Merge branch 'master' into master

src/Database/PostgreSQL.js

@@ -8,18 +8,23 @@ exports.ffiNewPool = function(config) {
     };
 };
 
-exports.ffiConnect = function (pool) {
+exports.ffiConnect = function (config) {
+    return function (pool) {
         return function (onError, onSuccess) {
-        var p = pool.connect(
+            var p = pool.connect().then(function(client) {
-            ).then(function(client) {
+                onSuccess(config.right({
-                onSuccess({
                     connection: client,
                     done: function() {
                         return client.release();
                     }
-                });
+                }));
             }).catch(function(err) {
+                var pgError = config.nullableLeft(err)
+                if (pgError) {
+                    onSuccess(pgError)
+                } else {
                     onError(err);
+                }
             });
 
             return function (cancelError, cancelerError, cancelerSuccess) {
@@ -28,8 +33,10 @@ exports.ffiConnect = function (pool) {
             };
         };
     };
+};
 
-exports.ffiUnsafeQuery = function(client) {
+exports.ffiUnsafeQuery = function(config) {
+    return function(client) {
         return function(sql) {
             return function(values) {
                 return function(onError, onSuccess) {
@@ -38,9 +45,14 @@ exports.ffiUnsafeQuery = function(client) {
                         values: values,
                         rowMode: 'array',
                     }).then(function(result) {
-                        onSuccess(result.rows);
+                        onSuccess(config.right(result))
                     }).catch(function(err) {
+                        var pgError = config.nullableLeft(err);
+                        if (pgError) {
+                            onSuccess(pgError)
+                        } else {
                             onError(err);
+                        }
                     });
 
                     return function (cancelError, cancelerError, cancelerSuccess) {
@@ -51,26 +63,30 @@ exports.ffiUnsafeQuery = function(client) {
             };
         };
     };
+};
 
-exports.ffiUnsafeCommand = function(client) {
+exports.ffiSQLState = function (error) {
-    return function(sql) {
+    return error.code || null;
-        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);
-                    });
 
-                return function (cancelError, cancelerError, cancelerSuccess) {
+exports.ffiErrorDetail = function (error) {
-                    q.cancel();
+    return {
-                    cancelerSuccess();
+        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 || ''
     };
+}

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
@@ -107,43 +125,66 @@ foreign import ffiNewPool
 withConnection
     :: ∀ a
      . Pool
-    -> (Connection -> Aff a)
+    -> (Connection -> PG a)
-    -> Aff a
+    -> PG a
 withConnection p k =
-  bracket
+    except <=< lift $ bracket (connect p) cleanup run
-    (connect p)
+    where
-    (liftEffect <<< _.done)
+    cleanup (Left _) = pure unit
-    (k <<< _.connection)
+    cleanup (Right { done }) = liftEffect done
+
+    run (Left err) = pure $ Left err
+    run (Right { connection }) = runExceptT $ k connection
 
 connect
     :: Pool
-    -> Aff
+    -> Aff (Either PGError ConnectResult)
+connect =
+    fromEffectFnAff
+    <<< ffiConnect
+            { nullableLeft: toNullable <<< map Left <<< convertError
+            , right: Right
+            }
+
+type ConnectResult =
     { connection :: Connection
     , done :: Effect Unit
     }
-connect = fromEffectFnAff <<< ffiConnect
 
 foreign import ffiConnect
-  :: Pool
+    :: ∀ a
-  -> EffectFnAff
+     . { nullableLeft :: Error -> Nullable (Either PGError ConnectResult)
-      { connection :: Connection
+       , right :: a -> Either PGError ConnectResult
-      , done :: Effect Unit
        }
+    -> 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
+    -> PG a
-    -> Aff a
+    -> PG a
 withTransaction conn action =
-    execute conn (Query "BEGIN TRANSACTION") Row0
+    begin *> lift (try $ runExceptT action) >>= case _ of
-    *> catchError (Right <$> action) (pure <<< Left) >>= case _ of
+        Left jsErr -> do
-        Right a -> execute conn (Query "COMMIT TRANSACTION") Row0 $> a
+            rollback
-        Left e -> execute conn (Query "ROLLBACK TRANSACTION") Row0 *> throwError e
+            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)
+    -> PG (Array o)
-query conn (Query sql) values =
+query conn (Query sql) values = do
-    unsafeQuery conn sql (toSQLRow values)
+    _.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
+    -> PG QueryResult
-unsafeCommand c s = fromEffectFnAff <<< ffiUnsafeCommand c s
+unsafeQuery c s =
+    except <=< lift <<< fromEffectFnAff <<< ffiUnsafeQuery p c s
+    where
+    p =
+        { nullableLeft: toNullable <<< map Left <<< convertError
+        , right: Right
+        }
 
-foreign import ffiUnsafeCommand
+foreign import ffiUnsafeQuery
-    :: Connection
+    :: { 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

test/Main.purs

@@ -4,13 +4,14 @@ module Test.Main
 
 import Prelude
 
-import Control.Monad.Error.Class (catchError, throwError, try)
+import Control.Monad.Error.Class (throwError, try)
-import Control.Monad.Free (Free)
+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.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
-  . Connection
+  → PG Unit
-  → Aff a
+  → PG Unit
-  → Aff Unit
+withRollback conn action =
-withRollback conn action = do
+    begin *> action *> rollback
-  execute conn (Query "BEGIN TRANSACTION") Row0
-  catchError (action >>= const rollback) (\e -> rollback >>= const (throwError e))
     where
-  rollback = execute conn (Query "ROLLBACK") Row0
+        begin = execute conn (Query "BEGIN TRANSACTION") Row0
+        rollback = execute conn (Query "ROLLBACK TRANSACTION") Row0
 
 test
-  ∷ ∀ a
+  ∷ Connection
-   . Connection
   → String
-  → Aff a
+  → PG Unit
-  → Free TestF Unit
+  → TestSuite
-test conn t a = Test.Unit.test t (withRollback conn a)
+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
@@ -68,9 +85,9 @@ main = do
     -- Running guide from README
     -- 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
@@ -210,14 +250,13 @@ main = do
             """) Row0
             liftEffect <<< assert $ sauerkrautPrice == [Row1 (D.fromString "3.30")]
 
-          test conn "constraint failure" $ do
+          transactionTest "integrity error handling" $ do
-            withTransaction conn $ do
+            withRollback conn do
-              result <- try $ execute conn (Query """
+              result <- onIntegrityError (pure "integrity error was handled") do
-                INSERT INTO foods (name)
+                insertFood
-                VALUES ($1)
+                insertFood
-              """) (Row1 "pork")
+                pure "integrity error was not handled"
-              liftEffect <<< assert $ isLeft result
+              liftEffect $ assert $ result == "integrity error was handled"
-            testCount 0
 
           test conn "handling date value" $ do
             let
@@ -235,7 +274,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
@@ -266,9 +305,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
@@ -279,3 +333,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 }