Psql.hs

module RFC.Psql
  ( module Database.PostgreSQL.Simple
  , module Database.PostgreSQL.Simple.FromField
  , module Database.PostgreSQL.Simple.FromRow
  , module Database.PostgreSQL.Simple.ToField
  , module Database.PostgreSQL.Simple.ToRow
  , module Database.PostgreSQL.Simple.SqlQQ
  , module Database.PostgreSQL.Simple.Types
  , module RFC.Psql
  ) where

import RFC.Prelude
import RFC.Env
import Database.PostgreSQL.Simple (Connection, connectUser, connectPassword, connectDatabase, ConnectInfo, FromRow, Only(..), In(..), commit, Query)
import qualified Database.PostgreSQL.Simple as Psql
import Data.Pool
import Database.PostgreSQL.Simple.FromField hiding (Binary)
import Database.PostgreSQL.Simple.FromRow
import Database.PostgreSQL.Simple.ToField
import Database.PostgreSQL.Simple.ToRow
import Database.PostgreSQL.Simple.SqlQQ
import Database.PostgreSQL.Simple.Types
import Control.Monad.Trans.Control
import RFC.Log

type ConnectionPool = Pool Connection

class (MonadIO m, MonadCatch m, MonadBaseControl IO m) => HasPsql m where
  getPsqlPool :: m ConnectionPool

  withPsqlConnection :: (Connection -> m a) -> m a
  withPsqlConnection action = do
    pool <- getPsqlPool
    withResource pool action

  withPsqlTransaction :: (Connection -> m a) -> m a
  withPsqlTransaction action = withPsqlConnection $ \conn ->
    (liftBaseOp_ (Psql.withTransaction conn)) (action conn)

defaultConnectInfo :: (MonadIO m) => m ConnectInfo
defaultConnectInfo = RFC.Env.readPsqlConnectInfo

createConnectionPool :: (MonadIO m) => ConnectInfo -> m ConnectionPool
createConnectionPool connInfo = liftIO $
    createPool connect close 1 10 100
  where
    connect = do
      logDebug "Opening DB connection"
      Psql.connect connInfo
    close conn = do
      logDebug "Closing DB connection"
      Psql.close conn

query :: (MonadIO m, FromRow r, ToRow q) => Connection -> Query -> q -> m [r]
query conn qry q = liftIO $ Psql.query conn qry q

query_ :: (MonadIO m, FromRow r) => Connection -> Query -> m [r]
query_ conn qry = liftIO $ Psql.query_ conn qry

query1 :: (MonadIO m, FromRow r, ToRow q) => Connection -> Query -> q -> m (Maybe r)
query1 conn qry q = do
  result <- query conn qry q
  return $ case result of
    [] -> Nothing
    (r:_) -> Just r

query1_ :: (MonadIO m, FromRow r) => Connection -> Query -> m (Maybe r)
query1_ conn qry = do
  result <- query_ conn qry
  return $ case result of
    [] -> Nothing
    (r:_) -> Just r

query1Else :: (MonadIO m, FromRow r, ToRow q, Exception e) => Connection -> Query -> q -> e -> m (Maybe r)
query1Else conn qry q e = do
  result <- query1 conn qry q
  case result of
    (Just _) -> return result
    Nothing -> liftIO $ throwIO e

query1Else_ :: (MonadIO m, FromRow r, Exception e) => Connection -> Query -> e -> m (Maybe r)
query1Else_ conn qry e = do
  result <- query1_ conn qry
  case result of
    (Just _) -> return result
    Nothing -> liftIO $ throwIO e

execute :: (MonadIO m, ToRow q) => Connection -> Query -> q -> m Int64
execute conn qry q = liftIO $ Psql.execute conn qry q

execute_ :: (MonadIO m) => Connection -> Query -> m Int64
execute_ conn qry = liftIO $ Psql.execute_ conn qry

executeMany :: (MonadIO m, ToRow q) => Connection -> Query -> [q] -> m Int64
executeMany conn qry qs = liftIO $ Psql.executeMany conn qry qs