module Hasql
(
Pool,
acquirePool,
releasePool,
PoolSettings,
poolSettings,
Session,
session,
SessionError(..),
Bknd.Stmt,
stmt,
Ex,
unitEx,
countEx,
singleEx,
maybeEx,
listEx,
vectorEx,
streamEx,
Tx,
tx,
Bknd.TxMode(..),
Bknd.TxIsolationLevel(..),
Bknd.TxWriteMode(..),
TxStream,
TxStreamListT,
CxRow.CxRow,
)
where
import Hasql.Prelude
import qualified Hasql.Backend as Bknd
import qualified Hasql.CxRow as CxRow
import qualified Hasql.QParser as QParser
import qualified ListT
import qualified Data.Pool as Pool
import qualified Data.Text as Text
import qualified Data.Vector as Vector
import qualified Data.Vector.Mutable as MVector
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Quote as TH
import qualified Language.Haskell.TH.Syntax as TH
import qualified Hasql.TH as THUtil
newtype Pool c =
Pool (Pool.Pool (Either (Bknd.CxError c) c))
acquirePool :: Bknd.Cx c => Bknd.CxSettings c -> PoolSettings -> IO (Pool c)
acquirePool cxSettings (PoolSettings size timeout) =
fmap Pool $
Pool.createPool (Bknd.acquireCx cxSettings)
(either (const $ return ()) Bknd.releaseCx)
(1)
(fromIntegral timeout)
(size)
releasePool :: Pool c -> IO ()
releasePool (Pool p) =
Pool.destroyAllResources p
data PoolSettings =
PoolSettings !Int !Int
deriving (Show)
instance TH.Lift PoolSettings where
lift (PoolSettings a b) =
[|PoolSettings a b|]
poolSettings ::
Int
->
Int
->
Maybe PoolSettings
poolSettings size timeout =
if size > 0 && timeout >= 1
then Just $ PoolSettings size timeout
else Nothing
newtype Session c m r =
Session (ReaderT (Pool c) (EitherT (SessionError c) m) r)
deriving (Functor, Applicative, Monad, MonadIO, MonadError (SessionError c))
instance MonadTrans (Session c) where
lift = Session . lift . lift
deriving instance MonadBase IO m => MonadBase IO (Session c m)
instance MFunctor (Session c) where
hoist f (Session m) =
Session $ ReaderT $ \e ->
EitherT $ f $ runEitherT $ flip runReaderT e $ m
#if MIN_VERSION_monad_control(1,0,0)
instance MonadTransControl (Session c) where
type StT (Session c) a = Either (SessionError c) a
liftWith onUnlift =
Session $ ReaderT $ \e ->
lift $ onUnlift $ \(Session m) ->
runEitherT $ flip runReaderT e $ m
restoreT =
Session . ReaderT . const . EitherT
instance (MonadBaseControl IO m) => MonadBaseControl IO (Session c m) where
type StM (Session c m) a = ComposeSt (Session c) m a
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
#else
instance MonadTransControl (Session c) where
newtype StT (Session c) a =
SessionStT (Either (SessionError c) a)
liftWith onUnlift =
Session $ ReaderT $ \e ->
lift $ onUnlift $ \(Session m) ->
liftM SessionStT $ runEitherT $ flip runReaderT e $ m
restoreT =
Session . ReaderT . const . EitherT . liftM (\(SessionStT a) -> a)
instance (MonadBaseControl IO m) => MonadBaseControl IO (Session c m) where
newtype StM (Session c m) a =
SessionStM (ComposeSt (Session c) m a)
liftBaseWith =
defaultLiftBaseWith SessionStM
restoreM =
defaultRestoreM $ \(SessionStM a) -> a
#endif
session :: Pool c -> Session c m a -> m (Either (SessionError c) a)
session pool m =
runEitherT $ flip runReaderT pool $ case m of Session m -> m
newtype Tx c s r =
Tx { unwrapTx :: EitherT (SessionError c) (Bknd.Tx c) r }
deriving (Functor, Applicative, Monad)
data SessionError c =
CxError (Bknd.CxError c) |
TxError (Bknd.TxError c) |
ResultError Text
deriving instance (Show (Bknd.CxError c), Show (Bknd.TxError c)) => Show (SessionError c)
deriving instance (Eq (Bknd.CxError c), Eq (Bknd.TxError c)) => Eq (SessionError c)
tx :: (Bknd.CxTx c, MonadBaseControl IO m) => Bknd.TxMode -> (forall s. Tx c s r) -> Session c m r
tx mode (Tx m) =
Session $ ReaderT $ \(Pool pool) ->
Pool.withResource pool $ \e -> do
c <- hoistEither $ mapLeft CxError e
let
attempt =
do
r <- EitherT $ liftBase $ fmap (either (Left . TxError) Right) $
Bknd.runTx c mode $ runEitherT m
maybe attempt hoistEither r
in attempt
type Ex c s r =
Bknd.Stmt c -> Tx c s r
unitEx :: Ex c s ()
unitEx =
Tx . lift . Bknd.unitTx
countEx :: Bknd.CxValue c Word64 => Ex c s Word64
countEx =
Tx . lift . Bknd.countTx
singleEx :: CxRow.CxRow c r => Ex c s r
singleEx =
join . fmap (maybe (Tx $ left $ ResultError "No rows on 'singleEx'") return) .
maybeEx
maybeEx :: CxRow.CxRow c r => Ex c s (Maybe r)
maybeEx =
fmap (fmap Vector.unsafeHead . mfilter (not . Vector.null) . Just) . vectorEx
listEx :: CxRow.CxRow c r => Ex c s [r]
listEx =
fmap toList . vectorEx
vectorEx :: CxRow.CxRow c r => Ex c s (Vector r)
vectorEx s =
Tx $ do
r <- lift $ Bknd.vectorTx s
EitherT $ return $ traverse ((mapLeft ResultError) . CxRow.parseRow) $ r
streamEx :: CxRow.CxRow c r => Int -> Ex c s (TxStream c s r)
streamEx n s =
Tx $ do
r <- lift $ Bknd.streamTx n s
return $ TxStreamListT $ do
row <- hoist (Tx . lift) r
lift $ Tx $ EitherT $ return $ mapLeft ResultError $ CxRow.parseRow $ row
type TxStream c s =
TxStreamListT s (Tx c s)
newtype TxStreamListT s m r =
TxStreamListT (ListT.ListT m r)
deriving (Functor, Applicative, Alternative, Monad, MonadTrans, MonadPlus,
Monoid, ListT.MonadCons)
instance ListT.MonadTransUncons (TxStreamListT s) where
uncons =
(liftM . fmap . fmap) (unsafeCoerce :: ListT.ListT m r -> TxStreamListT s m r) .
ListT.uncons .
(unsafeCoerce :: TxStreamListT s m r -> ListT.ListT m r)
stmt :: TH.QuasiQuoter
stmt =
TH.QuasiQuoter
(parseExp)
(const $ fail "Pattern context is not supported")
(const $ fail "Type context is not supported")
(const $ fail "Declaration context is not supported")
where
parseExp s =
do
(t, n) <- either (fail . showString "Parsing failure: ") return (QParser.parse (fromString s))
return $ statementF (Text.unpack t) (fromIntegral n)
statementF s n =
TH.LamE
(map TH.VarP argNames)
(THUtil.purify [|Bknd.Stmt $(pure statementE) $(pure argsE) True|])
where
argNames =
map (TH.mkName . ('_' :) . show) [1 .. n]
statementE =
TH.LitE (TH.StringL s)
argsE =
THUtil.vectorE $
map (\x -> THUtil.purify [| Bknd.encodeValue $(TH.varE x) |]) $
argNames