{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE
DefaultSignatures
, FunctionalDependencies
, FlexibleContexts
, FlexibleInstances
, OverloadedStrings
, RankNTypes
, ScopedTypeVariables
, TypeApplications
, TypeFamilies
, TypeInType
, TypeOperators
, UndecidableInstances
#-}
module Squeal.PostgreSQL.PQ
(
LibPQ.Connection
, connectdb
, finish
, withConnection
, lowerConnection
, PQ (PQ, unPQ)
, runPQ
, execPQ
, evalPQ
, IndexedMonadTransPQ (..)
, MonadPQ (..)
, PQRun
, pqliftWith
, LibPQ.Result
, LibPQ.Row
, ntuples
, getRow
, getRows
, nextRow
, firstRow
, liftResult
, LibPQ.ExecStatus (..)
, resultStatus
, resultErrorMessage
, resultErrorCode
, SquealException (..)
, catchSqueal
, handleSqueal
) where
import Control.Exception.Lifted
import Control.Monad.Base
import Control.Monad.Except
import Control.Monad.Morph
import Control.Monad.Trans.Control
import Data.ByteString (ByteString)
import Data.Foldable
import Data.Function ((&))
import Data.Kind
import Data.Text (pack, Text)
import Data.Traversable
import Generics.SOP
import PostgreSQL.Binary.Encoding (encodingBytes)
import qualified Database.PostgreSQL.LibPQ as LibPQ
import Squeal.PostgreSQL.Binary
import Squeal.PostgreSQL.Definition
import Squeal.PostgreSQL.Manipulation
import Squeal.PostgreSQL.Query
import Squeal.PostgreSQL.Schema
import Control.Monad.Trans.Identity
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Cont
import qualified Control.Monad.Trans.State.Lazy as Lazy
import qualified Control.Monad.Trans.State.Strict as Strict
import qualified Control.Monad.Trans.Writer.Lazy as Lazy
import qualified Control.Monad.Trans.Writer.Strict as Strict
import qualified Control.Monad.Trans.RWS.Lazy as Lazy
import qualified Control.Monad.Trans.RWS.Strict as Strict
connectdb
:: forall schema io
. MonadBase IO io
=> ByteString
-> io (K LibPQ.Connection schema)
connectdb = fmap K . liftBase . LibPQ.connectdb
finish :: MonadBase IO io => K LibPQ.Connection schema -> io ()
finish = liftBase . LibPQ.finish . unK
withConnection
:: forall schema0 schema1 io x
. MonadBaseControl IO io
=> ByteString
-> PQ schema0 schema1 io x
-> io x
withConnection connString action = do
K x <- bracket (connectdb connString) finish (unPQ action)
return x
lowerConnection
:: K LibPQ.Connection (table ': schema)
-> K LibPQ.Connection schema
lowerConnection (K conn) = K conn
newtype PQ
(schema0 :: SchemaType)
(schema1 :: SchemaType)
(m :: Type -> Type)
(x :: Type) =
PQ { unPQ :: K LibPQ.Connection schema0 -> m (K x schema1) }
instance Monad m => Functor (PQ schema0 schema1 m) where
fmap f (PQ pq) = PQ $ \ conn -> do
K x <- pq conn
return $ K (f x)
runPQ
:: Functor m
=> PQ schema0 schema1 m x
-> K LibPQ.Connection schema0
-> m (x, K LibPQ.Connection schema1)
runPQ (PQ pq) conn = (\ x -> (unK x, K (unK conn))) <$> pq conn
execPQ
:: Functor m
=> PQ schema0 schema1 m x
-> K LibPQ.Connection schema0
-> m (K LibPQ.Connection schema1)
execPQ (PQ pq) conn = mapKK (\ _ -> unK conn) <$> pq conn
evalPQ
:: Functor m
=> PQ schema0 schema1 m x
-> K LibPQ.Connection schema0
-> m x
evalPQ (PQ pq) conn = unK <$> pq conn
class IndexedMonadTransPQ pq where
pqAp
:: Monad m
=> pq schema0 schema1 m (x -> y)
-> pq schema1 schema2 m x
-> pq schema0 schema2 m y
pqJoin
:: Monad m
=> pq schema0 schema1 m (pq schema1 schema2 m y)
-> pq schema0 schema2 m y
pqJoin pq = pq & pqBind id
pqBind
:: Monad m
=> (x -> pq schema1 schema2 m y)
-> pq schema0 schema1 m x
-> pq schema0 schema2 m y
pqThen
:: Monad m
=> pq schema1 schema2 m y
-> pq schema0 schema1 m x
-> pq schema0 schema2 m y
pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)
pqAndThen
:: Monad m
=> (y -> pq schema1 schema2 m z)
-> (x -> pq schema0 schema1 m y)
-> x -> pq schema0 schema2 m z
pqAndThen g f x = pqBind g (f x)
pqEmbed
:: Monad m
=> pq schema0 schema1 m x
-> pq (table ': schema0) (table : schema1) m x
define
:: MonadBase IO io
=> Definition schema0 schema1
-> pq schema0 schema1 io (K LibPQ.Result '[])
instance IndexedMonadTransPQ PQ where
pqAp (PQ f) (PQ x) = PQ $ \ conn -> do
K f' <- f conn
K x' <- x (K (unK conn))
return $ K (f' x')
pqBind f (PQ x) = PQ $ \ conn -> do
K x' <- x conn
unPQ (f x') (K (unK conn))
pqEmbed (PQ pq) = PQ $ \ (K conn) -> do
K x <- pq (K conn)
return $ K x
define (UnsafeDefinition q) = PQ $ \ (K conn) -> do
resultMaybe <- liftBase $ LibPQ.exec conn q
case resultMaybe of
Nothing -> throw $ ResultException
"define: LibPQ.exec returned no results"
Just result -> return $ K (K result)
class Monad pq => MonadPQ schema pq | pq -> schema where
manipulateParams
:: ToParams x params
=> Manipulation schema params ys
-> x -> pq (K LibPQ.Result ys)
default manipulateParams
:: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
=> ToParams x params
=> Manipulation schema params ys
-> x -> pq (K LibPQ.Result ys)
manipulateParams manipulation params = lift $
manipulateParams manipulation params
manipulate :: Manipulation schema '[] ys -> pq (K LibPQ.Result ys)
manipulate statement = manipulateParams statement ()
runQueryParams
:: ToParams x params
=> Query schema params ys
-> x -> pq (K LibPQ.Result ys)
runQueryParams = manipulateParams . queryStatement
runQuery
:: Query schema '[] ys
-> pq (K LibPQ.Result ys)
runQuery q = runQueryParams q ()
traversePrepared
:: (ToParams x params, Traversable list)
=> Manipulation schema params ys
-> list x -> pq (list (K LibPQ.Result ys))
default traversePrepared
:: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
=> (ToParams x params, Traversable list)
=> Manipulation schema params ys -> list x -> pq (list (K LibPQ.Result ys))
traversePrepared manipulation params = lift $
traversePrepared manipulation params
forPrepared
:: (ToParams x params, Traversable list)
=> list x
-> Manipulation schema params ys
-> pq (list (K LibPQ.Result ys))
forPrepared = flip traversePrepared
traversePrepared_
:: (ToParams x params, Foldable list)
=> Manipulation schema params '[]
-> list x -> pq ()
default traversePrepared_
:: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
=> (ToParams x params, Foldable list)
=> Manipulation schema params '[]
-> list x -> pq ()
traversePrepared_ manipulation params = lift $
traversePrepared_ manipulation params
forPrepared_
:: (ToParams x params, Foldable list)
=> list x
-> Manipulation schema params '[]
-> pq ()
forPrepared_ = flip traversePrepared_
liftPQ :: (LibPQ.Connection -> IO a) -> pq a
default liftPQ
:: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
=> (LibPQ.Connection -> IO a) -> pq a
liftPQ = lift . liftPQ
instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)
=> MonadPQ schema (PQ schema0 schema1 io) where
manipulateParams
(UnsafeManipulation q :: Manipulation schema ps ys) (params :: x) =
PQ $ \ (K conn) -> do
let
toParam' encoding =
(LibPQ.invalidOid, encodingBytes encoding, LibPQ.Binary)
params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))
q' = q <> ";"
resultMaybe <- liftBase $ LibPQ.execParams conn q' params' LibPQ.Binary
case resultMaybe of
Nothing -> throw $ ResultException
"manipulateParams: LibPQ.execParams returned no results"
Just result -> do
tryResult result
return $ K (K result)
traversePrepared
(UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =
PQ $ \ (K conn) -> liftBase $ do
let temp = "temporary_statement"
prepResultMaybe <- LibPQ.prepare conn temp q Nothing
case prepResultMaybe of
Nothing -> throw $ ResultException
"traversePrepared: LibPQ.prepare returned no results"
Just prepResult -> tryResult prepResult
results <- for list $ \ params -> do
let
toParam' encoding = (encodingBytes encoding,LibPQ.Binary)
params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary
case resultMaybe of
Nothing -> throw $ ResultException
"traversePrepared: LibPQ.execParams returned no results"
Just result -> do
tryResult result
return $ K result
deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
case deallocResultMaybe of
Nothing -> throw $ ResultException
"traversePrepared: LibPQ.exec DEALLOCATE returned no results"
Just deallocResult -> tryResult deallocResult
return (K results)
traversePrepared_
(UnsafeManipulation q :: Manipulation schema xs '[]) (list :: list x) =
PQ $ \ (K conn) -> liftBase $ do
let temp = "temporary_statement"
prepResultMaybe <- LibPQ.prepare conn temp q Nothing
case prepResultMaybe of
Nothing -> throw $ ResultException
"traversePrepared_: LibPQ.prepare returned no results"
Just prepResult -> tryResult prepResult
for_ list $ \ params -> do
let
toParam' encoding = (encodingBytes encoding, LibPQ.Binary)
params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary
case resultMaybe of
Nothing -> throw $ ResultException
"traversePrepared_: LibPQ.execParams returned no results"
Just result -> tryResult result
deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
case deallocResultMaybe of
Nothing -> throw $ ResultException
"traversePrepared: LibPQ.exec DEALLOCATE returned no results"
Just deallocResult -> tryResult deallocResult
return (K ())
liftPQ pq = PQ $ \ (K conn) -> do
y <- liftBase $ pq conn
return (K y)
instance MonadPQ schema m => MonadPQ schema (IdentityT m)
instance MonadPQ schema m => MonadPQ schema (ReaderT r m)
instance MonadPQ schema m => MonadPQ schema (Strict.StateT s m)
instance MonadPQ schema m => MonadPQ schema (Lazy.StateT s m)
instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Strict.WriterT w m)
instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Lazy.WriterT w m)
instance MonadPQ schema m => MonadPQ schema (MaybeT m)
instance MonadPQ schema m => MonadPQ schema (ExceptT e m)
instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Strict.RWST r w s m)
instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Lazy.RWST r w s m)
instance MonadPQ schema m => MonadPQ schema (ContT r m)
instance (Monad m, schema0 ~ schema1)
=> Applicative (PQ schema0 schema1 m) where
pure x = PQ $ \ _conn -> pure (K x)
(<*>) = pqAp
instance (Monad m, schema0 ~ schema1)
=> Monad (PQ schema0 schema1 m) where
return = pure
(>>=) = flip pqBind
instance schema0 ~ schema1 => MFunctor (PQ schema0 schema1) where
hoist f (PQ pq) = PQ (f . pq)
instance schema0 ~ schema1 => MonadTrans (PQ schema0 schema1) where
lift m = PQ $ \ _conn -> do
x <- m
return (K x)
instance schema0 ~ schema1 => MMonad (PQ schema0 schema1) where
embed f (PQ pq) = PQ $ \ conn -> do
evalPQ (f (pq conn)) conn
instance (MonadBase b m, schema0 ~ schema1)
=> MonadBase b (PQ schema0 schema1 m) where
liftBase = lift . liftBase
type PQRun schema =
forall m x. Monad m => PQ schema schema m x -> m (K x schema)
pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a
pqliftWith f = PQ $ \ conn ->
fmap K (f $ \ pq -> unPQ pq conn)
instance (MonadBaseControl b m, schema0 ~ schema1)
=> MonadBaseControl b (PQ schema0 schema1 m) where
type StM (PQ schema0 schema1 m) x = StM m (K x schema0)
liftBaseWith f =
pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run
restoreM = PQ . const . restoreM
getRow
:: (FromRow columns y, MonadBase IO io)
=> LibPQ.Row
-> K LibPQ.Result columns
-> io y
getRow r (K result :: K LibPQ.Result columns) = liftBase $ do
numRows <- LibPQ.ntuples result
when (numRows < r) $ throw $ ResultException $
"getRow: expected at least " <> pack (show r) <> "rows but only saw "
<> pack (show numRows)
let len = fromIntegral (lengthSList (Proxy @columns))
row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
case fromList row' of
Nothing -> throw $ ResultException "getRow: found unexpected length"
Just row -> case fromRow @columns row of
Left parseError -> throw $ ParseException $ "getRow: " <> parseError
Right y -> return y
nextRow
:: (FromRow columns y, MonadBase IO io)
=> LibPQ.Row
-> K LibPQ.Result columns
-> LibPQ.Row
-> io (Maybe (LibPQ.Row,y))
nextRow total (K result :: K LibPQ.Result columns) r
= liftBase $ if r >= total then return Nothing else do
let len = fromIntegral (lengthSList (Proxy @columns))
row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
case fromList row' of
Nothing -> throw $ ResultException "nextRow: found unexpected length"
Just row -> case fromRow @columns row of
Left parseError -> throw $ ParseException $ "nextRow: " <> parseError
Right y -> return $ Just (r+1, y)
getRows
:: (FromRow columns y, MonadBase IO io)
=> K LibPQ.Result columns
-> io [y]
getRows (K result :: K LibPQ.Result columns) = liftBase $ do
let len = fromIntegral (lengthSList (Proxy @columns))
numRows <- LibPQ.ntuples result
for [0 .. numRows - 1] $ \ r -> do
row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
case fromList row' of
Nothing -> throw $ ResultException "getRows: found unexpected length"
Just row -> case fromRow @columns row of
Left parseError -> throw $ ParseException $ "getRows: " <> parseError
Right y -> return y
firstRow
:: (FromRow columns y, MonadBase IO io)
=> K LibPQ.Result columns
-> io (Maybe y)
firstRow (K result :: K LibPQ.Result columns) = liftBase $ do
numRows <- LibPQ.ntuples result
if numRows <= 0 then return Nothing else do
let len = fromIntegral (lengthSList (Proxy @columns))
row' <- traverse (LibPQ.getvalue result 0) [0 .. len - 1]
case fromList row' of
Nothing -> throw $ ResultException "firstRow: found unexpected length"
Just row -> case fromRow @columns row of
Left parseError -> throw $ ParseException $ "firstRow: " <> parseError
Right y -> return $ Just y
liftResult
:: MonadBase IO io
=> (LibPQ.Result -> IO x)
-> K LibPQ.Result results -> io x
liftResult f (K result) = liftBase $ f result
ntuples :: MonadBase IO io => K LibPQ.Result columns -> io LibPQ.Row
ntuples = liftResult LibPQ.ntuples
resultStatus :: MonadBase IO io => K LibPQ.Result results -> io LibPQ.ExecStatus
resultStatus = liftResult LibPQ.resultStatus
resultErrorMessage
:: MonadBase IO io => K LibPQ.Result results -> io (Maybe ByteString)
resultErrorMessage = liftResult LibPQ.resultErrorMessage
resultErrorCode
:: MonadBase IO io
=> K LibPQ.Result results
-> io (Maybe ByteString)
resultErrorCode = liftResult (flip LibPQ.resultErrorField LibPQ.DiagSqlstate)
data SquealException
= PQException
{ sqlExecStatus :: LibPQ.ExecStatus
, sqlStateCode :: Maybe ByteString
, sqlErrorMessage :: Maybe ByteString
}
| ResultException Text
| ParseException Text
deriving (Eq, Show)
instance Exception SquealException
tryResult
:: MonadBase IO io
=> LibPQ.Result
-> io ()
tryResult result = liftBase $ do
status <- LibPQ.resultStatus result
case status of
LibPQ.CommandOk -> return ()
LibPQ.TuplesOk -> return ()
_ -> do
stateCode <- LibPQ.resultErrorField result LibPQ.DiagSqlstate
msg <- LibPQ.resultErrorMessage result
throw $ PQException status stateCode msg
catchSqueal
:: MonadBaseControl IO io
=> io a
-> (SquealException -> io a)
-> io a
catchSqueal = catch
handleSqueal
:: MonadBaseControl IO io
=> (SquealException -> io a)
-> io a -> io a
handleSqueal = handle