commit 50b88ebbf12c8b8f9bac08eda40a89f502fe06ab Author: rightfold Date: Thu Dec 22 19:12:38 2016 +0100 Extract from dinote diff --git a/.editorconfig b/.editorconfig new file mode 100644 index 0000000..0b3779e --- /dev/null +++ b/.editorconfig @@ -0,0 +1,5 @@ +root = true + +[*] +end_of_line = lf +insert_final_newline = true diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..40a61a6 --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +/.pulp-cache +/bower_components +/node_modules +/output diff --git a/bower.json b/bower.json new file mode 100644 index 0000000..eb9dc05 --- /dev/null +++ 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 new file mode 100644 index 0000000..31915af --- /dev/null +++ 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 new file mode 100644 index 0000000..525d70f --- /dev/null +++ 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