Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Create initial version based on snaplet-postgresql-simple

Adapt https://github.com/mightybyte/snaplet-postgresql-simple to work
with the sqlite-simple library.
  • Loading branch information...
commit 10cfeaac8a9980e807f6b6ba45139e80fcf9d53e 0 parents
@nurpax authored
3  Setup.hs
@@ -0,0 +1,3 @@
+import Distribution.Simple
+
+main = defaultMain
21 resources/auth/devel.cfg
@@ -0,0 +1,21 @@
+# Currently this option is not enforced. See current auth documentation for
+# more information.
+minPasswordLen = 8
+
+# Name of the cookie to use for remembering the logged in user.
+rememberCookie = "_remember"
+
+# Number of seconds of inactivity before the user is logged out. If ommitted,
+# the user will remain logged in until the end of the session.
+rememberPeriod = 1209600 # 2 weeks
+
+# Lockout strategy. The first value is the max number of invalid login
+# attempts before lockout. The second value is how long the locked lasts. If
+# ommitted, then incorrect passwords will never result in lockout.
+# lockout = [5, 86400]
+
+# File where the auth encryption key is stored.
+siteKey = "site_key.txt"
+
+# Name of the table where the user data is stored.
+authTable = "snap_auth_user"
13 resources/db/devel.cfg
@@ -0,0 +1,13 @@
+db = "test.db"
+
+# Nmuber of distinct connection pools to maintain. The smallest acceptable
+# value is 1.
+numStripes = 1
+
+# Number of seconds an unused resource is kept open. The smallest acceptable
+# value is 0.5 seconds.
+idleTime = 5
+
+# Maximum number of resources to keep open per stripe. The smallest
+# acceptable value is 1.
+maxResourcesPerStripe = 20
53 snaplet-sqlite-simple.cabal
@@ -0,0 +1,53 @@
+name: snaplet-postgresql-simple
+version: 0.1.0
+synopsis: sqlite-simple snaplet for the Snap Framework
+description: This snaplet contains support for using the SQLite
+ database with a Snap Framework application via the
+ sqlite-simple package. It also includes an
+ authentication backend.
+license: BSD3
+license-file: LICENSE
+author: Janne Hellsten, Doug Beardsley
+maintainer: Janne Hellsten <jjhellst@gmail.com>
+build-type: Simple
+cabal-version: >= 1.6
+homepage: https://github.com/nurpax/snaplet-sqlite-simple
+category: Web, Snap
+
+extra-source-files: LICENSE
+
+data-files:
+ resources/db/devel.cfg
+ resources/auth/devel.cfg
+
+source-repository head
+ type: git
+ location: https://github.com/nurpax/snaplet-sqlite-simple.git
+
+Library
+ hs-source-dirs: src
+
+ exposed-modules:
+ Snap.Snaplet.SqliteSimple
+ Snap.Snaplet.Auth.Backends.SqliteSimple
+
+ other-modules:
+ Paths_snaplet_sqlite_simple
+
+ build-depends:
+ base >= 4 && < 5,
+ bytestring >= 0.9.1 && < 0.10,
+ clientsession >= 0.7.2 && < 0.8,
+ configurator >= 0.2 && < 0.3,
+ MonadCatchIO-transformers >= 0.3 && < 0.4,
+ mtl >= 2 && < 3,
+ sqlite-simple >= 0.1 && < 1.0,
+ resource-pool-catchio >= 0.2 && < 0.3,
+ snap >= 0.9 && < 0.10,
+ text >= 0.11 && < 0.12,
+ transformers >= 0.2 && < 0.4,
+ unordered-containers >= 0.2 && < 0.3
+
+
+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields
+ -fno-warn-orphans -fno-warn-unused-do-bind
339 src/Snap/Snaplet/Auth/Backends/SqliteSimple.hs
@@ -0,0 +1,339 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+{-|
+
+This module allows you to use the auth snaplet with your user database stored
+in a PostgreSQL database. When you run your application with this snaplet, a
+config file will be copied into the the @snaplets/postgresql-auth@ directory.
+This file contains all of the configurable options for the snaplet and allows
+you to change them without recompiling your application.
+
+To use this snaplet in your application enable the session, postgres, and auth
+snaplets as follows:
+
+> data App = App
+> { ... -- your own application state here
+> , _sess :: Snaplet SessionManager
+> , _db :: Snaplet Postgres
+> , _auth :: Snaplet (AuthManager App)
+> }
+
+Then in your initializer you'll have something like this:
+
+> d <- nestSnaplet "db" db pgsInit
+> a <- nestSnaplet "auth" auth $ initPostgresAuth sess d
+
+If you have not already created the database table for users, it will
+automatically be created for you the first time you run your application.
+
+-}
+
+module Snap.Snaplet.Auth.Backends.PostgresqlSimple
+ ( initPostgresAuth
+ ) where
+
+------------------------------------------------------------------------------
+import qualified Data.Configurator as C
+import qualified Data.HashMap.Lazy as HM
+import qualified Data.Text as T
+import Data.Text (Text)
+import qualified Data.Text.Encoding as T
+import Data.Maybe
+import Data.Pool
+import qualified Database.PostgreSQL.Simple as P
+import qualified Database.PostgreSQL.Simple.ToField as P
+import Database.PostgreSQL.Simple.FromField
+import Database.PostgreSQL.Simple.FromRow
+import Database.PostgreSQL.Simple.Types
+import Snap
+import Snap.Snaplet.Auth
+import Snap.Snaplet.PostgresqlSimple
+import Snap.Snaplet.Session
+import Web.ClientSession
+import Paths_snaplet_postgresql_simple
+
+
+data PostgresAuthManager = PostgresAuthManager
+ { pamTable :: AuthTable
+ , pamConnPool :: Pool P.Connection
+ }
+
+
+------------------------------------------------------------------------------
+-- | Initializer for the postgres backend to the auth snaplet.
+--
+initPostgresAuth
+ :: Lens b (Snaplet SessionManager) -- ^ Lens to the session snaplet
+ -> Snaplet Postgres -- ^ The postgres snaplet
+ -> SnapletInit b (AuthManager b)
+initPostgresAuth sess db = makeSnaplet "postgresql-auth" desc datadir $ do
+ config <- getSnapletUserConfig
+ authTable <- liftIO $ C.lookupDefault "snap_auth_user" config "authTable"
+ authSettings <- authSettingsFromConfig
+ key <- liftIO $ getKey (asSiteKey authSettings)
+ let tableDesc = defAuthTable { tblName = authTable }
+ let manager = PostgresAuthManager tableDesc $
+ pgPool $ getL snapletValue db
+ liftIO $ createTableIfMissing manager
+ rng <- liftIO mkRNG
+ return $ AuthManager
+ { backend = manager
+ , session = sess
+ , activeUser = Nothing
+ , minPasswdLen = asMinPasswdLen authSettings
+ , rememberCookieName = asRememberCookieName authSettings
+ , rememberPeriod = asRememberPeriod authSettings
+ , siteKey = key
+ , lockout = asLockout authSettings
+ , randomNumberGenerator = rng
+ }
+ where
+ desc = "A PostgreSQL backend for user authentication"
+ datadir = Just $ liftM (++"/resources/auth") getDataDir
+
+
+------------------------------------------------------------------------------
+-- | Create the user table if it doesn't exist.
+createTableIfMissing :: PostgresAuthManager -> IO ()
+createTableIfMissing PostgresAuthManager{..} = do
+ withResource pamConnPool $ \conn -> do
+ res <- P.query_ conn $ Query $ T.encodeUtf8 $
+ "select relname from pg_class where relname='"
+ `T.append` tblName pamTable `T.append` "'"
+ when (null (res :: [Only T.Text])) $
+ P.execute_ conn (Query $ T.encodeUtf8 q) >> return ()
+ return ()
+ where
+ q = T.concat
+ [ "CREATE TABLE "
+ , tblName pamTable
+ , " ("
+ , T.intercalate "," (map (fDesc . ($pamTable) . (fst)) colDef)
+ , ")"
+ ]
+
+buildUid :: Int -> UserId
+buildUid = UserId . T.pack . show
+
+
+instance FromField UserId where
+ fromField f v = buildUid <$> fromField f v
+
+instance FromField Password where
+ fromField f v = Encrypted <$> fromField f v
+
+instance FromRow AuthUser where
+ fromRow =
+ AuthUser
+ <$> _userId
+ <*> _userLogin
+ <*> _userPassword
+ <*> _userActivatedAt
+ <*> _userSuspendedAt
+ <*> _userRememberToken
+ <*> _userLoginCount
+ <*> _userFailedLoginCount
+ <*> _userLockedOutUntil
+ <*> _userCurrentLoginAt
+ <*> _userLastLoginAt
+ <*> _userCurrentLoginIp
+ <*> _userLastLoginIp
+ <*> _userCreatedAt
+ <*> _userUpdatedAt
+ <*> _userRoles
+ <*> _userMeta
+ where
+ !_userId = field
+ !_userLogin = field
+ !_userPassword = field
+ !_userActivatedAt = field
+ !_userSuspendedAt = field
+ !_userRememberToken = field
+ !_userLoginCount = field
+ !_userFailedLoginCount = field
+ !_userLockedOutUntil = field
+ !_userCurrentLoginAt = field
+ !_userLastLoginAt = field
+ !_userCurrentLoginIp = field
+ !_userLastLoginIp = field
+ !_userCreatedAt = field
+ !_userUpdatedAt = field
+ !_userRoles = pure []
+ !_userMeta = pure HM.empty
+
+
+querySingle :: (ToRow q, FromRow a)
+ => Pool P.Connection -> Query -> q -> IO (Maybe a)
+querySingle pool q ps = withResource pool $ \conn -> return . listToMaybe =<<
+ P.query conn q ps
+
+authExecute :: ToRow q
+ => Pool P.Connection -> Query -> q -> IO ()
+authExecute pool q ps = do
+ withResource pool $ \conn -> P.execute conn q ps
+ return ()
+
+instance P.ToField Password where
+ toField (ClearText bs) = P.toField bs
+ toField (Encrypted bs) = P.toField bs
+
+
+-- | Datatype containing the names of the columns for the authentication table.
+data AuthTable
+ = AuthTable
+ { tblName :: Text
+ , colId :: (Text, Text)
+ , colLogin :: (Text, Text)
+ , colPassword :: (Text, Text)
+ , colActivatedAt :: (Text, Text)
+ , colSuspendedAt :: (Text, Text)
+ , colRememberToken :: (Text, Text)
+ , colLoginCount :: (Text, Text)
+ , colFailedLoginCount :: (Text, Text)
+ , colLockedOutUntil :: (Text, Text)
+ , colCurrentLoginAt :: (Text, Text)
+ , colLastLoginAt :: (Text, Text)
+ , colCurrentLoginIp :: (Text, Text)
+ , colLastLoginIp :: (Text, Text)
+ , colCreatedAt :: (Text, Text)
+ , colUpdatedAt :: (Text, Text)
+ , rolesTable :: Text
+ }
+
+-- | Default authentication table layout
+defAuthTable :: AuthTable
+defAuthTable
+ = AuthTable
+ { tblName = "snap_auth_user"
+ , colId = ("uid", "SERIAL PRIMARY KEY")
+ , colLogin = ("login", "text UNIQUE NOT NULL")
+ , colPassword = ("password", "text")
+ , colActivatedAt = ("activated_at", "timestamptz")
+ , colSuspendedAt = ("suspended_at", "timestamptz")
+ , colRememberToken = ("remember_token", "text")
+ , colLoginCount = ("login_count", "integer NOT NULL")
+ , colFailedLoginCount = ("failed_login_count", "integer NOT NULL")
+ , colLockedOutUntil = ("locked_out_until", "timestamptz")
+ , colCurrentLoginAt = ("current_login_at", "timestamptz")
+ , colLastLoginAt = ("last_login_at", "timestamptz")
+ , colCurrentLoginIp = ("current_login_ip", "text")
+ , colLastLoginIp = ("last_login_ip", "text")
+ , colCreatedAt = ("created_at", "timestamptz")
+ , colUpdatedAt = ("updated_at", "timestamptz")
+ , rolesTable = "user_roles"
+ }
+
+fDesc :: (Text, Text) -> Text
+fDesc f = fst f `T.append` " " `T.append` snd f
+
+-- | List of deconstructors so it's easier to extract column names from an
+-- 'AuthTable'.
+colDef :: [(AuthTable -> (Text, Text), AuthUser -> P.Action)]
+colDef =
+ [ (colId , P.toField . fmap unUid . userId)
+ , (colLogin , P.toField . userLogin)
+ , (colPassword , P.toField . userPassword)
+ , (colActivatedAt , P.toField . userActivatedAt)
+ , (colSuspendedAt , P.toField . userSuspendedAt)
+ , (colRememberToken , P.toField . userRememberToken)
+ , (colLoginCount , P.toField . userLoginCount)
+ , (colFailedLoginCount, P.toField . userFailedLoginCount)
+ , (colLockedOutUntil , P.toField . userLockedOutUntil)
+ , (colCurrentLoginAt , P.toField . userCurrentLoginAt)
+ , (colLastLoginAt , P.toField . userLastLoginAt)
+ , (colCurrentLoginIp , P.toField . userCurrentLoginIp)
+ , (colLastLoginIp , P.toField . userLastLoginIp)
+ , (colCreatedAt , P.toField . userCreatedAt)
+ , (colUpdatedAt , P.toField . userUpdatedAt)
+ ]
+
+saveQuery :: AuthTable -> AuthUser -> (Text, [P.Action])
+saveQuery at u@AuthUser{..} = maybe insertQuery updateQuery userId
+ where
+ insertQuery = (T.concat [ "INSERT INTO "
+ , tblName at
+ , " ("
+ , T.intercalate "," cols
+ , ") VALUES ("
+ , T.intercalate "," vals
+ , ")"
+ ]
+ , params)
+ qval f = fst (f at) `T.append` " = ?"
+ updateQuery uid =
+ (T.concat [ "UPDATE "
+ , tblName at
+ , " SET "
+ , T.intercalate "," (map (qval . fst) $ tail colDef)
+ , " WHERE "
+ , fst (colId at)
+ , " = ?"
+ ]
+ , params ++ [P.toField $ unUid uid])
+ cols = map (fst . ($at) . fst) $ tail colDef
+ vals = map (const "?") cols
+ params = map (($u) . snd) $ tail colDef
+
+
+------------------------------------------------------------------------------
+-- |
+instance IAuthBackend PostgresAuthManager where
+ save PostgresAuthManager{..} u@AuthUser{..} = do
+ let (qstr, params) = saveQuery pamTable u
+ let q = Query $ T.encodeUtf8 qstr
+ withResource pamConnPool $ \conn -> do
+ P.begin conn
+ P.execute conn q params
+ let q2 = Query $ T.encodeUtf8 $ T.concat
+ [ "select * from "
+ , tblName pamTable
+ , " where "
+ , fst (colLogin pamTable)
+ , " = ?"
+ ]
+ res <- P.query conn q2 [userLogin]
+ P.commit conn
+ return $ fromMaybe u $ listToMaybe res
+
+ lookupByUserId PostgresAuthManager{..} uid = do
+ let q = Query $ T.encodeUtf8 $ T.concat
+ [ "select * from "
+ , tblName pamTable
+ , " where "
+ , fst (colId pamTable)
+ , " = ?"
+ ]
+ querySingle pamConnPool q [unUid uid]
+
+ lookupByLogin PostgresAuthManager{..} login = do
+ let q = Query $ T.encodeUtf8 $ T.concat
+ [ "select * from "
+ , tblName pamTable
+ , " where "
+ , fst (colLogin pamTable)
+ , " = ?"
+ ]
+ querySingle pamConnPool q [login]
+
+ lookupByRememberToken PostgresAuthManager{..} token = do
+ let q = Query $ T.encodeUtf8 $ T.concat
+ [ "select * from "
+ , tblName pamTable
+ , " where "
+ , fst (colRememberToken pamTable)
+ , " = ?"
+ ]
+ querySingle pamConnPool q [token]
+
+ destroy PostgresAuthManager{..} AuthUser{..} = do
+ let q = Query $ T.encodeUtf8 $ T.concat
+ [ "delete from "
+ , tblName pamTable
+ , " where "
+ , fst (colLogin pamTable)
+ , " = ?"
+ ]
+ authExecute pamConnPool q [userLogin]
+
375 src/Snap/Snaplet/SqliteSimple.hs
@@ -0,0 +1,375 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+{-|
+
+This snaplet makes it simple to use a PostgreSQL database from your Snap
+application and is based on the excellent postgresql-simple library
+(<http://hackage.haskell.org/package/postgresql-simple>) by Leon Smith
+(adapted from Bryan O\'Sullivan\'s mysql-simple). Now, adding a database
+to your web app takes just two simple steps.
+
+First, include this snaplet in your application's state.
+
+> data App = App
+> { ... -- Other state needed in your app
+> , _db :: Snaplet Postgres
+> }
+
+Next, call the pgsInit from your application's initializer.
+
+> appInit = makeSnaplet ... $ do
+> ...
+> d <- nestSnaplet "db" db pgsInit
+> return $ App ... d
+
+Now you can use any of the postgresql-simple wrapper functions defined in this
+module anywhere in your application handlers. For instance:
+
+> postHandler :: Handler App App ()
+> postHandler = do
+> posts <- with db $ query_ "select * from blog_post"
+> ...
+
+Optionally, if you find yourself doing many database queries, you can eliminate some of the boilerplate by defining a HasPostgres instance for your application.
+
+> instance HasPostgres (Handler b App) where
+> getPostgresState = with db get
+
+With this code, our postHandler example no longer requires the 'with' function:
+
+> postHandler :: Handler App App ()
+> postHandler = do
+> posts <- query_ "select * from blog_post"
+> ...
+
+The first time you run an application with the postgresql-simple snaplet, a
+configuration file @devel.cfg@ is created in the @snaplets/postgresql-simple@
+directory underneath your project root. It specifies how to connect to your
+PostgreSQL server and what user, password, and database to use. Edit this
+file and modify the values appropriately and you'll be off and running.
+
+If you want to have out-of-the-box authentication, look at the documentation
+for the "Snap.Snaplet.Auth.Backends.PostgresqlSimple" module.
+
+-}
+
+module Snap.Snaplet.PostgresqlSimple (
+ -- * The Snaplet
+ Postgres(..)
+ , HasPostgres(..)
+ , pgsInit
+
+ -- * Wrappers and re-exports
+ , query
+ , query_
+ , fold
+ , foldWithOptions
+ , fold_
+ , foldWithOptions_
+ , forEach
+ , forEach_
+ , execute
+ , execute_
+ , executeMany
+ , begin
+ , beginLevel
+ , beginMode
+ , rollback
+ , commit
+ , withTransaction
+ , withTransactionLevel
+ , withTransactionMode
+ , formatMany
+ , formatQuery
+
+ -- Re-exported from postgresql-simple
+ , 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
+
+
+
+------------------------------------------------------------------------------
+-- | The state for the postgresql-simple snaplet. To use it in your app
+-- include this in your application state and use pgsInit to initialize it.
+data Postgres = Postgres
+ { pgPool :: Pool P.Connection
+ -- ^ Function for retrieving the connection pool
+ }
+
+
+------------------------------------------------------------------------------
+-- | Instantiate this typeclass on 'Handler b YourAppState' so this snaplet
+-- can find the connection source. If you need to have multiple instances of
+-- the postgres snaplet in your application, then don't provide this instance
+-- and leverage the default instance by using \"@with dbLens@\" in front of calls
+-- to snaplet-postgresql-simple functions.
+class (MonadCatchIO m) => HasPostgres m where
+ getPostgresState :: m Postgres
+
+
+------------------------------------------------------------------------------
+-- | Default instance
+instance HasPostgres (Handler b Postgres) where
+ getPostgresState = get
+
+
+------------------------------------------------------------------------------
+-- | A convenience instance to make it easier to use this snaplet in the
+-- Initializer monad like this:
+--
+-- > d <- nestSnaplet "db" db pgsInit
+-- > count <- liftIO $ runReaderT (execute "INSERT ..." params) d
+instance (MonadCatchIO m) => HasPostgres (ReaderT (Snaplet Postgres) m) where
+ getPostgresState = asks (getL snapletValue)
+
+
+------------------------------------------------------------------------------
+-- | A convenience instance to make it easier to use functions written for
+-- this snaplet in non-snaplet contexts.
+instance (MonadCatchIO m) => HasPostgres (ReaderT Postgres m) where
+ getPostgresState = ask
+
+
+------------------------------------------------------------------------------
+-- | Convenience function allowing easy collection of config file errors.
+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
+
+
+------------------------------------------------------------------------------
+-- | Initialize the snaplet
+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
+
+
+------------------------------------------------------------------------------
+-- | Convenience function for executing a function that needs a database
+-- connection.
+withPG :: (HasPostgres m)
+ => (P.Connection -> IO b) -> m b
+withPG f = do
+ s <- getPostgresState
+ let pool = pgPool s
+ liftIO $ withResource pool f
+
+
+------------------------------------------------------------------------------
+-- | See 'P.query'
+query :: (HasPostgres m, ToRow q, FromRow r)
+ => P.Query -> q -> m [r]
+query q params = withPG (\c -> P.query c q params)
+
+
+------------------------------------------------------------------------------
+-- | See 'P.query_'
+query_ :: (HasPostgres m, FromRow r) => P.Query -> m [r]
+query_ q = withPG (\c -> P.query_ c q)
+
+
+------------------------------------------------------------------------------
+-- |
+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)
+
+
Please sign in to comment.
Something went wrong with that request. Please try again.