Extract from dinote

.editorconfig

@@ -0,0 +1,5 @@
+root = true
+
+[*]
+end_of_line = lf
+insert_final_newline = true

.gitignore

@@ -0,0 +1,4 @@
+/.pulp-cache
+/bower_components
+/node_modules
+/output

bower.json

@@ -0,0 +1,15 @@
+{
+  "name": "purescript-postgresql-client",
+  "dependencies": {
+    "purescript-prelude": "^2.1.0",
+    "purescript-transformers": "^2.0.2",
+    "purescript-lists": "^3.2.1",
+    "purescript-foreign": "^3.0.1",
+    "purescript-partial": "^1.1.2",
+    "purescript-tuples": "^3.0.0",
+    "purescript-aff": "^2.0.2",
+    "purescript-either": "^2.0.0",
+    "purescript-maybe": "^2.0.1",
+    "purescript-foldable-traversable": "^2.0.0"
+  }
+}

src/Database/PostgreSQL.js

@@ -0,0 +1,49 @@
+'use strict';
+
+var pg = require('pg');
+
+exports.newPool = function(config) {
+    return function(onSuccess, onError) {
+        onSuccess(new pg.Pool(config));
+    };
+};
+
+exports.withConnection = function(pool) {
+    return function(body) {
+        return function(onSuccess, onError) {
+            pool.connect(function(err, client, done) {
+                if (err !== null) {
+                    onError(err);
+                    return;
+                }
+                body(client)(function(r) {
+                    done();
+                    onSuccess(r);
+                }, function(e) {
+                    done();
+                    onError(e);
+                });
+            });
+        };
+    };
+};
+
+exports._query = function(client) {
+    return function(sql) {
+        return function(values) {
+            return function(onSuccess, onError) {
+                client.query({
+                    text: sql,
+                    values: values,
+                    rowMode: 'array',
+                }, function(err, result) {
+                    if (err !== null) {
+                        onError(err);
+                        return;
+                    }
+                    onSuccess(result.rows);
+                });
+            };
+        };
+    };
+};

src/Database/PostgreSQL.purs

@@ -0,0 +1,169 @@
+module Database.PostgreSQL
+( POSTGRESQL
+, PoolConfiguration
+, Pool
+, Connection
+, class ToSQLRow
+, class FromSQLRow
+, class ToSQLValue
+, class FromSQLValue
+, toSQLRow
+, fromSQLRow
+, toSQLValue
+, fromSQLValue
+, newPool
+, withConnection
+, withTransaction
+, execute
+, query
+) where
+
+import Control.Monad.Aff (Aff)
+import Control.Monad.Error.Class (catchError, throwError)
+import Control.Monad.Except (runExcept)
+import Data.Either (Either(..))
+import Data.Foreign (Foreign, readArray, readString, toForeign)
+import Data.List (List)
+import Data.List as List
+import Data.Maybe (fromJust, Maybe(..))
+import Data.Traversable (traverse)
+import Data.Tuple (Tuple)
+import Data.Tuple.Nested ((/\), tuple1, tuple2, tuple3, tuple4, tuple5)
+import Partial.Unsafe (unsafePartial)
+import Prelude
+
+foreign import data POSTGRESQL :: !
+
+type PoolConfiguration =
+    { user              :: String
+    , password          :: String
+    , host              :: String
+    , port              :: Int
+    , database          :: String
+    , max               :: Int
+    , idleTimeoutMillis :: Int
+    }
+
+foreign import data Pool :: *
+
+foreign import data Connection :: *
+
+class ToSQLRow a where
+    toSQLRow :: a -> Array Foreign
+
+class FromSQLRow a where
+    fromSQLRow :: Array Foreign -> Maybe a
+
+class ToSQLValue a where
+    toSQLValue :: a -> Foreign
+
+class FromSQLValue a where
+    fromSQLValue :: Foreign -> Maybe a
+
+instance toSQLRowUnit :: ToSQLRow Unit where
+    toSQLRow _ = []
+
+instance toSQLRowTuple1 :: (ToSQLValue a) => ToSQLRow (Tuple a Unit) where
+    toSQLRow (a /\ _) = [toSQLValue a]
+
+instance toSQLRowTuple2 :: (ToSQLValue a, ToSQLValue b) => ToSQLRow (Tuple a (Tuple b Unit)) where
+    toSQLRow (a /\ b /\ _) = [toSQLValue a, toSQLValue b]
+
+instance toSQLRowTuple3 :: (ToSQLValue a, ToSQLValue b, ToSQLValue c) => ToSQLRow (Tuple a (Tuple b (Tuple c Unit))) where
+    toSQLRow (a /\ b /\ c /\ _) = [toSQLValue a, toSQLValue b, toSQLValue c]
+
+instance toSQLRowTuple4 :: (ToSQLValue a, ToSQLValue b, ToSQLValue c, ToSQLValue d) => ToSQLRow (Tuple a (Tuple b (Tuple c (Tuple d Unit)))) where
+    toSQLRow (a /\ b /\ c /\ d /\ _) = [toSQLValue a, toSQLValue b, toSQLValue c, toSQLValue d]
+
+instance toSQLRowTuple5 :: (ToSQLValue a, ToSQLValue b, ToSQLValue c, ToSQLValue d, ToSQLValue e) => ToSQLRow (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e Unit))))) where
+    toSQLRow (a /\ b /\ c /\ d /\ e /\ _) = [toSQLValue a, toSQLValue b, toSQLValue c, toSQLValue d, toSQLValue e]
+
+instance fromSQLRowUnit :: FromSQLRow Unit where
+    fromSQLRow [] = Just unit
+    fromSQLRow _ = Nothing
+
+instance fromSQLRowTuple1 :: (FromSQLValue a) => FromSQLRow (Tuple a Unit) where
+    fromSQLRow [a] = tuple1 <$> fromSQLValue a
+    fromSQLRow _ = Nothing
+
+instance fromSQLRowTuple2 :: (FromSQLValue a, FromSQLValue b) => FromSQLRow (Tuple a (Tuple b Unit)) where
+    fromSQLRow [a, b] = tuple2 <$> fromSQLValue a <*> fromSQLValue b
+    fromSQLRow _ = Nothing
+
+instance fromSQLRowTuple3 :: (FromSQLValue a, FromSQLValue b, FromSQLValue c) => FromSQLRow (Tuple a (Tuple b (Tuple c Unit))) where
+    fromSQLRow [a, b, c] = tuple3 <$> fromSQLValue a <*> fromSQLValue b <*> fromSQLValue c
+    fromSQLRow _ = Nothing
+
+instance fromSQLRowTuple4 :: (FromSQLValue a, FromSQLValue b, FromSQLValue c, FromSQLValue d) => FromSQLRow (Tuple a (Tuple b (Tuple c (Tuple d Unit)))) where
+    fromSQLRow [a, b, c, d] = tuple4 <$> fromSQLValue a <*> fromSQLValue b <*> fromSQLValue c <*> fromSQLValue d
+    fromSQLRow _ = Nothing
+
+instance fromSQLRowTuple5 :: (FromSQLValue a, FromSQLValue b, FromSQLValue c, FromSQLValue d, FromSQLValue e) => FromSQLRow (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e Unit))))) where
+    fromSQLRow [a, b, c, d, e] = tuple5 <$> fromSQLValue a <*> fromSQLValue b <*> fromSQLValue c <*> fromSQLValue d <*> fromSQLValue e
+    fromSQLRow _ = Nothing
+
+instance toSQLValueString :: ToSQLValue String where
+    toSQLValue = toForeign
+
+instance fromSQLValueString :: FromSQLValue String where
+    fromSQLValue = fromRight <<< runExcept <<< readString
+
+instance fromSQLValueArray :: (FromSQLValue a) => FromSQLValue (Array a) where
+    fromSQLValue = traverse fromSQLValue <=< fromRight <<< runExcept <<< readArray
+
+instance fromSQLValueList :: (FromSQLValue a) => FromSQLValue (List a) where
+    fromSQLValue = map List.fromFoldable <<< traverse fromSQLValue <=< fromRight <<< runExcept <<< readArray
+
+foreign import newPool
+    :: ∀ eff
+     . PoolConfiguration
+    -> Aff (postgreSQL :: POSTGRESQL | eff) Pool
+
+foreign import withConnection
+    :: ∀ eff a
+     . Pool
+    -> (Connection -> Aff (postgreSQL :: POSTGRESQL | eff) a)
+    -> Aff (postgreSQL :: POSTGRESQL | eff) a
+
+withTransaction
+    :: ∀ eff a
+     . Connection
+    -> Aff (postgreSQL :: POSTGRESQL | eff) a
+    -> Aff (postgreSQL :: POSTGRESQL | eff) a
+withTransaction conn action =
+    execute conn "BEGIN TRANSACTION" unit
+    *> catchError (Right <$> action) (pure <<< Left) >>= case _ of
+        Right a -> execute conn "COMMIT TRANSACTION" unit $> a
+        Left e -> execute conn "ROLLBACK TRANSACTION" unit *> throwError e
+
+execute
+    :: ∀ i eff
+     . (ToSQLRow i)
+    => Connection
+    -> String
+    -> i
+    -> Aff (postgreSQL :: POSTGRESQL | eff) Unit
+execute conn sql values =
+    void $ _query conn sql (toSQLRow values)
+
+query
+    :: ∀ i o eff
+     . (ToSQLRow i, FromSQLRow o)
+    => Connection
+    -> String
+    -> i
+    -> Aff (postgreSQL :: POSTGRESQL | eff) (Array o)
+query conn sql values =
+    _query conn sql (toSQLRow values)
+    <#> map (unsafePartial fromJust <<< fromSQLRow)
+
+foreign import _query
+    :: ∀ eff
+     . Connection
+    -> String
+    -> Array Foreign
+    -> Aff (postgreSQL :: POSTGRESQL | eff) (Array (Array Foreign))
+
+fromRight :: ∀ a b. Either a b -> Maybe b
+fromRight (Left _) = Nothing
+fromRight (Right a) = Just a