snaplet-postgresql-simple 0.5 → 0.6
raw patch · 4 files changed
+176/−158 lines, 4 filesdep +lensdep ~basedep ~text
Dependencies added: lens
Dependency ranges changed: base, text
Files
- snaplet-postgresql-simple.cabal +8/−6
- src/Snap/Snaplet/Auth/Backends/PostgresqlSimple.hs +15/−15
- src/Snap/Snaplet/PostgresqlSimple.hs +63/−137
- src/Snap/Snaplet/PostgresqlSimple/Internal.hs +90/−0
snaplet-postgresql-simple.cabal view
@@ -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
src/Snap/Snaplet/Auth/Backends/PostgresqlSimple.hs view
@@ -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]
src/Snap/Snaplet/PostgresqlSimple.hs view
@@ -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)
+ src/Snap/Snaplet/PostgresqlSimple/Internal.hs view
@@ -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)+