diff --git a/snaplet-postgresql-simple.cabal b/snaplet-postgresql-simple.cabal --- a/snaplet-postgresql-simple.cabal +++ b/snaplet-postgresql-simple.cabal @@ -1,5 +1,5 @@ name: snaplet-postgresql-simple -version: 0.5 +version: 0.6 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 @@ -32,21 +32,23 @@ Snap.Snaplet.Auth.Backends.PostgresqlSimple other-modules: + Snap.Snaplet.PostgresqlSimple.Internal Paths_snaplet_postgresql_simple build-depends: - base >= 4 && < 5, + base >= 4 && < 4.8, bytestring >= 0.9.1 && < 0.11, clientsession >= 0.7.2 && < 0.10, - configurator >= 0.2 && < 0.3, + configurator >= 0.2 && < 0.4, errors >= 1.4 && < 1.5, + lens, MonadCatchIO-transformers >= 0.3 && < 0.4, - mtl >= 2 && < 3, + mtl >= 2 && < 2.3, postgresql-simple >= 0.3 && < 0.5, resource-pool-catchio >= 0.2 && < 0.3, snap >= 0.10 && < 0.14, - text >= 0.11.2 && < 1.2, - transformers >= 0.2 && < 0.4, + text >= 0.11 && < 1.3, + transformers >= 0.2 && < 0.5, unordered-containers >= 0.2 && < 0.3 diff --git a/src/Snap/Snaplet/Auth/Backends/PostgresqlSimple.hs b/src/Snap/Snaplet/Auth/Backends/PostgresqlSimple.hs --- a/src/Snap/Snaplet/Auth/Backends/PostgresqlSimple.hs +++ b/src/Snap/Snaplet/Auth/Backends/PostgresqlSimple.hs @@ -43,7 +43,6 @@ import qualified Data.Text as T import Data.Text (Text) import qualified Data.Text.Encoding as T -import Data.Pool import qualified Database.PostgreSQL.Simple as P import qualified Database.PostgreSQL.Simple.ToField as P import Database.PostgreSQL.Simple.FromField @@ -52,14 +51,16 @@ import Snap import Snap.Snaplet.Auth import Snap.Snaplet.PostgresqlSimple +import Snap.Snaplet.PostgresqlSimple.Internal import Snap.Snaplet.Session import Web.ClientSession import Paths_snaplet_postgresql_simple +------------------------------------------------------------------------------ data PostgresAuthManager = PostgresAuthManager { pamTable :: AuthTable - , pamConnPool :: Pool P.Connection + , pamConn :: Postgres } @@ -76,8 +77,7 @@ authSettings <- authSettingsFromConfig key <- liftIO $ getKey (asSiteKey authSettings) let tableDesc = defAuthTable { tblName = authTable } - let manager = PostgresAuthManager tableDesc $ - pgPool $ db ^# snapletValue + let manager = PostgresAuthManager tableDesc $ db ^# snapletValue liftIO $ createTableIfMissing manager rng <- liftIO mkRNG return $ AuthManager @@ -100,7 +100,7 @@ -- | Create the user table if it doesn't exist. createTableIfMissing :: PostgresAuthManager -> IO () createTableIfMissing PostgresAuthManager{..} = do - withResource pamConnPool $ \conn -> do + liftPG' pamConn $ \conn -> do res <- P.query_ conn $ Query $ T.encodeUtf8 $ "select relname from pg_class where relname='" `T.append` schemaless (tblName pamTable) `T.append` "'" @@ -174,14 +174,14 @@ querySingle :: (ToRow q, FromRow a) - => Pool P.Connection -> Query -> q -> IO (Maybe a) -querySingle pool q ps = withResource pool $ \conn -> return . listToMaybe =<< + => Postgres -> Query -> q -> IO (Maybe a) +querySingle pc q ps = liftPG' pc $ \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 + => Postgres -> Query -> q -> IO () +authExecute pc q ps = do + liftPG' pc $ \conn -> P.execute conn q ps return () instance P.ToField Password where @@ -306,7 +306,7 @@ save PostgresAuthManager{..} u@AuthUser{..} = do let (qstr, params) = saveQuery pamTable u let q = Query $ T.encodeUtf8 qstr - let action = withResource pamConnPool $ \conn -> do + let action = liftPG' pamConn $ \conn -> do res <- P.query conn q params return $ Right $ fromMaybe u $ listToMaybe res E.catch action onFailure @@ -320,7 +320,7 @@ , fst (colId pamTable) , " = ?" ] - querySingle pamConnPool q [unUid uid] + querySingle pamConn q [unUid uid] where cols = map (fst . ($pamTable) . fst) colDef lookupByLogin PostgresAuthManager{..} login = do @@ -331,7 +331,7 @@ , fst (colLogin pamTable) , " = ?" ] - querySingle pamConnPool q [login] + querySingle pamConn q [login] where cols = map (fst . ($pamTable) . fst) colDef lookupByRememberToken PostgresAuthManager{..} token = do @@ -342,7 +342,7 @@ , fst (colRememberToken pamTable) , " = ?" ] - querySingle pamConnPool q [token] + querySingle pamConn q [token] where cols = map (fst . ($pamTable) . fst) colDef destroy PostgresAuthManager{..} AuthUser{..} = do @@ -353,5 +353,5 @@ , fst (colLogin pamTable) , " = ?" ] - authExecute pamConnPool q [userLogin] + authExecute pamConn q [userLogin] diff --git a/src/Snap/Snaplet/PostgresqlSimple.hs b/src/Snap/Snaplet/PostgresqlSimple.hs --- a/src/Snap/Snaplet/PostgresqlSimple.hs +++ b/src/Snap/Snaplet/PostgresqlSimple.hs @@ -64,10 +64,12 @@ , HasPostgres(..) , PGSConfig(..) , pgsDefaultConfig - , mkPGSConfig + , mkPGSConfig , pgsInit , pgsInit' - , getConnectionString + , getConnectionString + , withPG + , liftPG -- * Wrappers and re-exports , query @@ -82,11 +84,6 @@ , execute_ , executeMany , returning - , begin - , beginLevel - , beginMode - , rollback - , commit , withTransaction , withTransactionLevel , withTransactionMode @@ -105,6 +102,11 @@ , P.TransactionMode(..) , P.IsolationLevel(..) , P.ReadWriteMode(..) + , P.begin + , P.beginLevel + , P.beginMode + , P.rollback + , P.commit , (P.:.)(..) , ToRow(..) , FromRow(..) @@ -119,11 +121,12 @@ import Prelude hiding ((++)) import Control.Applicative +import Control.Lens (set) import Control.Monad.CatchIO (MonadCatchIO) import qualified Control.Monad.CatchIO as CIO import Control.Monad.IO.Class import Control.Monad.State -import Control.Monad.Trans.Reader +import Control.Monad.Reader import Data.ByteString (ByteString) import Data.Monoid(Monoid(..)) import qualified Data.Configurator as C @@ -142,6 +145,7 @@ import qualified Database.PostgreSQL.Simple as P import qualified Database.PostgreSQL.Simple.Transaction as P import Snap +import Snap.Snaplet.PostgresqlSimple.Internal import Paths_snaplet_postgresql_simple -- This is actually more portable than using <> @@ -150,28 +154,10 @@ infixr 5 ++ ------------------------------------------------------------------------------ --- | 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 + setLocalPostgresState s = local (const s) ------------------------------------------------------------------------------ @@ -182,13 +168,14 @@ -- > count <- liftIO $ runReaderT (execute "INSERT ..." params) d instance (MonadCatchIO m) => HasPostgres (ReaderT (Snaplet Postgres) m) where getPostgresState = asks (^# snapletValue) - + setLocalPostgresState s = local (set snapletValue s) ------------------------------------------------------------------------------ -- | 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 + setLocalPostgresState s = local (const s) ------------------------------------------------------------------------------ @@ -251,10 +238,13 @@ showBool x = TB.decimal (fromEnum x) - showNum x = TB.formatRealFloat TB.Fixed Nothing - ( fromIntegral (numerator x) - / fromIntegral (denominator x) :: Double ) + nd ratio = (numerator ratio, denominator ratio) + showNum (nd -> (n,1)) = TB.decimal n + showNum x = TB.formatRealFloat TB.Fixed Nothing + ( fromIntegral (numerator x) + / fromIntegral (denominator x) :: Double ) + showText x = qt ++ loop x where loop (T.break escapeNeeded -> (a,b)) @@ -295,34 +285,6 @@ ------------------------------------------------------------------------------ --- | Data type holding all the snaplet's config information. -data PGSConfig = PGSConfig - { pgsConnStr :: ByteString - -- ^ A libpq connection string. - , pgsNumStripes :: Int - -- ^ The number of distinct sub-pools to maintain. The smallest - -- acceptable value is 1. - , pgsIdleTime :: Double - -- ^ Amount of time for which an unused resource is kept open. The - -- smallest acceptable value is 0.5 seconds. - , pgsResources :: Int - -- ^ Maximum number of resources to keep open per stripe. The smallest - -- acceptable value is 1. - } - - ------------------------------------------------------------------------------- --- | Returns a config object with default values and the specified connection --- string. -pgsDefaultConfig :: ByteString - -- ^ A connection string such as \"host=localhost - -- port=5432 dbname=mydb\" - -> PGSConfig -pgsDefaultConfig connstr = PGSConfig connstr 1 5 20 - - - ------------------------------------------------------------------------------- -- | Builds a PGSConfig object from a configurator Config object. This -- function uses getConnectionString to construct the connection string. The -- rest of the PGSConfig fields are obtained from \"numStripes\", @@ -341,50 +303,40 @@ pool <- liftIO $ createPool (P.connectPostgreSQL pgsConnStr) P.close pgsNumStripes (realToFrac pgsIdleTime) pgsResources - return $ Postgres pool - - ------------------------------------------------------------------------------- --- | 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 + return $ PostgresPool pool ------------------------------------------------------------------------------ -- | 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) +query q params = liftPG (\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) +query_ q = liftPG (\c -> P.query_ c q) + ------------------------------------------------------------------------------ -- | See 'P.returning' returning :: (HasPostgres m, ToRow q, FromRow r) => P.Query -> [q] -> m [r] -returning q params = withPG (\c -> P.returning c q params) +returning q params = liftPG (\c -> P.returning c q params) + ------------------------------------------------------------------------------ --- | +-- | fold :: (HasPostgres m, FromRow row, - ToRow params, - MonadCatchIO m) + ToRow params) => P.Query -> params -> b -> (b -> row -> IO b) -> m b -fold template qs a f = withPG (\c -> P.fold c template qs a f) +fold template qs a f = liftPG (\c -> P.fold c template qs a f) ------------------------------------------------------------------------------ --- | +-- | foldWithOptions :: (HasPostgres m, FromRow row, ToRow params, @@ -396,119 +348,93 @@ -> (b -> row -> IO b) -> m b foldWithOptions opts template qs a f = - withPG (\c -> P.foldWithOptions opts c template qs a f) + liftPG (\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) +fold_ template a f = liftPG (\c -> P.fold_ c template a f) ------------------------------------------------------------------------------ --- | +-- | foldWithOptions_ :: (HasPostgres m, - FromRow row, - MonadCatchIO m) + FromRow row) => 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) + liftPG (\c -> P.foldWithOptions_ opts c template a f) ------------------------------------------------------------------------------ --- | +-- | forEach :: (HasPostgres m, FromRow r, - ToRow q, - MonadCatchIO m) + ToRow q) => P.Query -> q -> (r -> IO ()) -> m () -forEach template qs f = withPG (\c -> P.forEach c template qs f) +forEach template qs f = liftPG (\c -> P.forEach c template qs f) ------------------------------------------------------------------------------ --- | +-- | forEach_ :: (HasPostgres m, - FromRow r, - MonadCatchIO m) + FromRow r) => P.Query -> (r -> IO ()) -> m () -forEach_ template f = withPG (\c -> P.forEach_ c template f) +forEach_ template f = liftPG (\c -> P.forEach_ c template f) ------------------------------------------------------------------------------ --- | -execute :: (HasPostgres m, ToRow q, MonadCatchIO m) +-- | +execute :: (HasPostgres m, ToRow q) => P.Query -> q -> m Int64 -execute template qs = withPG (\c -> P.execute c template qs) +execute template qs = liftPG (\c -> P.execute c template qs) ------------------------------------------------------------------------------ --- | -execute_ :: (HasPostgres m, MonadCatchIO m) +-- | +execute_ :: (HasPostgres m) => P.Query -> m Int64 -execute_ template = withPG (\c -> P.execute_ c template) +execute_ template = liftPG (\c -> P.execute_ c template) ------------------------------------------------------------------------------ --- | -executeMany :: (HasPostgres m, ToRow q, MonadCatchIO m) +-- | +executeMany :: (HasPostgres m, ToRow q) => 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 +executeMany template qs = liftPG (\c -> P.executeMany c template qs) -withTransaction :: (HasPostgres m, MonadCatchIO m) +withTransaction :: (HasPostgres m) => m a -> m a withTransaction = withTransactionMode P.defaultTransactionMode -withTransactionLevel :: (HasPostgres m, MonadCatchIO m) +withTransactionLevel :: (HasPostgres m) => P.IsolationLevel -> m a -> m a withTransactionLevel lvl = withTransactionMode P.defaultTransactionMode { P.isolationLevel = lvl } -withTransactionMode :: (HasPostgres m, MonadCatchIO m) +withTransactionMode :: (HasPostgres m) => P.TransactionMode -> m a -> m a -withTransactionMode mode act = do - beginMode mode - r <- act `CIO.onException` rollback - commit +withTransactionMode mode act = withPG $ CIO.block $ do + liftPG $ P.beginMode mode + r <- CIO.unblock act `CIO.onException` liftPG P.rollback + liftPG $ P.commit return r - -formatMany :: (ToRow q, HasPostgres m, MonadCatchIO m) +formatMany :: (ToRow q, HasPostgres m) => P.Query -> [q] -> m ByteString -formatMany q qs = withPG (\c -> P.formatMany c q qs) +formatMany q qs = liftPG (\c -> P.formatMany c q qs) -formatQuery :: (ToRow q, HasPostgres m, MonadCatchIO m) +formatQuery :: (ToRow q, HasPostgres m) => P.Query -> q -> m ByteString -formatQuery q qs = withPG (\c -> P.formatQuery c q qs) +formatQuery q qs = liftPG (\c -> P.formatQuery c q qs) diff --git a/src/Snap/Snaplet/PostgresqlSimple/Internal.hs b/src/Snap/Snaplet/PostgresqlSimple/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/PostgresqlSimple/Internal.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +module Snap.Snaplet.PostgresqlSimple.Internal where + +import Prelude hiding ((++)) +import Control.Monad.CatchIO (MonadCatchIO) +import Control.Monad.IO.Class +import Data.ByteString (ByteString) +import Data.Pool +import qualified Database.PostgreSQL.Simple as P + +------------------------------------------------------------------------------ +-- | 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 = PostgresPool (Pool P.Connection) + | PostgresConn P.Connection + + +------------------------------------------------------------------------------ +-- | 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 + setLocalPostgresState :: Postgres -> m a -> m a + + +------------------------------------------------------------------------------ +-- | Data type holding all the snaplet's config information. +data PGSConfig = PGSConfig + { pgsConnStr :: ByteString + -- ^ A libpq connection string. + , pgsNumStripes :: Int + -- ^ The number of distinct sub-pools to maintain. The smallest + -- acceptable value is 1. + , pgsIdleTime :: Double + -- ^ Amount of time for which an unused resource is kept open. The + -- smallest acceptable value is 0.5 seconds. + , pgsResources :: Int + -- ^ Maximum number of resources to keep open per stripe. The smallest + -- acceptable value is 1. + } + + +------------------------------------------------------------------------------ +-- | Returns a config object with default values and the specified connection +-- string. +pgsDefaultConfig :: ByteString + -- ^ A connection string such as \"host=localhost + -- port=5432 dbname=mydb\" + -> PGSConfig +pgsDefaultConfig connstr = PGSConfig connstr 1 5 20 + + + +------------------------------------------------------------------------------ +-- | Function that reserves a single connection for the duration of the given +-- action. +withPG :: (HasPostgres m) + => m b -> m b +withPG f = do + s <- getPostgresState + case s of + (PostgresPool p) -> withResource p (\c -> setLocalPostgresState (PostgresConn c) f) + (PostgresConn _) -> f + + +------------------------------------------------------------------------------ +-- | Convenience function for executing a function that needs a database +-- connection. +liftPG :: (HasPostgres m) => (P.Connection -> IO b) -> m b +liftPG f = do + s <- getPostgresState + liftPG' s f + + +------------------------------------------------------------------------------ +-- | Convenience function for executing a function that needs a database +-- connection. +liftPG' :: MonadIO m => Postgres -> (P.Connection -> IO b) -> m b +liftPG' (PostgresPool p) f = liftIO (withResource p f) +liftPG' (PostgresConn c) f = liftIO (f c) +