thunderstrike/purescript-postgresql-client
thunderstrike/purescript-postgresql-client
2
0
Fork 0
generated from tpl/purs
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Separate Pool module. Make test database configurable.

Browse Source
This commit is contained in:
Tomasz Rybarczyk 2020-11-09 15:54:23 +01:00
parent fd465da8ac
commit 26bb7ee471
13 changed files with 495 additions and 316 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.env-example Normal file
View File

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

22
README.md
View File

@ -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
((defaultPoolConfiguration "purspg") { idleTimeoutMillis = Just 1000 })
pool <- liftEffect $ Pool.new
((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.).
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`
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.
### Releasing

3
package.json
View File

@ -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",

27
packages.dhall
View File

@ -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

4
spago.dhall
View File

@ -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"

12
src/Database/PostgreSQL.js
View File

@ -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.
// Putting this import into `PostgreSQL/Value.js` caused problem
// with web bundlers.
// allow frontend modules to access `PostgreSQL.*` classes too.
// Putting this import into `PostgreSQL/Value.js` caused is a problem
// 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) {

464
src/Database/PostgreSQL.purs
View File

@ -1,26 +1,20 @@
module Database.PostgreSQL
( module Row
, module Value
, PGError(..)
, PGErrorDetail
, Database
, PoolConfiguration
, Pool
, Connection
, ConnectResult
, Query(..)
, PgConnectionUri
, newPool
, connect
, withConnection
, withTransaction
, defaultPoolConfiguration
, getDefaultPoolConfigurationByUri
, command
, execute
, query
, scalar
) where
( module Pool
, module Row
, module Value
, PGError(..)
, PGErrorDetail
, Connection
, ConnectResult
, Query(..)
, connect
, withConnection
, withTransaction
, 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 (foldMap, traverse)
import Data.Traversable (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
:: forall a
. Pool
-> (Either PGError Connection -> Aff a)
-> Aff a
withConnection p k =
bracket (connect p) cleanup run
where
cleanup (Left _) = pure unit
cleanup (Right { done }) = liftEffect done
withConnection ::
forall a.
Pool ->
(Either PGError Connection -> Aff a) ->
Aff a
withConnection p k = bracket (connect p) cleanup run
where
cleanup (Left _) = pure unit
run (Left err) = k (Left err)
run (Right { connection }) = k (Right connection)
cleanup (Right { done }) = liftEffect done
connect
:: Pool
-> Aff (Either PGError ConnectResult)
run (Left err) = k (Left err)
run (Right { connection }) = k (Right connection)
connect ::
Pool ->
Aff (Either PGError ConnectResult)
connect =
fromEffectFnAff
fromEffectFnAff
<<< ffiConnect
{ nullableLeft: toNullable <<< map Left <<< convertError
, right: Right
}
{ nullableLeft: toNullable <<< map Left <<< convertError
, right: Right
}
type ConnectResult =
{ connection :: Connection
type ConnectResult
= { connection :: Connection
, done :: Effect Unit
}
foreign import ffiConnect
:: forall a
. { nullableLeft :: Error -> Nullable (Either PGError ConnectResult)
, right :: a -> Either PGError ConnectResult
}
-> Pool
-> EffectFnAff (Either PGError ConnectResult)
foreign import ffiConnect ::
forall 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 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
:: forall a
. Connection
-> Aff a
-> Aff (Either PGError a)
withTransaction ::
forall a.
Connection ->
Aff a ->
Aff (Either PGError a)
withTransaction conn action =
begin >>= case _ of
Nothing → do
a ← action `catchError` \jsErr → do
void $ rollback
throwError jsErr
commit >>= case _ of
Just pgError → pure (Left pgError)
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
begin
>>= case _ of
Nothing -> do
a <-
action
`catchError`
\jsErr -> do
void $ rollback
throwError jsErr
commit
>>= case _ of
Just pgError -> pure (Left pgError)
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
:: forall i o
. (ToSQLRow i)
=> Connection
-> Query i o
-> i
-> Aff (Maybe PGError)
execute conn (Query sql) values =
hush <<< either Right Left <$> unsafeQuery conn sql (toSQLRow values)
execute ::
forall i o.
(ToSQLRow i) =>
Connection ->
Query i o ->
i ->
Aff (Maybe PGError)
execute conn (Query sql) values = hush <<< either Right Left <$> unsafeQuery conn sql (toSQLRow values)
-- | Execute a PostgreSQL query and return its results.
query
:: forall i o
. ToSQLRow i
=> FromSQLRow o
=> Connection
-> Query i o
-> i
-> Aff (Either PGError (Array o))
query ::
forall i o.
ToSQLRow i =>
FromSQLRow o =>
Connection ->
Query i o ->
i ->
Aff (Either PGError (Array o))
query conn (Query sql) values = do
r <- unsafeQuery conn sql (toSQLRow values)
pure $ r >>= _.rows >>> traverse (fromSQLRow >>> lmap ConversionError)
r <- unsafeQuery conn sql (toSQLRow values)
pure $ r >>= _.rows >>> traverse (fromSQLRow >>> lmap ConversionError)
-- | Execute a PostgreSQL query and return the first field of the first row in
-- | the result.
scalar
:: forall i o
. ToSQLRow i
=> FromSQLValue o
=> Connection
-> Query i (Row1 o)
-> i
-> Aff (Either PGError (Maybe o))
scalar conn sql values =
query conn sql values <#> map (head >>> map (case _ of Row1 a -> a))
scalar ::
forall i o.
ToSQLRow i =>
FromSQLValue o =>
Connection ->
Query i (Row1 o) ->
i ->
Aff (Either PGError (Maybe o))
scalar conn sql values = 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
:: forall i
. ToSQLRow i
=> Connection
-> Query i Int
-> i
-> Aff (Either PGError Int)
command conn (Query sql) values =
map _.rowCount <$> unsafeQuery conn sql (toSQLRow values)
command ::
forall i.
ToSQLRow i =>
Connection ->
Query i Int ->
i ->
Aff (Either PGError Int)
command conn (Query sql) values = map _.rowCount <$> unsafeQuery conn sql (toSQLRow values)
type QueryResult =
{ rows :: Array (Array Foreign)
type QueryResult
= { rows :: Array (Array Foreign)
, rowCount :: Int
}
unsafeQuery
:: Connection
-> String
-> Array Foreign
-> Aff (Either PGError QueryResult)
unsafeQuery c s =
fromEffectFnAff <<< ffiUnsafeQuery p c s
where
p =
{ nullableLeft: toNullable <<< map Left <<< convertError
, right: Right
}
unsafeQuery ::
Connection ->
String ->
Array Foreign ->
Aff (Either PGError QueryResult)
unsafeQuery c s = fromEffectFnAff <<< ffiUnsafeQuery p c s
where
p =
{ nullableLeft: toNullable <<< map Left <<< convertError
, right: Right
}
foreign import ffiUnsafeQuery
:: { nullableLeft :: Error -> Nullable (Either PGError QueryResult)
, right :: QueryResult -> Either PGError QueryResult
}
-> Connection
-> String
-> Array Foreign
-> EffectFnAff (Either PGError QueryResult)
foreign import ffiUnsafeQuery ::
{ nullableLeft :: Error -> Nullable (Either PGError QueryResult)
, right :: QueryResult -> Either PGError QueryResult
} ->
Connection ->
String ->
Array Foreign ->
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
= 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
show = genericShow
type PGErrorDetail =
{ severity :: String
type PGErrorDetail
= { 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 =
case toMaybe $ ffiSQLState err of
Nothing -> Nothing
Just sqlState -> Just $ convert sqlState $ ffiErrorDetail err
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
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)
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 =

2
src/Database/PostgreSQL/PG.purs
View File

@ -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)

28
src/Database/PostgreSQL/Pool.js Normal file
View File

@ -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();
};
};

121
src/Database/PostgreSQL/Pool.purs Normal file
View File

@ -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

22
src/Database/PostgreSQL/RowList.purs Normal file
View File

@ -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.

47
test/Config.purs Normal file
View File

@ -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

56
test/Main.purs
View File

@ -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.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 (PGConnectionURI, parseURI)
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
pool <- liftEffect $ newPool config
config ← Config.load
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 (getDefaultPoolConfigurationByUri notValidConnUri) Nothing
equal (parseURI validUriToPoolConfigs.uri) (Just validUriToPoolConfigs.poolConfig)
equal (parseURI notValidConnUri) Nothing
config :: PoolConfiguration
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 :: PGConnectionURI
, poolConfig :: Configuration }
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"