summaryrefslogtreecommitdiff
path: root/src/Snap/Snaplet/Hasql.hs
blob: 04a7fd6e94240da051058be4965f135ba1bc62c7 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
{-# LANGUAGE ExplicitNamespaces     #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE OverloadedStrings      #-}
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

{-# INLINE session #-}
-- | Wrapper around 'session' that calls 'fail' on failure.
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)

{-# INLINE session' #-}
-- | Wrapper around 'session'.
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)