module Snap.Snaplet.PostgresqlSimple (
Postgres(..)
, HasPostgres(..)
, pgsInit
, query
, query_
, fold
, foldWithOptions
, fold_
, foldWithOptions_
, forEach
, forEach_
, execute
, execute_
, executeMany
, returning
, begin
, beginLevel
, beginMode
, rollback
, commit
, withTransaction
, withTransactionLevel
, withTransactionMode
, formatMany
, formatQuery
, P.ConnectInfo(..)
, P.Query
, P.In(..)
, P.Binary(..)
, P.Only(..)
, P.SqlError(..)
, P.FormatError(..)
, P.QueryError(..)
, P.ResultError(..)
, P.TransactionMode(..)
, P.IsolationLevel(..)
, P.ReadWriteMode(..)
, (P.:.)(..)
, ToRow(..)
, FromRow(..)
, P.defaultConnectInfo
, P.defaultTransactionMode
, P.defaultIsolationLevel
, P.defaultReadWriteMode
, field
) where
import Prelude hiding (catch)
import Control.Applicative
import Control.Monad.CatchIO hiding (Handler)
import Control.Monad.IO.Class
import Control.Monad.State
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Writer
import Data.ByteString (ByteString)
import qualified Data.Configurator as C
import Data.Int
import Data.List
import Data.Maybe
import Data.Pool
import Database.PostgreSQL.Simple.ToRow
import Database.PostgreSQL.Simple.FromRow
import qualified Database.PostgreSQL.Simple as P
import Snap
import Paths_snaplet_postgresql_simple
data Postgres = Postgres
{ pgPool :: Pool P.Connection
}
class (MonadCatchIO m) => HasPostgres m where
getPostgresState :: m Postgres
instance HasPostgres (Handler b Postgres) where
getPostgresState = get
instance (MonadCatchIO m) => HasPostgres (ReaderT (Snaplet Postgres) m) where
getPostgresState = asks (getL snapletValue)
instance (MonadCatchIO m) => HasPostgres (ReaderT Postgres m) where
getPostgresState = ask
logErr :: MonadIO m
=> t -> IO (Maybe a) -> WriterT [t] m (Maybe a)
logErr err m = do
res <- liftIO m
when (isNothing res) (tell [err])
return res
pgsInit :: SnapletInit b Postgres
pgsInit = makeSnaplet "postgresql-simple" description datadir $ do
config <- getSnapletUserConfig
(mci,errs) <- runWriterT $ do
host <- logErr "Must specify postgres host" $ C.lookup config "host"
port <- logErr "Must specify postgres port" $ C.lookup config "port"
user <- logErr "Must specify postgres user" $ C.lookup config "user"
pwd <- logErr "Must specify postgres pass" $ C.lookup config "pass"
db <- logErr "Must specify postgres db" $ C.lookup config "db"
return $ P.ConnectInfo <$> host <*> port <*> user <*> pwd <*> db
let ci = fromMaybe (error $ intercalate "\n" errs) mci
stripes <- liftIO $ C.lookupDefault 1 config "numStripes"
idle <- liftIO $ C.lookupDefault 5 config "idleTime"
resources <- liftIO $ C.lookupDefault 20 config "maxResourcesPerStripe"
pool <- liftIO $ createPool (P.connect ci) P.close stripes
(realToFrac (idle :: Double)) resources
return $ Postgres pool
where
description = "PostgreSQL abstraction"
datadir = Just $ liftM (++"/resources/db") getDataDir
withPG :: (HasPostgres m)
=> (P.Connection -> IO b) -> m b
withPG f = do
s <- getPostgresState
let pool = pgPool s
liftIO $ withResource pool f
query :: (HasPostgres m, ToRow q, FromRow r)
=> P.Query -> q -> m [r]
query q params = withPG (\c -> P.query c q params)
query_ :: (HasPostgres m, FromRow r) => P.Query -> m [r]
query_ q = withPG (\c -> P.query_ c q)
returning :: (HasPostgres m, ToRow q, FromRow r)
=> P.Query -> [q] -> m [r]
returning q params = withPG (\c -> P.returning c q params)
fold :: (HasPostgres m,
FromRow row,
ToRow params,
MonadCatchIO m)
=> P.Query -> params -> b -> (b -> row -> IO b) -> m b
fold template qs a f = withPG (\c -> P.fold c template qs a f)
foldWithOptions :: (HasPostgres m,
FromRow row,
ToRow params,
MonadCatchIO m)
=> P.FoldOptions
-> P.Query
-> params
-> b
-> (b -> row -> IO b)
-> m b
foldWithOptions opts template qs a f =
withPG (\c -> P.foldWithOptions opts c template qs a f)
fold_ :: (HasPostgres m,
FromRow row,
MonadCatchIO m)
=> P.Query -> b -> (b -> row -> IO b) -> m b
fold_ template a f = withPG (\c -> P.fold_ c template a f)
foldWithOptions_ :: (HasPostgres m,
FromRow row,
MonadCatchIO m)
=> P.FoldOptions
-> P.Query
-> b
-> (b -> row -> IO b)
-> m b
foldWithOptions_ opts template a f =
withPG (\c -> P.foldWithOptions_ opts c template a f)
forEach :: (HasPostgres m,
FromRow r,
ToRow q,
MonadCatchIO m)
=> P.Query -> q -> (r -> IO ()) -> m ()
forEach template qs f = withPG (\c -> P.forEach c template qs f)
forEach_ :: (HasPostgres m,
FromRow r,
MonadCatchIO m)
=> P.Query -> (r -> IO ()) -> m ()
forEach_ template f = withPG (\c -> P.forEach_ c template f)
execute :: (HasPostgres m, ToRow q, MonadCatchIO m)
=> P.Query -> q -> m Int64
execute template qs = withPG (\c -> P.execute c template qs)
execute_ :: (HasPostgres m, MonadCatchIO m)
=> P.Query -> m Int64
execute_ template = withPG (\c -> P.execute_ c template)
executeMany :: (HasPostgres m, ToRow q, MonadCatchIO m)
=> P.Query -> [q] -> m Int64
executeMany template qs = withPG (\c -> P.executeMany c template qs)
begin :: (HasPostgres m, MonadCatchIO m) => m ()
begin = withPG P.begin
beginLevel :: (HasPostgres m, MonadCatchIO m)
=> P.IsolationLevel -> m ()
beginLevel lvl = withPG (P.beginLevel lvl)
beginMode :: (HasPostgres m, MonadCatchIO m)
=> P.TransactionMode -> m ()
beginMode mode = withPG (P.beginMode mode)
rollback :: (HasPostgres m, MonadCatchIO m) => m ()
rollback = withPG P.rollback
commit :: (HasPostgres m, MonadCatchIO m) => m ()
commit = withPG P.commit
withTransaction :: (HasPostgres m, MonadCatchIO m)
=> m a -> m a
withTransaction = withTransactionMode P.defaultTransactionMode
withTransactionLevel :: (HasPostgres m, MonadCatchIO m)
=> P.IsolationLevel -> m a -> m a
withTransactionLevel lvl =
withTransactionMode P.defaultTransactionMode { P.isolationLevel = lvl }
withTransactionMode :: (HasPostgres m, MonadCatchIO m)
=> P.TransactionMode -> m a -> m a
withTransactionMode mode act = do
beginMode mode
r <- act `onException` rollback
commit
return r
formatMany :: (ToRow q, HasPostgres m, MonadCatchIO m)
=> P.Query -> [q] -> m ByteString
formatMany q qs = withPG (\c -> P.formatMany c q qs)
formatQuery :: (ToRow q, HasPostgres m, MonadCatchIO m)
=> P.Query -> q -> m ByteString
formatQuery q qs = withPG (\c -> P.formatQuery c q qs)