generated from tpl/purs
239 lines
7.6 KiB
Plaintext
239 lines
7.6 KiB
Plaintext
module Database.PostgreSQL
|
|
( POSTGRESQL
|
|
, PoolConfiguration
|
|
, Pool
|
|
, Connection
|
|
, Query(..)
|
|
, class ToSQLRow
|
|
, class FromSQLRow
|
|
, class ToSQLValue
|
|
, class FromSQLValue
|
|
, toSQLRow
|
|
, fromSQLRow
|
|
, toSQLValue
|
|
, fromSQLValue
|
|
, newPool
|
|
, withConnection
|
|
, withTransaction
|
|
, execute
|
|
, query
|
|
, scalar
|
|
) where
|
|
|
|
import Control.Monad.Aff (Aff)
|
|
import Control.Monad.Eff.Exception (error)
|
|
import Control.Monad.Error.Class (catchError, throwError)
|
|
import Control.Monad.Except (runExcept)
|
|
import Data.Array (head)
|
|
import Data.ByteString (ByteString)
|
|
import Data.DateTime.Instant (Instant)
|
|
import Data.Either (Either(..))
|
|
import Data.Foreign (Foreign, isNull, readArray, readChar, readInt, readString, toForeign, unsafeFromForeign)
|
|
import Data.Foreign.Null (writeNull)
|
|
import Data.List (List)
|
|
import Data.List as List
|
|
import Data.Maybe (Maybe(..))
|
|
import Data.Newtype (class Newtype)
|
|
import Data.Traversable (traverse)
|
|
import Data.Tuple (fst, Tuple)
|
|
import Data.Tuple.Nested ((/\), tuple1, tuple2, tuple3, tuple4, tuple5)
|
|
import Prelude
|
|
|
|
foreign import data POSTGRESQL :: !
|
|
|
|
-- | PostgreSQL connection pool configuration.
|
|
type PoolConfiguration =
|
|
{ user :: String
|
|
, password :: String
|
|
, host :: String
|
|
, port :: Int
|
|
, database :: String
|
|
, max :: Int
|
|
, idleTimeoutMillis :: Int
|
|
}
|
|
|
|
-- | PostgreSQL connection pool.
|
|
foreign import data Pool :: *
|
|
|
|
-- | PostgreSQL connection.
|
|
foreign import data Connection :: *
|
|
|
|
-- | PostgreSQL query with parameter (`$1`, `$2`, …) and return types.
|
|
newtype Query i o = Query String
|
|
|
|
derive instance newtypeQuery :: Newtype (Query i o) _
|
|
|
|
-- | Convert things to SQL rows.
|
|
class ToSQLRow a where
|
|
toSQLRow :: a -> Array Foreign
|
|
|
|
-- | Convert things from SQL rows.
|
|
class FromSQLRow a where
|
|
fromSQLRow :: Array Foreign -> Maybe a
|
|
|
|
-- | Convert things to SQL values.
|
|
class ToSQLValue a where
|
|
toSQLValue :: a -> Foreign
|
|
|
|
-- | Convert things from SQL values.
|
|
class FromSQLValue a where
|
|
fromSQLValue :: Foreign -> Maybe a
|
|
|
|
instance toSQLRowUnit :: ToSQLRow Unit where
|
|
toSQLRow _ = []
|
|
|
|
instance toSQLRowTuple :: (ToSQLValue a, ToSQLRow b) => ToSQLRow (Tuple a b) where
|
|
toSQLRow (a /\ b) = [toSQLValue a] <> toSQLRow b
|
|
|
|
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 toSQLValueBoolean :: ToSQLValue Boolean where
|
|
toSQLValue = toForeign
|
|
|
|
instance toSQLValueChar :: ToSQLValue Char where
|
|
toSQLValue = toForeign
|
|
|
|
instance fromSQLValueChar :: FromSQLValue Char where
|
|
fromSQLValue = fromRight <<< runExcept <<< readChar
|
|
|
|
instance toSQLValueInt :: ToSQLValue Int where
|
|
toSQLValue = toForeign
|
|
|
|
instance fromSQLValueInt :: FromSQLValue Int where
|
|
fromSQLValue = fromRight <<< runExcept <<< readInt
|
|
|
|
instance toSQLValueNumber :: ToSQLValue Number where
|
|
toSQLValue = toForeign
|
|
|
|
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
|
|
|
|
instance toSQLValueByteString :: ToSQLValue ByteString where
|
|
toSQLValue = toForeign
|
|
|
|
instance fromSQLValueByteString :: FromSQLValue ByteString where
|
|
fromSQLValue x
|
|
| unsafeIsBuffer x = Just $ unsafeFromForeign x
|
|
| otherwise = Nothing
|
|
|
|
instance toSQLValueInstant :: ToSQLValue Instant where
|
|
toSQLValue = instantToString
|
|
|
|
instance toSQLValueMaybe :: (ToSQLValue a) => ToSQLValue (Maybe a) where
|
|
toSQLValue Nothing = writeNull
|
|
toSQLValue (Just x) = toSQLValue x
|
|
|
|
instance fromSQLValueMaybe :: (FromSQLValue a) => FromSQLValue (Maybe a) where
|
|
fromSQLValue x | isNull x = Just Nothing
|
|
| otherwise = Just <$> fromSQLValue x
|
|
|
|
foreign import instantToString :: Instant -> Foreign
|
|
foreign import unsafeIsBuffer :: ∀ a. a -> Boolean
|
|
|
|
-- | Create a new connection pool.
|
|
foreign import newPool
|
|
:: ∀ eff
|
|
. PoolConfiguration
|
|
-> Aff (postgreSQL :: POSTGRESQL | eff) Pool
|
|
|
|
-- | Run an action with a connection. The connection is released to the pool
|
|
-- | when the action returns.
|
|
foreign import withConnection
|
|
:: ∀ eff a
|
|
. Pool
|
|
-> (Connection -> Aff (postgreSQL :: POSTGRESQL | eff) a)
|
|
-> Aff (postgreSQL :: POSTGRESQL | eff) a
|
|
|
|
-- | Run an action within a transaction. The transaction is committed if the
|
|
-- | action returns, and rolled back when the action throws. If you want to
|
|
-- | change the transaction mode, issue a separate `SET TRANSACTION` statement
|
|
-- | within the transaction.
|
|
withTransaction
|
|
:: ∀ eff a
|
|
. Connection
|
|
-> Aff (postgreSQL :: POSTGRESQL | eff) a
|
|
-> Aff (postgreSQL :: POSTGRESQL | eff) a
|
|
withTransaction conn action =
|
|
execute conn (Query "BEGIN TRANSACTION") unit
|
|
*> catchError (Right <$> action) (pure <<< Left) >>= case _ of
|
|
Right a -> execute conn (Query "COMMIT TRANSACTION") unit $> a
|
|
Left e -> execute conn (Query "ROLLBACK TRANSACTION") unit *> throwError e
|
|
|
|
-- | Execute a PostgreSQL query and discard its results.
|
|
execute
|
|
:: ∀ i o eff
|
|
. (ToSQLRow i)
|
|
=> Connection
|
|
-> Query i o
|
|
-> i
|
|
-> Aff (postgreSQL :: POSTGRESQL | eff) Unit
|
|
execute conn (Query sql) values =
|
|
void $ _query conn sql (toSQLRow values)
|
|
|
|
-- | Execute a PostgreSQL query and return its results.
|
|
query
|
|
:: ∀ i o eff
|
|
. (ToSQLRow i, FromSQLRow o)
|
|
=> Connection
|
|
-> Query i o
|
|
-> i
|
|
-> Aff (postgreSQL :: POSTGRESQL | eff) (Array o)
|
|
query conn (Query sql) values =
|
|
_query conn sql (toSQLRow values)
|
|
>>= traverse (fromSQLRow >>> case _ of
|
|
Just row -> pure row
|
|
Nothing -> throwError (error "incompatible row structure"))
|
|
|
|
scalar
|
|
:: ∀ i o eff
|
|
. (ToSQLRow i, FromSQLValue o)
|
|
=> Connection
|
|
-> Query i (Tuple o Unit)
|
|
-> i
|
|
-> Aff (postgreSQL :: POSTGRESQL | eff) (Maybe o)
|
|
scalar conn sql values =
|
|
query conn sql values
|
|
<#> map fst <<< head
|
|
|
|
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
|