module Hasql
(
Session,
session,
SessionSettings,
sessionSettings,
Tx,
tx,
Mode,
Backend.IsolationLevel(..),
q,
unit,
count,
single,
list,
stream,
TxListT,
RowParser.RowParser(..),
Error(..),
)
where
import Hasql.Prelude hiding (Error)
import Hasql.Backend (Backend)
import Hasql.RowParser (RowParser)
import qualified Hasql.Backend as Backend
import qualified Hasql.RowParser as RowParser
import qualified Hasql.QParser as QParser
import qualified ListT
import qualified Data.Pool as Pool
import qualified Data.Vector as Vector
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Quote as TH
import qualified Hasql.TH as THUtil
type Session b =
ReaderT (Pool.Pool (Backend.Connection b))
session ::
(Backend.Backend b, MonadBaseControl IO m) =>
b -> SessionSettings -> Session b m r -> m r
session backend (SessionSettings size timeout) reader =
join $ liftM restoreM $ liftBaseWith $ \runInIO ->
mask $ \unmask -> do
p <- Pool.createPool (Backend.connect backend) Backend.disconnect 1 timeout size
r <- try $ unmask $ runInIO $ runReaderT reader p
Pool.purgePool p
either onException return r
where
onException =
\case
Backend.CantConnect t -> throwIO $ CantConnect t
Backend.ConnectionLost t -> throwIO $ ConnectionLost t
Backend.ErroneousResult t -> throwIO $ ErroneousResult t
Backend.UnexpectedResult t -> throwIO $ UnexpectedResult t
Backend.UnparsableTemplate t -> throwIO $ UnparsableTemplate t
Backend.TransactionConflict -> $bug "Unexpected TransactionConflict exception"
Backend.NotInTransaction -> throwIO $ NotInTransaction
data SessionSettings =
SessionSettings !Word32 !NominalDiffTime
sessionSettings ::
Word32
->
NominalDiffTime
->
Maybe SessionSettings
sessionSettings size timeout =
if size > 0 && timeout >= 0.5
then Just $ SessionSettings size timeout
else Nothing
data Error =
CantConnect Text |
ConnectionLost Text |
ErroneousResult Text |
UnexpectedResult Text |
UnparsableTemplate Text |
NotInTransaction |
UnparsableRow Text
deriving (Show, Typeable, Eq, Ord)
instance Exception Error
newtype Tx b s r =
Tx (ReaderT (Backend.Connection b) IO r)
deriving (Functor, Applicative, Monad)
type Mode =
Maybe (Backend.IsolationLevel, Bool)
tx ::
(Backend.Backend b, MonadBase IO m) =>
Mode -> (forall s. Tx b s r) -> Session b m r
tx m t =
ReaderT $ \p -> liftBase $ Pool.withResource p $ \c -> runTx c m t
where
runTx ::
Backend b =>
Backend.Connection b -> Mode -> (forall s. Tx b s r) -> IO r
runTx connection mode (Tx reader) =
maybe (const id) inTransaction mode connection (runReaderT reader connection)
where
inTransaction ::
Backend b =>
Backend.TransactionMode -> Backend.Connection b -> IO r -> IO r
inTransaction mode c io =
do
Backend.beginTransaction mode c
try io >>= \case
Left Backend.TransactionConflict -> do
Backend.finishTransaction False c
inTransaction mode c io
Left e -> throwIO e
Right r -> do
Backend.finishTransaction True c
return r
newtype TxListT s m r =
TxListT (ListT.ListT m r)
deriving (Functor, Applicative, Alternative, Monad, MonadTrans, MonadPlus,
Monoid, ListT.ListMonad)
instance ListT.ListTrans (TxListT s) where
uncons =
unsafeCoerce
(ListT.uncons :: ListT.ListT m r -> m (Maybe (r, ListT.ListT m r)))
unit :: Backend b => Backend.Statement b -> Tx b s ()
unit s =
Tx $ ReaderT $ Backend.execute s
count :: (Backend b, Backend.Mapping b Word64) => Backend.Statement b -> Tx b s Word64
count s =
Tx $ ReaderT $ Backend.executeAndCountEffects s
single :: (Backend b, RowParser b r) => Backend.Statement b -> Tx b s (Maybe r)
single s =
headMay <$> list s
list :: (Backend b, RowParser b r) => Backend.Statement b -> Tx b s [r]
list s =
Tx $ ReaderT $ \c -> do
m <- Backend.executeAndGetMatrix s c
traverse (either (throwIO . UnparsableRow) return . RowParser.parseRow) $ Vector.toList m
stream :: (Backend b, RowParser b r) => Backend.Statement b -> TxListT s (Tx b s) r
stream s =
do
s <- lift $ Tx $ ReaderT $ \c -> Backend.executeAndStream s c
TxListT $ hoist (Tx . lift) $ do
row <- s
either (lift . throwIO . UnparsableRow) return $ RowParser.parseRow row
q :: TH.QuasiQuoter
q =
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
n <- either (fail . showString "Parsing failure: ") return (QParser.parse (fromString s))
return $ statementF s n
statementF s n =
TH.LamE
(map TH.VarP argNames)
(TH.AppE
(TH.AppE
(TH.ConE '(,))
(statementE))
(argsE))
where
argNames =
map (TH.mkName . ('_' :) . show) [1 .. n]
statementE =
TH.LitE (TH.StringL s)
argsE =
TH.ListE $ flip map argNames $ \x ->
THUtil.purify
[| Backend.renderValue $(TH.varE x) |]