Separate Pool module. Make test database configurable.

.env-example

@@ -0,0 +1,3 @@
+PG_DB="purspg"
+PG_PORT=6432
+PG_IDLE_TIMEOUT_MILLISECONDS=1000

README.md

@@ -19,8 +19,9 @@ module Test.README where
 import Prelude
 
 import Control.Monad.Except.Trans (ExceptT, runExceptT)
-import Database.PostgreSQL.PG (defaultPoolConfiguration, PGError, command, execute, newPool, Pool, Connection, query, Query(Query))
+import Database.PostgreSQL.PG (defaultConfiguration, PGError, command, execute, Pool, Connection, query, Query(Query))
 import Database.PostgreSQL.PG as PG
+import Database.PostgreSQL.Pool (new) as Pool
 import Database.PostgreSQL.Row (Row0(Row0), Row3(Row3))
 import Data.Decimal as Decimal
 import Data.Maybe (Maybe(..))
@@ -31,7 +32,7 @@ import Test.Assert (assert)
 ```
 
 The whole API for interaction with PostgreSQL is performed asynchronously in `Aff`
-(the only function which runs in plain `Effect` is `newPool`). Core library
+(the only function which runs in plain `Effect` is `Pool.new`). Core library
 functions usually results in somthing like `Aff (Either PGError a)` which can be easily
 wrapped by user into `ExceptT` or any other custom monad stack.
 To be honest we provide alternatives to functions in the `Database.PostgreSQL.PG` module that work on any stack `m` with `MonadError PGError m` and `MonadAff m`.
@@ -50,7 +51,7 @@ withTransaction = PG.withTransaction runExceptT
 ```
 
 We assume here that Postgres is running on a standard local port
-with `ident` authentication so configuration can be nearly empty (`defaultPoolConfiguration`).
+with `ident` authentication so configuration can be nearly empty (`defaultConfiguration`).
 It requires only database name which we pass to `newPool` function.
 Additionally we pass `idleTimeoutMillis` value because this code
 is run by our test suite and we want to exit after its execution quickly ;-)
@@ -60,8 +61,8 @@ is run by our test suite and we want to exit after its execution quickly ;-)
 run ∷ PG Unit
 run = do
 
-  pool <- liftEffect $ newPool
+  pool <- liftEffect $ Pool.new
-    ((defaultPoolConfiguration "purspg") { idleTimeoutMillis = Just 1000 })
+    ((defaultConfiguration "purspg") { idleTimeoutMillis = Just 1000 })
   withConnection pool \conn -> do
 ```
 
@@ -151,16 +152,7 @@ generator instead of a preprocessor, and easier to use.
 
 ### Testing
 
-Currently tests are prepared to work with default and local setup for postgresql (ident authentication, standard port etc.).
+Test database is read from the environment or loaded from _.env_ file. You can find _.env-example_ in the repo with some simple testing db setup.
-If you think that we should add configuration layer for our test runner please open an issue.
-
-To run suite please:
-
-  * `$ npm install`
-
-  * `$ createdb purspg`
-
-  * `$ npm run test`
 
 ### Releasing
 

package.json

@@ -2,7 +2,8 @@
   "name": "purescript-postgresql-client",
   "dependencies": {
     "decimal.js": "^10.0.0",
-    "pg": "^6.1.2"
+    "pg": "^6.4.2",
+    "postgres": "^1.0.2"
   },
   "devDependencies": {
     "github-release-notes": "^0.17.1",

packages.dhall

@@ -116,6 +116,31 @@ let upstream =
 
 let overrides = {=}
 
-let additions = {=}
+let polyform = mkPackage
+  [ "debug", "foreign", "foreign-object", "generics-rep", "invariant", "newtype"
+  , "ordered-collections", "parsing", "psci-support", "profunctor", "quickcheck-laws"
+  , "run", "test-unit", "transformers", "validation", "variant"
+  ]
+  "https://github.com/purescript-polyform/polyform.git"
+  "master"
+
+let polyform-batteries = mkPackage
+  [ "affjax", "argonaut", "debug", "decimals", "filterable"
+  , "numbers", "polyform", "prelude", "record-extra"
+  , "test-unit"
+  ]
+  "https://github.com/purescript-polyform/batteries.git"
+  "master"
+
+let polyform-batteries-env = mkPackage
+  [ "polyform-batteries" ]
+  "https://github.com/purescript-polyform/batteries-env.git"
+  "master"
+
+let additions =
+  { polyform = polyform
+  , polyform-batteries = polyform-batteries
+  , polyform-batteries-env = polyform-batteries-env
+  }
 
 in  upstream // overrides // additions

spago.dhall

@@ -14,6 +14,7 @@ You can edit this file as you like.
   , "console"
   , "datetime"
   , "decimals"
+  , "dotenv"
   , "effect"
   , "either"
   , "exceptions"
@@ -25,7 +26,10 @@ You can edit this file as you like.
   , "lists"
   , "maybe"
   , "newtype"
+  , "node-fs"
+  , "node-process"
   , "nullable"
+  , "polyform-batteries-env"
   , "prelude"
   , "psci-support"
   , "string-parsers"

src/Database/PostgreSQL.js

@@ -4,9 +4,9 @@
 'use strict';
 
 // `pg related code/bindings are done here as we want to
-// allow web related modules to access `PostgreSQL.*` classes.
+// allow frontend modules to access `PostgreSQL.*` classes too.
-// Putting this import into `PostgreSQL/Value.js` caused problem
+// Putting this import into `PostgreSQL/Value.js` caused is a problem
-// with web bundlers.
+// for the web bundlers etc.
 
 var pg = require('pg');
 
@@ -15,12 +15,6 @@ var pg = require('pg');
 // to prevent this craziness
 pg.types.setTypeParser(1082 /* DATE_OID */, function(dateString) { return dateString; });
 
-exports.ffiNewPool = function(config) {
-    return function() {
-        return new pg.Pool(config);
-    };
-};
-
 exports.ffiConnect = function (config) {
     return function (pool) {
         return function (onError, onSuccess) {

src/Database/PostgreSQL.purs

@@ -1,26 +1,20 @@
 module Database.PostgreSQL
-( module Row
+  ( module Pool
-, module Value
+  , module Row
-, PGError(..)
+  , module Value
-, PGErrorDetail
+  , PGError(..)
-, Database
+  , PGErrorDetail
-, PoolConfiguration
+  , Connection
-, Pool
+  , ConnectResult
-, Connection
+  , Query(..)
-, ConnectResult
+  , connect
-, Query(..)
+  , withConnection
-, PgConnectionUri
+  , withTransaction
-, newPool
+  , command
-, connect
+  , execute
-, withConnection
+  , query
-, withTransaction
+  , scalar
-, defaultPoolConfiguration
+  ) where
-, getDefaultPoolConfigurationByUri
-, command
-, execute
-, query
-, scalar
-) where
 
 import Prelude
 
@@ -30,14 +24,14 @@ import Data.Bifunctor (lmap)
 import Data.Either (Either(..), either, hush)
 import Data.Generic.Rep (class Generic)
 import Data.Generic.Rep.Show (genericShow)
-import Data.Int (fromString)
 import Data.Maybe (Maybe(..), maybe)
 import Data.Newtype (class Newtype)
 import Data.Nullable (Nullable, toMaybe, toNullable)
 import Data.String (Pattern(..))
 import Data.String as String
-import Data.String.CodeUnits (singleton)
+import Data.Traversable (traverse)
-import Data.Traversable (foldMap, traverse)
+import Database.PostgreSQL.Pool (Configuration, Database, parseURI, PGConnectionURI, new, Pool, defaultConfiguration) as Pool
+import Database.PostgreSQL.Pool (Pool)
 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)
 import Database.PostgreSQL.Value (class FromSQLValue)
@@ -48,258 +42,182 @@ import Effect.Aff.Compat (EffectFnAff, fromEffectFnAff)
 import Effect.Class (liftEffect)
 import Effect.Exception (Error)
 import Foreign (Foreign)
-import Text.Parsing.StringParser (runParser)
-import Text.Parsing.StringParser.CodePoints (anyChar, char, string)
-import Text.Parsing.StringParser.Combinators (many, manyTill)
-
-type Database = String
-
--- | PostgreSQL connection pool configuration.
-type PoolConfiguration =
-    { database :: Database
-    , host :: Maybe String
-    , idleTimeoutMillis :: Maybe Int
-    , max :: Maybe Int
-    , password :: Maybe String
-    , port :: Maybe Int
-    , user :: Maybe String
-    }
-
-defaultPoolConfiguration :: Database -> PoolConfiguration
-defaultPoolConfiguration database =
-    { database
-    , host: Nothing
-    , idleTimeoutMillis: Nothing
-    , max: Nothing
-    , password: Nothing
-    , port: Nothing
-    , user: Nothing
-    }
-
-type PgConnectionUri = String
-
--- | Get the default pool configuration from postgres connection uri
-getDefaultPoolConfigurationByUri :: PgConnectionUri -> Maybe PoolConfiguration
-getDefaultPoolConfigurationByUri uri = hush $ flip runParser uri do
-  _ <- string "postgres://"
-  user <- tillChar (char ':')
-  password <- tillChar (char '@')
-  host <- tillChar (char ':')
-  port <- tillChar (char '/')
-  database <- many anyChar
-  pure { database: toStr database
-       , host: Just $ toStr host
-       , idleTimeoutMillis: Nothing
-       , max: Nothing
-       , password: Just $ toStr password
-       , port: fromString $ toStr port
-       , user: Just $ toStr user
-       }
-  where tillChar = manyTill anyChar
-        toStr = foldMap singleton
-
--- | PostgreSQL connection pool.
-foreign import data Pool :: Type
 
 -- | PostgreSQL connection.
 foreign import data Connection :: Type
 
 -- | PostgreSQL query with parameter (`$1`, `$2`, …) and return types.
-newtype Query i o = Query String
+newtype Query i o
+  = Query String
 
 derive instance newtypeQuery :: Newtype (Query i o) _
 
--- | Create a new connection pool.
-newPool :: PoolConfiguration -> Effect Pool
-newPool cfg =
-    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' =
-    { user :: Nullable String
-    , password :: Nullable String
-    , host :: Nullable String
-    , port :: Nullable Int
-    , database :: String
-    , max :: Nullable Int
-    , idleTimeoutMillis :: Nullable Int
-    }
-
-foreign import ffiNewPool
-    :: PoolConfiguration'
-    -> Effect Pool
-
 -- | Run an action with a connection. The connection is released to the pool
 -- | when the action returns.
-withConnection
+withConnection ::
-    :: forall a
+  forall a.
-     . Pool
+  Pool ->
-    -> (Either PGError Connection -> Aff a)
+  (Either PGError Connection -> Aff a) ->
-    -> Aff a
+  Aff a
-withConnection p k =
+withConnection p k = bracket (connect p) cleanup run
-    bracket (connect p) cleanup run
+  where
-    where
+  cleanup (Left _) = pure unit
-    cleanup (Left _) = pure unit
-    cleanup (Right { done }) = liftEffect done
 
-    run (Left err) = k (Left err)
+  cleanup (Right { done }) = liftEffect done
-    run (Right { connection }) = k (Right connection)
 
-connect
+  run (Left err) = k (Left err)
-    :: Pool
+
-    -> Aff (Either PGError ConnectResult)
+  run (Right { connection }) = k (Right connection)
+
+connect ::
+  Pool ->
+  Aff (Either PGError ConnectResult)
 connect =
-    fromEffectFnAff
+  fromEffectFnAff
     <<< ffiConnect
-            { nullableLeft: toNullable <<< map Left <<< convertError
+        { nullableLeft: toNullable <<< map Left <<< convertError
-            , right: Right
+        , right: Right
-            }
+        }
 
-type ConnectResult =
+type ConnectResult
-    { connection :: Connection
+  = { connection :: Connection
     , done :: Effect Unit
     }
 
-foreign import ffiConnect
+foreign import ffiConnect ::
-    :: forall a
+  forall a.
-     . { nullableLeft :: Error -> Nullable (Either PGError ConnectResult)
+  { nullableLeft :: Error -> Nullable (Either PGError ConnectResult)
-       , right :: a -> Either PGError ConnectResult
+  , right :: a -> Either PGError ConnectResult
-       }
+  } ->
-    -> Pool
+  Pool ->
-    -> EffectFnAff (Either PGError ConnectResult)
+  EffectFnAff (Either PGError ConnectResult)
 
 -- | Run an action within a transaction. The transaction is committed if the
 -- | 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
+withTransaction ::
-    :: forall a
+  forall a.
-     . Connection
+  Connection ->
-    -> Aff a
+  Aff a ->
-    -> Aff (Either PGError a)
+  Aff (Either PGError a)
 withTransaction conn action =
-    begin >>= case _ of
+  begin
-      Nothing → do
+    >>= case _ of
-        a ← action `catchError` \jsErr → do
+        Nothing -> do
-          void $ rollback
+          a <-
-          throwError jsErr
+            action
-        commit >>= case _ of
+              `catchError`
-          Just pgError → pure (Left pgError)
+                \jsErr -> do
-          Nothing → pure (Right a)
+                  void $ rollback
-      Just pgError → pure (Left pgError)
+                  throwError jsErr
-    where
+          commit
-    begin = execute conn (Query "BEGIN TRANSACTION") Row0
+            >>= case _ of
-    commit = execute conn (Query "COMMIT TRANSACTION") Row0
+                Just pgError -> pure (Left pgError)
-    rollback = execute conn (Query "ROLLBACK TRANSACTION") Row0
+                Nothing -> pure (Right a)
+        Just pgError -> pure (Left pgError)
+  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
+execute ::
-    :: forall i o
+  forall i o.
-     . (ToSQLRow i)
+  (ToSQLRow i) =>
-    => Connection
+  Connection ->
-    -> Query i o
+  Query i o ->
-    -> i
+  i ->
-    -> Aff (Maybe PGError)
+  Aff (Maybe PGError)
-execute conn (Query sql) values =
+execute conn (Query sql) values = hush <<< either Right Left <$> unsafeQuery conn sql (toSQLRow values)
-    hush <<< either Right Left <$> unsafeQuery conn sql (toSQLRow values)
 
 -- | Execute a PostgreSQL query and return its results.
-query
+query ::
-    :: forall i o
+  forall i o.
-     . ToSQLRow i
+  ToSQLRow i =>
-    => FromSQLRow o
+  FromSQLRow o =>
-    => Connection
+  Connection ->
-    -> Query i o
+  Query i o ->
-    -> i
+  i ->
-    -> Aff (Either PGError (Array o))
+  Aff (Either PGError (Array o))
 query conn (Query sql) values = do
-    r <- unsafeQuery conn sql (toSQLRow values)
+  r <- unsafeQuery conn sql (toSQLRow values)
-    pure $ r >>= _.rows >>> traverse (fromSQLRow >>> lmap ConversionError)
+  pure $ r >>= _.rows >>> traverse (fromSQLRow >>> lmap ConversionError)
 
 -- | Execute a PostgreSQL query and return the first field of the first row in
 -- | the result.
-scalar
+scalar ::
-    :: forall i o
+  forall i o.
-     . ToSQLRow i
+  ToSQLRow i =>
-    => FromSQLValue o
+  FromSQLValue o =>
-    => Connection
+  Connection ->
-    -> Query i (Row1 o)
+  Query i (Row1 o) ->
-    -> i
+  i ->
-    -> Aff (Either PGError (Maybe o))
+  Aff (Either PGError (Maybe o))
-scalar conn sql values =
+scalar conn sql values = query conn sql values <#> map (head >>> map (case _ of Row1 a -> a))
-    query conn sql values <#> map (head >>> map (case _ of Row1 a -> a))
 
 -- | 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.
-command
+command ::
-    :: forall i
+  forall i.
-     . ToSQLRow i
+  ToSQLRow i =>
-    => Connection
+  Connection ->
-    -> Query i Int
+  Query i Int ->
-    -> i
+  i ->
-    -> Aff (Either PGError Int)
+  Aff (Either PGError Int)
-command conn (Query sql) values =
+command conn (Query sql) values = map _.rowCount <$> unsafeQuery conn sql (toSQLRow values)
-    map _.rowCount <$> unsafeQuery conn sql (toSQLRow values)
 
-type QueryResult =
+type QueryResult
-    { rows :: Array (Array Foreign)
+  = { rows :: Array (Array Foreign)
     , rowCount :: Int
     }
 
-unsafeQuery
+unsafeQuery ::
-    :: Connection
+  Connection ->
-    -> String
+  String ->
-    -> Array Foreign
+  Array Foreign ->
-    -> Aff (Either PGError QueryResult)
+  Aff (Either PGError QueryResult)
-unsafeQuery c s =
+unsafeQuery c s = fromEffectFnAff <<< ffiUnsafeQuery p c s
-    fromEffectFnAff <<< ffiUnsafeQuery p c s
+  where
-    where
+  p =
-    p =
+    { nullableLeft: toNullable <<< map Left <<< convertError
-        { nullableLeft: toNullable <<< map Left <<< convertError
+    , right: Right
-        , right: Right
+    }
-        }
 
-foreign import ffiUnsafeQuery
+foreign import ffiUnsafeQuery ::
-    :: { nullableLeft :: Error -> Nullable (Either PGError QueryResult)
+  { nullableLeft :: Error -> Nullable (Either PGError QueryResult)
-       , right :: QueryResult -> Either PGError QueryResult
+  , right :: QueryResult -> Either PGError QueryResult
-       }
+  } ->
-    -> Connection
+  Connection ->
-    -> String
+  String ->
-    -> Array Foreign
+  Array Foreign ->
-    -> EffectFnAff (Either PGError QueryResult)
+  EffectFnAff (Either PGError QueryResult)
 
 data PGError
-    = ConnectionError String
+  = ConnectionError String
-    | ConversionError String
+  | ConversionError String
-    | InternalError PGErrorDetail
+  | InternalError PGErrorDetail
-    | OperationalError PGErrorDetail
+  | OperationalError PGErrorDetail
-    | ProgrammingError PGErrorDetail
+  | ProgrammingError PGErrorDetail
-    | IntegrityError PGErrorDetail
+  | IntegrityError PGErrorDetail
-    | DataError PGErrorDetail
+  | DataError PGErrorDetail
-    | NotSupportedError PGErrorDetail
+  | NotSupportedError PGErrorDetail
-    | QueryCanceledError PGErrorDetail
+  | QueryCanceledError PGErrorDetail
-    | TransactionRollbackError PGErrorDetail
+  | TransactionRollbackError PGErrorDetail
 
 derive instance eqPGError :: Eq PGError
+
 derive instance genericPGError :: Generic PGError _
 
 instance showPGError :: Show PGError where
-    show = genericShow
+  show = genericShow
 
-type PGErrorDetail =
+type PGErrorDetail
-    { severity :: String
+  = { severity :: String
     , code :: String
     , message :: String
     , detail :: String
@@ -319,40 +237,74 @@ type PGErrorDetail =
     }
 
 foreign import ffiSQLState :: Error -> Nullable String
+
 foreign import ffiErrorDetail :: Error -> PGErrorDetail
 
 convertError :: Error -> Maybe PGError
-convertError err =
+convertError err = case toMaybe $ ffiSQLState err of
-    case toMaybe $ ffiSQLState err of
+  Nothing -> Nothing
-        Nothing -> Nothing
+  Just sqlState -> Just $ convert sqlState $ ffiErrorDetail err
-        Just sqlState -> Just $ convert sqlState $ ffiErrorDetail err
-
   where
-      convert :: String -> PGErrorDetail -> PGError
+  convert :: String -> PGErrorDetail -> PGError
-      convert s =
+  convert s =
-          if prefix "0A" s then NotSupportedError
+    if prefix "0A" s then
-          else if prefix "20" s || prefix "21" s then ProgrammingError
+      NotSupportedError
-          else if prefix "22" s then DataError
+    else
-          else if prefix "23" s then IntegrityError
+      if prefix "20" s || prefix "21" s then
-          else if prefix "24" s || prefix "25" s then InternalError
+        ProgrammingError
-          else if prefix "26" s || prefix "27" s || prefix "28" s then OperationalError
+      else
-          else if prefix "2B" s || prefix "2D" s || prefix "2F" s then InternalError
+        if prefix "22" s then
-          else if prefix "34" s then OperationalError
+          DataError
-          else if prefix "38" s || prefix "39" s || prefix "3B" s then InternalError
+        else
-          else if prefix "3D" s || prefix "3F" s then ProgrammingError
+          if prefix "23" s then
-          else if prefix "40" s then TransactionRollbackError
+            IntegrityError
-          else if prefix "42" s || prefix "44" s then ProgrammingError
+          else
-          else if s == "57014" then QueryCanceledError
+            if prefix "24" s || prefix "25" s then
-          else if prefix "5" s then OperationalError
+              InternalError
-          else if prefix "F" s then InternalError
+            else
-          else if prefix "H" s then OperationalError
+              if prefix "26" s || prefix "27" s || prefix "28" s then
-          else if prefix "P" s then InternalError
+                OperationalError
-          else if prefix "X" s then InternalError
+              else
-          else const $ ConnectionError s
+                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 :: String -> String -> Boolean
-      prefix p =
+  prefix p = maybe false (_ == 0) <<< String.indexOf (Pattern p)
-          maybe false (_ == 0) <<< String.indexOf (Pattern p)
 
 -- onIntegrityError :: forall a. PG a -> PG a -> PG a
 -- onIntegrityError errorResult db =

src/Database/PostgreSQL/PG.purs

@@ -17,7 +17,7 @@ import Control.Monad.Error.Class (class MonadError, catchError, throwError)
 import Data.Either (Either(..), either)
 import Data.Maybe (Maybe, maybe)
 import Database.PostgreSQL (Connection, PGError(..), Pool, Query)
-import Database.PostgreSQL (class FromSQLRow, class FromSQLValue, class ToSQLRow, class ToSQLValue, Connection, Database, PGError(..), PGErrorDetail, Pool, PoolConfiguration, Query(..), Row0(..), Row1(..), Row10(..), Row11(..), Row12(..), Row13(..), Row14(..), Row15(..), Row16(..), Row17(..), Row18(..), Row19(..), Row2(..), Row3(..), Row4(..), Row5(..), Row6(..), Row7(..), Row8(..), Row9(..), defaultPoolConfiguration, fromSQLRow, fromSQLValue, instantFromString, instantToString, newPool, null, toSQLRow, toSQLValue, unsafeIsBuffer) as PostgreSQL
+import Database.PostgreSQL (class FromSQLRow, class FromSQLValue, class ToSQLRow, class ToSQLValue, Connection, Database, PGError(..), PGErrorDetail, Pool, Configuration, Query(..), Row0(..), Row1(..), Row10(..), Row11(..), Row12(..), Row13(..), Row14(..), Row15(..), Row16(..), Row17(..), Row18(..), Row19(..), Row2(..), Row3(..), Row4(..), Row5(..), Row6(..), Row7(..), Row8(..), Row9(..), defaultConfiguration, fromSQLRow, fromSQLValue, instantFromString, instantToString, new, null, toSQLRow, toSQLValue, unsafeIsBuffer) as PostgreSQL
 import Database.PostgreSQL (command, execute, query, scalar, withConnection, withTransaction) as P
 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, Row1)

src/Database/PostgreSQL/Pool.js

@@ -0,0 +1,28 @@
+var pg = require('pg');
+
+"use sctrict";
+
+exports.ffiNew = function(config) {
+    return function() {
+        return new pg.Pool(config);
+    };
+};
+
+
+exports.totalCount = function(pool) {
+  return function() {
+    return pool.totalCount();
+  };
+};
+
+exports.idleCount = function(pool) {
+  return function() {
+    return pool.idleCount();
+  };
+};
+
+exports.waitingCount = function(pool) {
+  return function() {
+    return pool.waitingCount();
+  };
+};

src/Database/PostgreSQL/Pool.purs

@@ -0,0 +1,121 @@
+module Database.PostgreSQL.Pool
+  ( defaultConfiguration
+  , Database
+  , idleCount
+  , new
+  , Configuration
+  , parseURI
+  , PGConnectionURI
+  , Pool
+  , totalCount
+  , waitingCount
+  )
+  where
+
+import Prelude (bind, flip, pure, ($))
+
+import Data.Either (hush)
+import Data.Int (fromString)
+import Data.Maybe (Maybe(..))
+import Data.Nullable (Nullable, toNullable)
+import Data.String.CodeUnits (singleton)
+import Data.Traversable (foldMap)
+import Effect (Effect)
+import Text.Parsing.StringParser (runParser)
+import Text.Parsing.StringParser.CodePoints (anyChar, char, string)
+import Text.Parsing.StringParser.Combinators (many, manyTill)
+
+-- | PostgreSQL connection pool.
+foreign import data Pool :: Type
+
+type Database
+  = String
+
+-- | Configuration which we actually pass to FFI.
+type Configuration'
+  = { user :: Nullable String
+    , password :: Nullable String
+    , host :: Nullable String
+    , port :: Nullable Int
+    , database :: String
+    , max :: Nullable Int
+    , idleTimeoutMillis :: Nullable Int
+    }
+
+-- | PostgreSQL connection pool configuration.
+type Configuration
+  = { database :: Database
+    , host :: Maybe String
+    , idleTimeoutMillis :: Maybe Int
+    , max :: Maybe Int
+    , password :: Maybe String
+    , port :: Maybe Int
+    , user :: Maybe String
+    }
+
+type PGConnectionURI
+  = String
+
+-- | Get the default pool configuration from postgres connection uri
+-- | TODO:
+-- | * Do we really want to keep parsing dependency to handle config string?
+-- | * In such a case we should improve parsing (validate port etc.)
+parseURI :: PGConnectionURI -> Maybe Configuration
+parseURI uri =
+  hush
+    $ flip runParser uri do
+        _ <- string "postgres://"
+        user <- tillChar (char ':')
+        password <- tillChar (char '@')
+        host <- tillChar (char ':')
+        port <- tillChar (char '/')
+        database <- many anyChar
+        pure
+          { database: toStr database
+          , host: Just $ toStr host
+          , idleTimeoutMillis: Nothing
+          , max: Nothing
+          , password: Just $ toStr password
+          , port: fromString $ toStr port
+          , user: Just $ toStr user
+          }
+  where
+  tillChar = manyTill anyChar
+
+  toStr = foldMap singleton
+
+defaultConfiguration :: Database -> Configuration
+defaultConfiguration database =
+  { database
+  , host: Nothing
+  , idleTimeoutMillis: Nothing
+  , max: Nothing
+  , password: Nothing
+  , port: Nothing
+  , user: Nothing
+  }
+
+foreign import ffiNew ::
+  Configuration' ->
+  Effect Pool
+
+-- | Create a new connection pool.
+new :: Configuration -> Effect Pool
+new cfg = ffiNew $ 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
+    }
+
+foreign import totalCount :: Pool -> Effect Int
+
+foreign import idleCount :: Pool -> Effect Int
+
+foreign import waitingCount :: Pool -> Effect Int
+

src/Database/PostgreSQL/RowList.purs

@@ -0,0 +1,22 @@
+module Data.PostgreSQL.RowList where
+
+-- import Prim.RowList (Cons, Nil) as RowList
+-- import Prim.RowList (kind RowList)
+-- 
+-- infixl 10 type RowList.Cons as :
+-- 
+-- type Apply (f :: RowList -> RowList) (a ∷ RowList) = f a
+-- 
+-- infixr 0 type Apply as $
+-- 
+-- type R = "test" : Int $ "fest" : String $ RowList.Nil
+-- 
+-- instance fromSQLRowRow0 :: FromSQLRow RowList.Nil where
+--   fromSQLRow [] =
+--     pure Row0
+--   fromSQLRow xs = Left $ "Row has " <> show n <> " fields, expecting 0."
+--     where n = Array.length xs
+-- 
+-- instance toSQLRowRow0 :: ToSQLRow Row0 where
+--   toSQLRow Row0 = []
+-- -- | A row with 1 field.

test/Config.purs

@@ -0,0 +1,47 @@
+module Test.Config where
+
+import Prelude
+
+import Control.Monad.Error.Class (throwError)
+import Data.Either (Either(..))
+import Data.Map (fromFoldable) as Map
+import Data.Newtype (un)
+import Data.Validation.Semigroup (V(..))
+import Database.PostgreSQL.PG (Configuration)
+import Dotenv (loadFile) as DotEnv
+import Effect.Aff (Aff)
+import Effect.Class (liftEffect)
+import Effect.Exception (error)
+import Foreign.Object (toUnfoldable) as Object
+import Node.Process (getEnv)
+import Polyform.Batteries.Env (Env, Validator) as Env
+import Polyform.Batteries.Env (MissingValue)
+import Polyform.Batteries.Env.Validators (optional, required) as Env
+import Polyform.Batteries.Int (IntExpected)
+import Polyform.Batteries.Int (validator) as Int
+import Polyform.Validator (runValidator)
+import Type.Row (type (+))
+
+validator
+  ∷ ∀ err m
+  . Monad m
+  ⇒ Env.Validator m (IntExpected + MissingValue + err) Env.Env Configuration
+validator = { database: _, host: _, idleTimeoutMillis: _, max: _, password: _, port: _, user: _ }
+  <$> Env.required "PG_DB" identity
+  <*> Env.optional "PG_HOST" identity
+  <*> Env.optional "PG_IDLE_TIMEOUT_MILLISECONDS" Int.validator
+  <*> Env.optional "PG_MAX" Int.validator
+  <*> Env.optional "PG_PASSWORD" identity
+  <*> Env.optional "PG_PORT" Int.validator
+  <*> Env.optional "PG_USER" identity
+
+load ∷ Aff Configuration
+load = do
+  void $ DotEnv.loadFile
+  env ← liftEffect $ getEnv <#> (Object.toUnfoldable ∷ _ → Array _) >>> Map.fromFoldable
+  runValidator validator env >>= un V >>> case _ of
+    Left err → do
+      throwError $ error "Configuration error. Please verify your environment and .env file."
+    Right p → pure p
+
+

test/Main.purs

@@ -22,8 +22,9 @@ import Data.Maybe (Maybe(..), fromJust)
 import Data.Newtype (unwrap)
 import Data.Tuple (Tuple(..))
 import Data.Tuple.Nested ((/\))
-import Database.PostgreSQL (PgConnectionUri, getDefaultPoolConfigurationByUri)
+import Database.PostgreSQL (PGConnectionURI, parseURI)
-import Database.PostgreSQL.PG (Connection, PGError(..), Pool, PoolConfiguration, Query(Query), Row0(Row0), Row1(Row1), Row2(Row2), Row3(Row3), Row9(Row9), command, execute, newPool, onIntegrityError, query, scalar)
+import Database.PostgreSQL.PG (Configuration, Connection, PGError(..), Pool, Query(Query), Row0(Row0), Row1(Row1), Row2(Row2), Row3(Row3), Row9(Row9), command, execute, onIntegrityError, query, scalar)
+import Database.PostgreSQL.Pool (new) as Pool
 import Effect (Effect)
 import Effect.Aff (Aff, error, launchAff)
 import Effect.Class (liftEffect)
@@ -34,6 +35,7 @@ import Global.Unsafe (unsafeStringify)
 import Math ((%))
 import Partial.Unsafe (unsafePartial)
 import Test.Assert (assert)
+import Test.Config (load) as Config
 import Test.README (run, PG, withConnection, withTransaction) as README
 import Test.Unit (TestSuite, suite)
 import Test.Unit as Test.Unit
@@ -92,14 +94,24 @@ jsdate_ ∷ Number → Number → Number → Number → Number → Number → Nu
 jsdate_ year month day hour minute second millisecond =
   jsdate { year, month, day, hour, minute, second, millisecond }
 
+noSuchDatabaseConfig :: Configuration → Configuration
+noSuchDatabaseConfig config =
+  config { database = "non-existing" <> config.database }
+
+cannotConnectConfig :: Configuration → Configuration
+cannotConnectConfig config =
+  config { host = Just "127.0.0.1"
+         , port = Just 45287
+         }
+
 main ∷ Effect Unit
 main = do
   void $ launchAff do
     -- Running guide from README
     void $ runExceptT $ README.run
 
-    -- Actual test suite
+    config ← Config.load
-    pool <- liftEffect $ newPool config
+    pool ← liftEffect $ Pool.new config
     checkPGErrors $ withConnection pool \conn -> do
       execute conn (Query """
         CREATE TEMPORARY TABLE foods (
@@ -347,45 +359,23 @@ main = do
           let doNothing _ = pure unit
 
           Test.Unit.test "connection refused" do
-            testPool <- liftEffect $ newPool cannotConnectConfig
+            testPool <- liftEffect $ Pool.new (cannotConnectConfig config)
             runExceptT (withConnection testPool doNothing) >>= case _ of
               Left (ConnectionError cause) -> equal cause "ECONNREFUSED"
               _ -> Test.Unit.failure "foo"
 
           Test.Unit.test "no such database" do
-            testPool <- liftEffect $ newPool noSuchDatabaseConfig
+            testPool <- liftEffect $ Pool.new (noSuchDatabaseConfig config)
             runExceptT (withConnection testPool doNothing) >>= case _ of
               Left (ProgrammingError { code, message }) -> equal code "3D000"
               _ -> Test.Unit.failure "PostgreSQL error was expected"
 
           Test.Unit.test "get pool configuration from postgres uri" do
-            equal (getDefaultPoolConfigurationByUri validUriToPoolConfigs.uri) (Just validUriToPoolConfigs.poolConfig)
+            equal (parseURI validUriToPoolConfigs.uri) (Just validUriToPoolConfigs.poolConfig)
-            equal (getDefaultPoolConfigurationByUri notValidConnUri) Nothing
+            equal (parseURI notValidConnUri) Nothing
 
-
+validUriToPoolConfigs :: { uri :: PGConnectionURI
-config :: PoolConfiguration
+                         , poolConfig :: Configuration }
-config =
-  { user: Nothing
-  , password: Nothing
-  , host: Nothing
-  , port: Nothing
-  , database: "purspg"
-  , 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
-         }
-
-validUriToPoolConfigs :: { uri :: PgConnectionUri
-                         , poolConfig :: PoolConfiguration }
 validUriToPoolConfigs = { uri: "postgres://urllgqrivcyako:c52275a95b7f177e2850c49de9bfa8bedc457ce860ccca664cb15db973554969@ec2-79-124-25-231.eu-west-1.compute.amazonaws.com:5432/e7cecg4nirunpo"
                         , poolConfig: { database: "e7cecg4nirunpo"
                                       , host: Just "ec2-79-124-25-231.eu-west-1.compute.amazonaws.com"
@@ -397,5 +387,5 @@ validUriToPoolConfigs = { uri: "postgres://urllgqrivcyako:c52275a95b7f177e2850c4
                                       }
                         }
 
-notValidConnUri :: PgConnectionUri
+notValidConnUri :: PGConnectionURI
 notValidConnUri = "postgres://urllgqrivcyakoc52275a95b7f177e2850c49de9bfa8bedc457ce860ccca664cb15db973554969@ec2-79-124-25-231.eu-west-1.compute.amazonaws.com:5432/e7cecg4nirunpo"