module Hasql
(
Session,
session,
sessionUnlifter,
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
newtype Session b s m r =
Session (ReaderT (Pool.Pool (Backend.Connection b)) m r)
deriving (Functor, Applicative, Monad, MonadTrans, MonadIO)
instance MonadTransControl (Session b s) where
type StT (Session b s) a = a
liftWith onRunner =
Session $ ReaderT $ \e -> onRunner $ \(Session (ReaderT f)) -> f e
restoreT =
Session . ReaderT . const
instance (MonadBase IO m) => MonadBase IO (Session b s m) where
liftBase = Session . liftBase
instance (MonadBaseControl IO m) => MonadBaseControl IO (Session b s m) where
type StM (Session b s m) a = ComposeSt (Session b s) m a
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
session ::
(Backend.Backend b, MonadBaseControl IO m) =>
b -> SessionSettings -> (forall s. Session b s m r) -> m r
session backend (SessionSettings size timeout) s =
control $ \runInIO ->
mask $ \unmask -> do
p <- Pool.createPool (Backend.connect backend) Backend.disconnect 1 timeout size
r <- try $ unmask $ runInIO $ runSession p s
Pool.purgePool p
either (throwIO :: SomeException -> IO r) return r
sessionUnlifter :: (MonadBaseControl IO m) => Session b s m (Session b s m r -> m r)
sessionUnlifter =
Session $ ReaderT $ return . runSession
runSession :: (MonadBaseControl IO m) => Pool.Pool (Backend.Connection b) -> Session b s m r -> m r
runSession e (Session r) =
control $ \runInIO ->
catch (runInIO (runReaderT r e)) $ \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 s m r
tx m t =
Session $ 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 =
let
io' =
Backend.beginTransaction mode c *> io <* Backend.finishTransaction True c
in
try io' >>= \case
Left Backend.TransactionConflict -> do
Backend.finishTransaction False c
inTransaction mode c io
Left e -> throwIO e
Right r -> return r
newtype TxListT s m r =
TxListT (ListT.ListT m r)
deriving (Functor, Applicative, Alternative, Monad, MonadTrans, MonadPlus,
Monoid, ListT.MonadCons)
instance ListT.MonadTransUncons (TxListT s) where
uncons =
(liftM . fmap . fmap) (unsafeCoerce :: ListT.ListT m r -> TxListT s m r) .
ListT.uncons .
(unsafeCoerce :: TxListT s m 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)
(THUtil.purify [|(,,) $(pure statementE) $(pure argsE) True|])
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) |]