module Snap.Snaplet.Hasql
( HasPool(..)
, initHasql
, initHasql'
, session
, session'
, module H
) where
import Control.Applicative
import Control.Lens
import Control.Monad.Reader
import qualified Data.Configurator as C
import Hasql as H hiding (session)
import qualified Hasql
import Hasql.Backend hiding (Tx)
import Paths_snaplet_hasql
import Snap
class (Show (CxError db), Show (TxError db), CxTx db, Cx db) =>
HasPool s db | s -> db where
poolLens :: Lens' s (Pool db)
instance (Cx db, CxTx db, Show (CxError db), Show (TxError db)) =>
HasPool (Pool db) db where
poolLens = id
dataDir :: Maybe (IO FilePath)
dataDir = Just (fmap (++ "/resources") getDataDir)
initHasql
:: HasPool c db
=> CxSettings db
-> SnapletInit c (Pool db)
initHasql cx =
makeSnaplet "hasql" "" dataDir $ do
ps <- getPoolSettings =<< getSnapletUserConfig
pool <- liftIO (acquirePool cx ps)
onUnload (releasePool pool)
return pool
getPoolSettings cfg = (\(Just a) -> a) <$> liftIO (poolSettings
<$> C.require cfg "maxConnections"
<*> C.require cfg "connectionTimeout")
initHasql'
:: HasPool c db
=> CxSettings db
-> Maybe PoolSettings
-> SnapletInit c (Pool db)
initHasql' cx Nothing = error "initHasql: Incorrect poolSettings parameters."
initHasql' cx (Just p) =
makeSnaplet "hasql" "" dataDir $ do
pool <- liftIO (acquirePool cx p)
onUnload (releasePool pool)
return pool
session :: HasPool v db => Session db IO r -> Handler b v r
session f = do
db <- view poolLens
r <- liftIO (Hasql.session db f)
case r of
Right a -> return a
Left er -> fail (show er)
session' :: HasPool v db
=> Session db IO r
-> Handler b v (Either (SessionError db) r)
session' f = do
db <- view poolLens
liftIO (Hasql.session db f)