module Hasql
(
Session,
session,
SessionSettings,
sessionSettings,
Tx,
tx,
Mode,
Backend.IsolationLevel(..),
QQ.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.QQ as QQ
import qualified ListT
import qualified Data.Pool as Pool
import qualified Data.Vector as Vector
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