diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2012, Doug Beardsley +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. + +Redistributions in binary form must reproduce the above copyright notice, this +list of conditions and the following disclaimer in the documentation and/or +other materials provided with the distribution. + +Neither the name of the authors nor the names of its contributors may be used +to endorse or promote products derived from this software without specific +prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/resources/auth/devel.cfg b/resources/auth/devel.cfg new file mode 100644 --- /dev/null +++ b/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" diff --git a/resources/db/devel.cfg b/resources/db/devel.cfg new file mode 100644 --- /dev/null +++ b/resources/db/devel.cfg @@ -0,0 +1,17 @@ +host = "localhost" +port = 5432 +user = "postgres" +pass = "" +db = "testdb" + +# 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 diff --git a/snaplet-postgresql-simple.cabal b/snaplet-postgresql-simple.cabal new file mode 100644 --- /dev/null +++ b/snaplet-postgresql-simple.cabal @@ -0,0 +1,53 @@ +name: snaplet-postgresql-simple +version: 0.1 +synopsis: postgresql-simple snaplet for the Snap Framework +description: This snaplet contains support for using the Postgresql + database with a Snap Framework application via the + postgresql-simple package. It also includes an + authentication backend. +license: BSD3 +license-file: LICENSE +author: Doug Beardsley +maintainer: mightybyte@gmail.com +build-type: Simple +cabal-version: >= 1.6 +homepage: https://github.com/mightybyte/snaplet-postgresql-simple +category: Web + +extra-source-files: LICENSE + +data-files: + resources/db/devel.cfg + resources/auth/devel.cfg + +source-repository head + type: git + location: https://github.com/mightybyte/snaplet-postgresql-simple.git + +Library + hs-source-dirs: src + + exposed-modules: + Snap.Snaplet.PostgresqlSimple + Snap.Snaplet.Auth.Backends.PostgresqlSimple + + other-modules: + Paths_snaplet_postgresql_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, + postgresql-simple >= 0.1 && < 0.2, + 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 diff --git a/src/Snap/Snaplet/Auth/Backends/PostgresqlSimple.hs b/src/Snap/Snaplet/Auth/Backends/PostgresqlSimple.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Auth/Backends/PostgresqlSimple.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", "timestamp") + , colSuspendedAt = ("suspended_at", "timestamp") + , colRememberToken = ("remember_token", "text") + , colLoginCount = ("login_count", "integer NOT NULL") + , colFailedLoginCount = ("failed_login_count", "integer NOT NULL") + , colLockedOutUntil = ("locked_out_until", "timestamp") + , colCurrentLoginAt = ("current_login_at", "timestamp") + , colLastLoginAt = ("last_login_at", "timestamp") + , colCurrentLoginIp = ("current_login_ip", "text") + , colLastLoginIp = ("last_login_ip", "text") + , colCreatedAt = ("created_at", "timestamp") + , colUpdatedAt = ("updated_at", "timestamp") + , 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] + diff --git a/src/Snap/Snaplet/PostgresqlSimple.hs b/src/Snap/Snaplet/PostgresqlSimple.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/PostgresqlSimple.hs @@ -0,0 +1,348 @@ +{-# 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 +() by Bryan O'Sullivan. +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 @snaplet.cfg@ 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(..) + , ToRow(..) + , FromRow(..) + + , P.defaultConnectInfo + , P.defaultTransactionMode + , P.defaultIsolationLevel + , P.defaultReadWriteMode + + ) 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.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.Snaplet +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. +class (MonadCatchIO m) => HasPostgres m where + getPostgresState :: m Postgres + + +------------------------------------------------------------------------------ +-- | Default instance +instance HasPostgres (Handler b Postgres) where + getPostgresState = get + + +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) + +