diff --git a/src/Database/PostgreSQL.js b/src/Database/PostgreSQL.js index b120a39..0884a3d 100644 --- a/src/Database/PostgreSQL.js +++ b/src/Database/PostgreSQL.js @@ -8,69 +8,85 @@ exports.ffiNewPool = function(config) { }; }; -exports.ffiConnect = function (pool) { - return function (onError, onSuccess) { - var p = pool.connect( - ).then(function(client) { - onSuccess({ +exports.ffiConnect = function (config) { + return function (pool) { + return function (onError, onSuccess) { + var p = pool.connect().then(function(client) { + onSuccess(config.right({ connection: client, done: function() { return client.release(); } - }); + })); }).catch(function(err) { - onError(err); + var pgError = config.nullableLeft(err) + if (pgError) { + onSuccess(pgError) + } else { + onError(err); + } }); - return function (cancelError, cancelerError, cancelerSuccess) { - p.cancel(); - cancelerSuccess(); + return function (cancelError, cancelerError, cancelerSuccess) { + p.cancel(); + cancelerSuccess(); + }; }; }; }; -exports.ffiUnsafeQuery = function(client) { - return function(sql) { - return function(values) { - return function(onError, onSuccess) { - var q = client.query({ +exports.ffiUnsafeQuery = function(config) { + return function(client) { + return function(sql) { + return function(values) { + return function(onError, onSuccess) { + var q = client.query({ text: sql, values: values, rowMode: 'array', }).then(function(result) { - onSuccess(result.rows); + onSuccess(config.right(result)) }).catch(function(err) { - onError(err); + var pgError = config.nullableLeft(err); + if (pgError) { + onSuccess(pgError) + } else { + onError(err); + } }); - return function (cancelError, cancelerError, cancelerSuccess) { - q.cancel(); - cancelerSuccess(); + return function (cancelError, cancelerError, cancelerSuccess) { + q.cancel(); + cancelerSuccess(); + }; }; }; }; }; }; -exports.ffiUnsafeCommand = function(client) { - return function(sql) { - return function(values) { - return function(onError, onSuccess) { - var q = client.query({ - text: sql, - values: values, - rowMode: 'array', - }).catch(function(err) { - onError(err); - }).then(function(result) { - onSuccess(result.rowCount); - }); +exports.ffiSQLState = function (error) { + return error.code || null; +} - return function (cancelError, cancelerError, cancelerSuccess) { - q.cancel(); - cancelerSuccess(); - }; - }; - }; +exports.ffiErrorDetail = function (error) { + return { + severity: error.severity || '', + code: error.code || '', + message: error.message || '', + detail: error.detail || '', + hint: error.hint || '', + position: error.position || '', + internalPosition: error.internalPosition || '', + internalQuery: error.internalQuery || '', + where_: error.where || '', + schema: error.schema || '', + table: error.table || '', + column: error.column || '', + dataType: error.dataType || '', + constraint: error.constraint || '', + file: error.file || '', + line: error.line || '', + routine: error.routine || '' }; -}; +} diff --git a/src/Database/PostgreSQL.purs b/src/Database/PostgreSQL.purs index ba502b8..ac29e6e 100644 --- a/src/Database/PostgreSQL.purs +++ b/src/Database/PostgreSQL.purs @@ -1,6 +1,9 @@ module Database.PostgreSQL ( module Row , module Value +, PG +, PGError(..) +, PGErrorDetail , Database , PoolConfiguration , Pool @@ -14,17 +17,23 @@ module Database.PostgreSQL , execute , query , scalar -, unsafeQuery +, onIntegrityError ) where import Prelude -import Control.Monad.Error.Class (catchError, throwError) +import Control.Monad.Error.Class (catchError, throwError, try) +import Control.Monad.Except.Trans (ExceptT, except, runExceptT) +import Control.Monad.Trans.Class (lift) import Data.Array (head) import Data.Either (Either(..)) -import Data.Maybe (Maybe(..)) +import Data.Generic.Rep (class Generic) +import Data.Generic.Rep.Show (genericShow) +import Data.Maybe (Maybe(..), maybe) import Data.Newtype (class Newtype) -import Data.Nullable (Nullable, toNullable) +import Data.Nullable (Nullable, toMaybe, toNullable) +import Data.String (Pattern(..)) +import Data.String as String import Data.Traversable (traverse) import Database.PostgreSQL.Row (class FromSQLRow, class ToSQLRow, Row0(..), Row1(..), Row10(..), Row11(..), Row12(..), Row13(..), Row14(..), Row15(..), Row16(..), Row17(..), Row18(..), Row19(..), Row2(..), Row3(..), Row4(..), Row5(..), Row6(..), Row7(..), Row8(..), Row9(..), fromSQLRow, toSQLRow) as Row import Database.PostgreSQL.Row (class FromSQLRow, class ToSQLRow, Row0(..), Row1(..), fromSQLRow, toSQLRow) @@ -34,11 +43,20 @@ import Effect (Effect) import Effect.Aff (Aff, bracket) import Effect.Aff.Compat (EffectFnAff, fromEffectFnAff) import Effect.Class (liftEffect) -import Effect.Exception (error) +import Effect.Exception (Error) import Foreign (Foreign) type Database = String +-- | PostgreSQL computations run in the `PG` monad. It's just `Aff` stacked with +-- | `ExceptT` to provide error handling. +-- | +-- | Errors originating from database queries or connection to the database are +-- | modeled with the `PGError` type. Use `runExceptT` from +-- | `Control.Monad.Except.Trans` to turn a `PG a` action into `Aff (Either +-- | PGError a)`. +type PG a = ExceptT PGError Aff a + -- | PostgreSQL connection pool configuration. type PoolConfiguration = { database :: Database @@ -75,17 +93,17 @@ derive instance newtypeQuery :: Newtype (Query i o) _ -- | Create a new connection pool. newPool :: PoolConfiguration -> Aff Pool newPool cfg = - liftEffect <<< ffiNewPool $ cfg' - where - cfg' = - { user: toNullable cfg.user - , password: toNullable cfg.password - , host: toNullable cfg.host - , port: toNullable cfg.port - , database: cfg.database - , max: toNullable cfg.max - , idleTimeoutMillis: toNullable cfg.idleTimeoutMillis - } + liftEffect <<< ffiNewPool $ cfg' + where + cfg' = + { user: toNullable cfg.user + , password: toNullable cfg.password + , host: toNullable cfg.host + , port: toNullable cfg.port + , database: cfg.database + , max: toNullable cfg.max + , idleTimeoutMillis: toNullable cfg.idleTimeoutMillis + } -- | Configuration which we actually pass to FFI. type PoolConfiguration' = @@ -107,43 +125,66 @@ foreign import ffiNewPool withConnection :: ∀ a . Pool - -> (Connection -> Aff a) - -> Aff a + -> (Connection -> PG a) + -> PG a withConnection p k = - bracket - (connect p) - (liftEffect <<< _.done) - (k <<< _.connection) + except <=< lift $ bracket (connect p) cleanup run + where + cleanup (Left _) = pure unit + cleanup (Right { done }) = liftEffect done + + run (Left err) = pure $ Left err + run (Right { connection }) = runExceptT $ k connection connect :: Pool - -> Aff - { connection :: Connection - , done :: Effect Unit - } -connect = fromEffectFnAff <<< ffiConnect + -> Aff (Either PGError ConnectResult) +connect = + fromEffectFnAff + <<< ffiConnect + { nullableLeft: toNullable <<< map Left <<< convertError + , right: Right + } + +type ConnectResult = + { connection :: Connection + , done :: Effect Unit + } foreign import ffiConnect - :: Pool - -> EffectFnAff - { connection :: Connection - , done :: Effect Unit - } + :: ∀ a + . { nullableLeft :: Error -> Nullable (Either PGError ConnectResult) + , right :: a -> Either PGError ConnectResult + } + -> Pool + -> EffectFnAff (Either PGError ConnectResult) -- | Run an action within a transaction. The transaction is committed if the --- | action returns, and rolled back when the action throws. If you want to +-- | action returns cleanly, and rolled back if the action throws (either a +-- | `PGError` or a JavaScript exception in the Aff context). If you want to -- | change the transaction mode, issue a separate `SET TRANSACTION` statement -- | within the transaction. withTransaction :: ∀ a . Connection - -> Aff a - -> Aff a + -> PG a + -> PG a withTransaction conn action = - execute conn (Query "BEGIN TRANSACTION") Row0 - *> catchError (Right <$> action) (pure <<< Left) >>= case _ of - Right a -> execute conn (Query "COMMIT TRANSACTION") Row0 $> a - Left e -> execute conn (Query "ROLLBACK TRANSACTION") Row0 *> throwError e + begin *> lift (try $ runExceptT action) >>= case _ of + Left jsErr -> do + rollback + lift $ throwError jsErr + Right (Left pgErr) -> do + rollback + throwError pgErr + Right (Right value) -> do + commit + pure value + + where + begin = execute conn (Query "BEGIN TRANSACTION") Row0 + commit = execute conn (Query "COMMIT TRANSACTION") Row0 + rollback = execute conn (Query "ROLLBACK TRANSACTION") Row0 -- | Execute a PostgreSQL query and discard its results. execute @@ -152,7 +193,7 @@ execute => Connection -> Query i o -> i - -> Aff Unit + -> PG Unit execute conn (Query sql) values = void $ unsafeQuery conn sql (toSQLRow values) @@ -164,12 +205,12 @@ query => Connection -> Query i o -> i - -> Aff (Array o) -query conn (Query sql) values = - unsafeQuery conn sql (toSQLRow values) + -> PG (Array o) +query conn (Query sql) values = do + _.rows <$> unsafeQuery conn sql (toSQLRow values) >>= traverse (fromSQLRow >>> case _ of Right row -> pure row - Left msg -> throwError (error msg)) + Left msg -> throwError $ ConversionError msg) -- | Execute a PostgreSQL query and return the first field of the first row in -- | the result. @@ -180,46 +221,130 @@ scalar => Connection -> Query i (Row1 o) -> i - -> Aff (Maybe o) + -> PG (Maybe o) scalar conn sql values = query conn sql values <#> map (case _ of Row1 a -> a) <<< head -unsafeQuery - :: Connection - -> String - -> Array Foreign - -> Aff (Array (Array Foreign)) -unsafeQuery c s = fromEffectFnAff <<< ffiUnsafeQuery c s - -foreign import ffiUnsafeQuery - :: Connection - -> String - -> Array Foreign - -> EffectFnAff (Array (Array Foreign)) - -- | Execute a PostgreSQL query and return its command tag value -- | (how many rows were affected by the query). This may be useful --- | for example with DELETE or UPDATE queries. +-- | for example with `DELETE` or `UPDATE` queries. command :: ∀ i . ToSQLRow i => Connection -> Query i Int -> i - -> Aff Int + -> PG Int command conn (Query sql) values = - unsafeCommand conn sql (toSQLRow values) + _.rowCount <$> unsafeQuery conn sql (toSQLRow values) -unsafeCommand +type QueryResult = + { rows :: Array (Array Foreign) + , rowCount :: Int + } + +unsafeQuery :: Connection -> String -> Array Foreign - -> Aff Int -unsafeCommand c s = fromEffectFnAff <<< ffiUnsafeCommand c s + -> PG QueryResult +unsafeQuery c s = + except <=< lift <<< fromEffectFnAff <<< ffiUnsafeQuery p c s + where + p = + { nullableLeft: toNullable <<< map Left <<< convertError + , right: Right + } -foreign import ffiUnsafeCommand - :: Connection +foreign import ffiUnsafeQuery + :: { nullableLeft :: Error -> Nullable (Either PGError QueryResult) + , right :: QueryResult -> Either PGError QueryResult + } + -> Connection -> String -> Array Foreign - -> EffectFnAff Int + -> EffectFnAff (Either PGError QueryResult) + +data PGError + = ConnectionError String + | ConversionError String + | InternalError PGErrorDetail + | OperationalError PGErrorDetail + | ProgrammingError PGErrorDetail + | IntegrityError PGErrorDetail + | DataError PGErrorDetail + | NotSupportedError PGErrorDetail + | QueryCanceledError PGErrorDetail + | TransactionRollbackError PGErrorDetail + +derive instance eqPGError :: Eq PGError +derive instance genericPGError :: Generic PGError _ + +instance showPGError :: Show PGError where + show = genericShow + +type PGErrorDetail = + { severity :: String + , code :: String + , message :: String + , detail :: String + , hint :: String + , position :: String + , internalPosition :: String + , internalQuery :: String + , where_ :: String + , schema :: String + , table :: String + , column :: String + , dataType :: String + , constraint :: String + , file :: String + , line :: String + , routine :: String + } + +foreign import ffiSQLState :: Error -> Nullable String +foreign import ffiErrorDetail :: Error -> PGErrorDetail + +convertError :: Error -> Maybe PGError +convertError err = + case toMaybe $ ffiSQLState err of + Nothing -> Nothing + Just sqlState -> Just $ convert sqlState $ ffiErrorDetail err + + where + convert :: String -> PGErrorDetail -> PGError + convert s = + if prefix "0A" s then NotSupportedError + else if prefix "20" s || prefix "21" s then ProgrammingError + else if prefix "22" s then DataError + else if prefix "23" s then IntegrityError + else if prefix "24" s || prefix "25" s then InternalError + else if prefix "26" s || prefix "27" s || prefix "28" s then OperationalError + else if prefix "2B" s || prefix "2D" s || prefix "2F" s then InternalError + else if prefix "34" s then OperationalError + else if prefix "38" s || prefix "39" s || prefix "3B" s then InternalError + else if prefix "3D" s || prefix "3F" s then ProgrammingError + else if prefix "40" s then TransactionRollbackError + else if prefix "42" s || prefix "44" s then ProgrammingError + else if s == "57014" then QueryCanceledError + else if prefix "5" s then OperationalError + else if prefix "F" s then InternalError + else if prefix "H" s then OperationalError + else if prefix "P" s then InternalError + else if prefix "X" s then InternalError + else const $ ConnectionError s + + prefix :: String -> String -> Boolean + prefix p = + maybe false (_ == 0) <<< String.indexOf (Pattern p) + +onIntegrityError :: forall a. PG a -> PG a -> PG a +onIntegrityError errorResult db = + catchError db handleError + where + handleError e = + case e of + IntegrityError _ -> errorResult + _ -> throwError e diff --git a/test/Main.purs b/test/Main.purs index 7eae202..9775c3d 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -4,13 +4,14 @@ module Test.Main import Prelude -import Control.Monad.Error.Class (catchError, throwError, try) -import Control.Monad.Free (Free) +import Control.Monad.Error.Class (throwError, try) +import Control.Monad.Except.Trans (runExceptT) +import Control.Monad.Trans.Class (lift) import Data.Array (zip) import Data.Date (Date, canonicalDate) import Data.DateTime.Instant (Instant, unInstant) import Data.Decimal as D -import Data.Either (isLeft) +import Data.Either (Either(..)) import Data.Enum (toEnum) import Data.Foldable (all, length) import Data.JSDate (JSDate, jsdate, toInstant) @@ -19,38 +20,54 @@ import Data.Maybe (Maybe(..), fromJust) import Data.Newtype (unwrap) import Data.Tuple (Tuple(..)) import Data.Tuple.Nested ((/\)) -import Database.PostgreSQL (Connection, PoolConfiguration, Query(Query), Row0(Row0), Row1(Row1), Row2(Row2), Row3(Row3), Row9(Row9), command, execute, newPool, query, scalar, withConnection, withTransaction) +import Database.PostgreSQL (Connection, PG, PGError(..), PoolConfiguration, Query(Query), Row0(Row0), Row1(Row1), Row2(Row2), Row3(Row3), Row9(Row9), command, execute, newPool, onIntegrityError, query, scalar, withConnection, withTransaction) import Effect (Effect) import Effect.Aff (Aff, error, launchAff) import Effect.Class (liftEffect) +import Effect.Exception (message) import Foreign.Object (Object, fromFoldable) import Math ((%)) import Partial.Unsafe (unsafePartial) import Test.Assert (assert) import Test.Example (run) as Example -import Test.Unit (TestF, suite) +import Test.Unit (TestSuite, suite) import Test.Unit as Test.Unit import Test.Unit.Assert (equal) import Test.Unit.Main (runTest) +pgEqual :: forall a. Eq a => Show a => a -> a -> PG Unit +pgEqual a b = lift $ equal a b + withRollback - ∷ ∀ a - . Connection - → Aff a - → Aff Unit -withRollback conn action = do - execute conn (Query "BEGIN TRANSACTION") Row0 - catchError (action >>= const rollback) (\e -> rollback >>= const (throwError e)) - where - rollback = execute conn (Query "ROLLBACK") Row0 + ∷ Connection + → PG Unit + → PG Unit +withRollback conn action = + begin *> action *> rollback + where + begin = execute conn (Query "BEGIN TRANSACTION") Row0 + rollback = execute conn (Query "ROLLBACK TRANSACTION") Row0 test - ∷ ∀ a - . Connection + ∷ Connection → String - → Aff a - → Free TestF Unit -test conn t a = Test.Unit.test t (withRollback conn a) + → PG Unit + → TestSuite +test conn name action = + Test.Unit.test name $ checkPGErrors $ withRollback conn action + +transactionTest + ∷ String + → PG Unit + → TestSuite +transactionTest name action = + Test.Unit.test name $ checkPGErrors $ action + +checkPGErrors :: PG Unit -> Aff Unit +checkPGErrors action = do + runExceptT action >>= case _ of + Left pgError -> Test.Unit.failure "Unexpected PostgreSQL error occured" + Right _ -> pure unit now ∷ Effect Instant now = unsafePartial $ (fromJust <<< toInstant) <$> JSDate.now @@ -66,11 +83,11 @@ main ∷ Effect Unit main = do void $ launchAff do -- Running guide from README - Example.run + --Example.run - -- Acctual test suite + -- Actual test suite pool <- newPool config - withConnection pool \conn -> do + checkPGErrors $ withConnection pool \conn -> do execute conn (Query """ CREATE TEMPORARY TABLE foods ( name text NOT NULL, @@ -92,7 +109,7 @@ main = do """) Row0 liftEffect $ runTest $ do - suite "Postgresql client" $ do + suite "PostgreSQL client" $ do let testCount n = do count <- scalar conn (Query """ @@ -101,7 +118,7 @@ main = do """) (Row1 n) liftEffect <<< assert $ count == Just true - Test.Unit.test "transaction commit" $ do + transactionTest "transaction commit" do withTransaction conn do execute conn (Query """ INSERT INTO foods (name, delicious, price) @@ -113,14 +130,37 @@ main = do DELETE FROM foods """) Row0 - Test.Unit.test "transaction rollback" $ do + transactionTest "transaction rollback on PostgreSQL error" $ do _ <- try $ withTransaction conn do execute conn (Query """ INSERT INTO foods (name, delicious, price) VALUES ($1, $2, $3) """) (Row3 "pork" true (D.fromString "8.30")) testCount 1 - throwError $ error "fail" + + -- invalid SQL query --> PGError is thrown + execute conn (Query "foo bar") Row0 + + -- transaction should've been rolled back + testCount 0 + + transactionTest "transaction rollback on JavaScript exception" $ do + result <- lift $ try $ runExceptT $ withTransaction conn do + execute conn (Query """ + INSERT INTO foods (name, delicious, price) + VALUES ($1, $2, $3) + """) (Row3 "pork" true (D.fromString "8.30")) + testCount 1 + + -- throw a JavaScript error + lift $ throwError $ error "fail" + + -- make sure the JavaScript error was thrown + liftEffect $ case result of + Left jsErr -> assert (message jsErr == "fail") + Right _ -> assert false + + -- transaction should've been rolled back testCount 0 test conn "usage of rows represented by nested tuples" $ do @@ -201,14 +241,13 @@ main = do """) Row0 liftEffect <<< assert $ sauerkrautPrice == [Row1 (D.fromString "3.30")] - test conn "constraint failure" $ do - withTransaction conn $ do - result <- try $ execute conn (Query """ - INSERT INTO foods (name) - VALUES ($1) - """) (Row1 "pork") - liftEffect <<< assert $ isLeft result - testCount 0 + transactionTest "integrity error handling" $ do + withRollback conn do + result <- onIntegrityError (pure "integrity error was handled") do + insertFood + insertFood + pure "integrity error was not handled" + liftEffect $ assert $ result == "integrity error was handled" test conn "handling date value" $ do let @@ -226,7 +265,7 @@ main = do FROM dates ORDER BY date ASC """) Row0 - equal 3 (length dates) + pgEqual 3 (length dates) liftEffect <<< assert $ all (\(Tuple (Row1 r) e) -> e == r) $ (zip dates [d1, d2, d3]) test conn "handling json and jsonb value" $ do @@ -257,9 +296,24 @@ main = do FROM timestamps ORDER BY timestamp ASC """) Row0 - equal 3 (length timestamps) + pgEqual 3 (length timestamps) liftEffect <<< assert $ all (\(Tuple (Row1 r) e) -> e == r) $ (zip timestamps [jsd1, jsd2, jsd3]) + suite "PostgreSQL connection errors" $ do + let doNothing _ = pure unit + + Test.Unit.test "connection refused" do + testPool <- newPool cannotConnectConfig + runExceptT (withConnection testPool doNothing) >>= case _ of + Left (ConnectionError cause) -> equal cause "ECONNREFUSED" + _ -> Test.Unit.failure "foo" + + Test.Unit.test "no such database" do + testPool <- newPool noSuchDatabaseConfig + runExceptT (withConnection testPool doNothing) >>= case _ of + Left (ProgrammingError { code, message }) -> equal code "3D000" + _ -> Test.Unit.failure "PostgreSQL error was expected" + config :: PoolConfiguration config = { user: Nothing @@ -270,3 +324,11 @@ config = , max: Nothing , idleTimeoutMillis: Just 1000 } + +noSuchDatabaseConfig :: PoolConfiguration +noSuchDatabaseConfig = + config { database = "this-database-does-not-exist" } + +cannotConnectConfig :: PoolConfiguration +cannotConnectConfig = + config { host = Just "127.0.0.1", port = Just 45287 }