Extract from dinote

rightfold · Dec 22, 2016 · 50b88ebbf12c8b8f9bac08eda40a89f502fe06ab · 50b88eb
commit 50b88ebbf12c8b8f9bac08eda40a89f502fe06ab
Unified Split

Showing with 242 additions and 0 deletions.

+5 −0 .editorconfig

+4 −0 .gitignore

+15 −0 bower.json

+49 −0 src/Database/PostgreSQL.js

+169 −0 src/Database/PostgreSQL.purs
diff --git a/.editorconfig b/.editorconfig
@@ -0,0 +1,5 @@
+  
+root = true
+  
+
+  
+[*]
+  
+end_of_line = lf
+  
+insert_final_newline = true
diff --git a/.gitignore b/.gitignore
@@ -0,0 +1,4 @@
+  
+/.pulp-cache
+  
+/bower_components
+  
+/node_modules
+  
+/output
diff --git a/bower.json b/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"
+  
+  }
+  
+}
diff --git a/src/Database/PostgreSQL.js b/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);
+  
+                });
+  
+            };
+  
+        };
+  
+    };
+  
+};
diff --git a/src/Database/PostgreSQL.purs b/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