snaplet-postgresql-simple 0.4.1.1 → 1.2.0.0
raw patch · 7 files changed
Files
- README.md +7/−0
- example/Site.hs +88/−0
- resources/db/devel.cfg +1/−1
- snaplet-postgresql-simple.cabal +55/−13
- src/Snap/Snaplet/Auth/Backends/PostgresqlSimple.hs +117/−90
- src/Snap/Snaplet/PostgresqlSimple.hs +191/−170
- src/Snap/Snaplet/PostgresqlSimple/Internal.hs +176/−0
+ README.md view
@@ -0,0 +1,7 @@+snaplet-postgresql-simple+=========================++[](https://hackage.haskell.org/package/snaplet-postgresql-simple)+[](https://travis-ci.org/mightybyte/snaplet-postgresql-simple)++Quick and easy postgresql support for snap applications.
+ example/Site.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module Main where++------------------------------------------------------------------------------+import Control.Applicative+import Control.Monad.Trans+import Control.Monad.Reader+import Control.Monad.State+import Data.ByteString (ByteString)+import Control.Lens+import Data.Maybe+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Time.Clock+import qualified Database.PostgreSQL.Simple as P+import Snap+import Snap.Snaplet.Auth+import Snap.Snaplet.Auth.Backends.PostgresqlSimple+import Snap.Snaplet.Heist+import Snap.Snaplet.PostgresqlSimple+import Snap.Snaplet.Session+import Snap.Snaplet.Session.Backends.CookieSession+import Snap.Util.FileServe+import Heist+import Text.XmlHtml hiding (render)+++------------------------------------------------------------------------------+data App = App+ { _sess :: Snaplet SessionManager+ , _db :: Snaplet Postgres+ , _auth :: Snaplet (AuthManager App)+ }++makeLenses ''App++instance HasPostgres (Handler b App) where+ getPostgresState = with db get+ setLocalPostgresState s = local (set (db . snapletValue) s)++------------------------------------------------------------------------------+-- | The application's routes.+routes :: [(ByteString, Handler App App ())]+routes = [ ("/", writeText "hello")+ , ("foo", fooHandler)+ , ("add/:uname", addHandler)+ , ("find/:email", findHandler)+ ]++fooHandler = do+ results <- query_ "select * from snap_auth_user"+ liftIO $ print (results :: [AuthUser])++addHandler = do+ mname <- getParam "uname"+ email <- getParam "email"+ let name = maybe "guest" T.decodeUtf8 mname+ u <- with auth $ do+ createUser name "" >>= \u -> case u of+ Left _ -> return u+ Right u' -> saveUser (u' {userEmail = T.decodeUtf8 <$> email})+ liftIO $ print u++findHandler = do+ email <- getParam "email"+ env <- with auth get+ liftIO $ lookupByEmail env (maybe "" T.decodeUtf8 email) >>= print++------------------------------------------------------------------------------+-- | The application initializer.+app :: SnapletInit App App+app = makeSnaplet "app" "An snaplet example application." Nothing $ do+ s <- nestSnaplet "" sess $+ initCookieSessionManager "site_key.txt" "_cookie" Nothing Nothing+ d <- nestSnaplet "db" db pgsInit+ a <- nestSnaplet "auth" auth $ initPostgresAuth sess d+ addRoutes routes+ return $ App s d a+++main :: IO ()+main = serveSnaplet defaultConfig app+
resources/db/devel.cfg view
@@ -4,7 +4,7 @@ pass = "" db = "testdb" -# Nmuber of distinct connection pools to maintain. The smallest acceptable+# Number of distinct connection pools to maintain. The smallest acceptable # value is 1. numStripes = 1
snaplet-postgresql-simple.cabal view
@@ -1,5 +1,5 @@ name: snaplet-postgresql-simple-version: 0.4.1.1+version: 1.2.0.0 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@@ -10,12 +10,22 @@ author: Doug Beardsley maintainer: mightybyte@gmail.com build-type: Simple-cabal-version: >= 1.6+cabal-version: >= 1.10 homepage: https://github.com/mightybyte/snaplet-postgresql-simple category: Web, Snap -extra-source-files: LICENSE+tested-with:+ GHC == 7.8.4,+ GHC == 7.10.3,+ GHC == 8.0.2,+ GHC == 8.2.2,+ GHC == 8.4.3,+ GHC == 8.6.4 +extra-source-files:+ LICENSE+ README.md+ data-files: resources/db/devel.cfg resources/auth/devel.cfg@@ -24,6 +34,11 @@ type: git location: https://github.com/mightybyte/snaplet-postgresql-simple.git ++flag Example+ description: Enable example+ default: False+ Library hs-source-dirs: src @@ -32,23 +47,50 @@ Snap.Snaplet.Auth.Backends.PostgresqlSimple other-modules:+ Snap.Snaplet.PostgresqlSimple.Internal Paths_snaplet_postgresql_simple build-depends:- base >= 4 && < 5,+ base >= 4 && < 4.13, bytestring >= 0.9.1 && < 0.11, clientsession >= 0.7.2 && < 0.10,- configurator >= 0.2 && < 0.3,- errors >= 1.4 && < 1.5,- MonadCatchIO-transformers >= 0.3 && < 0.4,- mtl >= 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,+ configurator >= 0.2 && < 0.4,+ lens >= 3.7.6 && < 4.18,+ lifted-base >= 0.2 && < 0.3,+ monad-control >= 1.0 && < 1.1,+ mtl >= 2 && < 2.3,+ postgresql-simple >= 0.3 && < 0.7,+ resource-pool >= 0.2 && < 0.3,+ snap >= 1.0 && < 1.2,+ text >= 0.11 && < 1.3,+ transformers >= 0.2 && < 0.6,+ transformers-base >= 0.4 && < 0.5, unordered-containers >= 0.2 && < 0.3 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-orphans -fno-warn-unused-do-bind++ default-language: Haskell2010++executable Example+ if flag(Example)+ buildable: True+ else+ buildable: False+ build-depends: base,+ aeson,+ bytestring,+ heist,+ lens,+ postgresql-simple,+ mtl,+ snap,+ snap-core,+ snaplet-postgresql-simple,+ text,+ time,+ xmlhtml+ default-language: Haskell2010+ hs-source-dirs: example+ main-is: Site.hs
src/Snap/Snaplet/Auth/Backends/PostgresqlSimple.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -17,7 +18,7 @@ > { ... -- your own application state here > , _sess :: Snaplet SessionManager > , _db :: Snaplet Postgres-> , _auth :: Snaplet (AuthManager App)+> , _auth :: Snaplet (A.AuthManager App) > } Then in your initializer you'll have something like this:@@ -35,31 +36,41 @@ ) where -------------------------------------------------------------------------------import Prelude-import Control.Error-import qualified Control.Exception as E-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.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 Control.Applicative+import qualified Control.Exception as E+import Control.Lens ((^#))+import Control.Monad (liftM, void, when)+import Control.Monad.Trans (liftIO)+import qualified Data.Configurator as C+import qualified Data.HashMap.Lazy as HM+import Data.Maybe (fromMaybe, listToMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Database.PostgreSQL.Simple as P+import Database.PostgreSQL.Simple.FromField (FromField, fromField)+import qualified Database.PostgreSQL.Simple.ToField as P+import Database.PostgreSQL.Simple.Types (Query (Query)) import Paths_snaplet_postgresql_simple+import Prelude+import Snap (Snaplet, SnapletInit,+ SnapletLens,+ getSnapletUserConfig,+ makeSnaplet,+ snapletValue)+import qualified Snap.Snaplet.Auth as A+import Snap.Snaplet.PostgresqlSimple (FromRow, Only, ToRow,+ field, fromRow)+import Snap.Snaplet.PostgresqlSimple.Internal (Postgres,+ withConnection)+import Snap.Snaplet.Session (SessionManager, mkRNG)+import Web.ClientSession (getKey)+------------------------------------------------------------------------------ data PostgresAuthManager = PostgresAuthManager- { pamTable :: AuthTable- , pamConnPool :: Pool P.Connection+ { pamTable :: AuthTable+ , pamConn :: Postgres } @@ -69,26 +80,26 @@ initPostgresAuth :: SnapletLens b SessionManager -- ^ Lens to the session snaplet -> Snaplet Postgres -- ^ The postgres snaplet- -> SnapletInit b (AuthManager b)+ -> SnapletInit b (A.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)+ authSettings <- A.authSettingsFromConfig+ key <- liftIO $ getKey (A.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+ return A.AuthManager { backend = manager , session = sess , activeUser = Nothing- , minPasswdLen = asMinPasswdLen authSettings- , rememberCookieName = asRememberCookieName authSettings- , rememberPeriod = asRememberPeriod authSettings+ , minPasswdLen = A.asMinPasswdLen authSettings+ , rememberCookieName = A.asRememberCookieName authSettings+ , rememberCookieDomain = Nothing+ , rememberPeriod = A.asRememberPeriod authSettings , siteKey = key- , lockout = asLockout authSettings+ , lockout = A.asLockout authSettings , randomNumberGenerator = rng } where@@ -100,12 +111,12 @@ -- | Create the user table if it doesn't exist. createTableIfMissing :: PostgresAuthManager -> IO () createTableIfMissing PostgresAuthManager{..} = do- withResource pamConnPool $ \conn -> do+ withConnection pamConn $ \conn -> do res <- P.query_ conn $ Query $ T.encodeUtf8 $ "select relname from pg_class where relname='" `T.append` schemaless (tblName pamTable) `T.append` "'" when (null (res :: [Only T.Text])) $- P.execute_ conn (Query $ T.encodeUtf8 q) >> return ()+ void (P.execute_ conn (Query $ T.encodeUtf8 q)) return () where schemaless = T.reverse . T.takeWhile (/='.') . T.reverse@@ -113,23 +124,26 @@ [ "CREATE TABLE \"" , tblName pamTable , "\" ("- , T.intercalate "," (map (fDesc . ($pamTable) . (fst)) colDef)- , ")"+ , T.intercalate "," (map (fDesc . ($pamTable) . fst) colDef)+ , "); "+ , "CREATE INDEX email_idx ON \""+ , tblName pamTable+ , "\" (email);" ] -buildUid :: Int -> UserId-buildUid = UserId . T.pack . show+buildUid :: Int -> A.UserId+buildUid = A.UserId . T.pack . show -instance FromField UserId where+instance FromField A.UserId where fromField f v = buildUid <$> fromField f v -instance FromField Password where- fromField f v = Encrypted <$> fromField f v+instance FromField A.Password where+ fromField f v = A.Encrypted <$> fromField f v -instance FromRow AuthUser where+instance FromRow A.AuthUser where fromRow =- AuthUser+ A.AuthUser <$> _userId <*> _userLogin <*> _userEmail@@ -174,19 +188,19 @@ 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 = withConnection 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+ withConnection pc $ \conn -> P.execute conn q ps return () -instance P.ToField Password where- toField (ClearText bs) = P.toField bs- toField (Encrypted bs) = P.toField bs+instance P.ToField A.Password where+ toField (A.ClearText bs) = P.toField bs+ toField (A.Encrypted bs) = P.toField bs -- | Datatype containing the names of the columns for the authentication table.@@ -245,68 +259,68 @@ -- | List of deconstructors so it's easier to extract column names from an -- 'AuthTable'.-colDef :: [(AuthTable -> (Text, Text), AuthUser -> P.Action)]+colDef :: [(AuthTable -> (Text, Text), A.AuthUser -> P.Action)] colDef =- [ (colId , P.toField . fmap unUid . userId)- , (colLogin , P.toField . userLogin)- , (colEmail , P.toField . userEmail)- , (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)- , (colResetToken , P.toField . userResetToken)- , (colResetRequestedAt, P.toField . userResetRequestedAt)+ [ (colId , P.toField . fmap A.unUid . A.userId)+ , (colLogin , P.toField . A.userLogin)+ , (colEmail , P.toField . A.userEmail)+ , (colPassword , P.toField . A.userPassword)+ , (colActivatedAt , P.toField . A.userActivatedAt)+ , (colSuspendedAt , P.toField . A.userSuspendedAt)+ , (colRememberToken , P.toField . A.userRememberToken)+ , (colLoginCount , P.toField . A.userLoginCount)+ , (colFailedLoginCount, P.toField . A.userFailedLoginCount)+ , (colLockedOutUntil , P.toField . A.userLockedOutUntil)+ , (colCurrentLoginAt , P.toField . A.userCurrentLoginAt)+ , (colLastLoginAt , P.toField . A.userLastLoginAt)+ , (colCurrentLoginIp , P.toField . A.userCurrentLoginIp)+ , (colLastLoginIp , P.toField . A.userLastLoginIp)+ , (colCreatedAt , P.toField . A.userCreatedAt)+ , (colUpdatedAt , P.toField . A.userUpdatedAt)+ , (colResetToken , P.toField . A.userResetToken)+ , (colResetRequestedAt, P.toField . A.userResetRequestedAt) ] -saveQuery :: AuthTable -> AuthUser -> (Text, [P.Action])-saveQuery at u@AuthUser{..} = maybe insertQuery updateQuery userId+saveQuery :: AuthTable -> A.AuthUser -> (Text, [P.Action])+saveQuery atable u@A.AuthUser{..} = maybe insertQuery updateQuery userId where insertQuery = (T.concat [ "INSERT INTO "- , tblName at+ , tblName atable , " (" , T.intercalate "," cols , ") VALUES (" , T.intercalate "," vals , ") RETURNING "- , T.intercalate "," (map (fst . ($at) . fst) colDef)+ , T.intercalate "," (map (fst . ($atable) . fst) colDef) ] , params)- qval f = fst (f at) `T.append` " = ?"+ qval f = fst (f atable) `T.append` " = ?" updateQuery uid = (T.concat [ "UPDATE "- , tblName at+ , tblName atable , " SET " , T.intercalate "," (map (qval . fst) $ tail colDef) , " WHERE "- , fst (colId at)+ , fst (colId atable) , " = ? RETURNING "- , T.intercalate "," (map (fst . ($at) . fst) colDef)+ , T.intercalate "," (map (fst . ($atable) . fst) colDef) ]- , params ++ [P.toField $ unUid uid])- cols = map (fst . ($at) . fst) $ tail colDef+ , params ++ [P.toField $ A.unUid uid])+ cols = map (fst . ($atable) . fst) $ tail colDef vals = map (const "?") cols params = map (($u) . snd) $ tail colDef -onFailure :: Monad m => E.SomeException -> m (Either AuthFailure a)-onFailure e = return $ Left $ AuthError $ show e+onFailure :: Monad m => E.SomeException -> m (Either A.AuthFailure a)+onFailure e = return $ Left $ A.AuthError $ show e ------------------------------------------------------------------------------ -- |-instance IAuthBackend PostgresAuthManager where- save PostgresAuthManager{..} u@AuthUser{..} = do+instance A.IAuthBackend PostgresAuthManager where+ save PostgresAuthManager{..} u@A.AuthUser{..} = do let (qstr, params) = saveQuery pamTable u let q = Query $ T.encodeUtf8 qstr- let action = withResource pamConnPool $ \conn -> do+ let action = withConnection pamConn $ \conn -> do res <- P.query conn q params return $ Right $ fromMaybe u $ listToMaybe res E.catch action onFailure@@ -320,7 +334,7 @@ , fst (colId pamTable) , " = ?" ]- querySingle pamConnPool q [unUid uid]+ querySingle pamConn q [A.unUid uid] where cols = map (fst . ($pamTable) . fst) colDef lookupByLogin PostgresAuthManager{..} login = do@@ -331,9 +345,22 @@ , fst (colLogin pamTable) , " = ?" ]- querySingle pamConnPool q [login]+ querySingle pamConn q [login] where cols = map (fst . ($pamTable) . fst) colDef +#if MIN_VERSION_snap(1,1,0)+ lookupByEmail PostgresAuthManager{..} email = do+ let q = Query $ T.encodeUtf8 $ T.concat+ [ "select ", T.intercalate "," cols, " from "+ , tblName pamTable+ , " where "+ , fst (colEmail pamTable)+ , " = ?"+ ]+ querySingle pamConn q [email]+ where cols = map (fst . ($pamTable) . fst) colDef+#endif+ lookupByRememberToken PostgresAuthManager{..} token = do let q = Query $ T.encodeUtf8 $ T.concat [ "select ", T.intercalate "," cols, " from "@@ -342,10 +369,10 @@ , fst (colRememberToken pamTable) , " = ?" ]- querySingle pamConnPool q [token]+ querySingle pamConn q [token] where cols = map (fst . ($pamTable) . fst) colDef - destroy PostgresAuthManager{..} AuthUser{..} = do+ destroy PostgresAuthManager{..} A.AuthUser{..} = do let q = Query $ T.encodeUtf8 $ T.concat [ "delete from " , tblName pamTable@@ -353,5 +380,5 @@ , fst (colLogin pamTable) , " = ?" ]- authExecute pamConnPool q [userLogin]+ authExecute pamConn q [userLogin]
src/Snap/Snaplet/PostgresqlSimple.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} @@ -38,6 +39,7 @@ > instance HasPostgres (Handler b App) where > getPostgresState = with db get+> setLocalPostgresState s = local (set (db . snapletValue) s) With this code, our postHandler example no longer requires the 'with' function: @@ -46,6 +48,14 @@ > posts <- query_ "select * from blog_post" > ... +If you have code that runs multiple queries but you want to make sure that you only use one database connection then you can use the withPG function, like so:++> postHandler :: Handler App App ()+> postHandler = withPG $ do+> posts <- query_ "select * from blog_post"+> links <- query_ "select * from links"+> ...+ 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@@ -61,9 +71,16 @@ -- * The Snaplet Postgres(..) , HasPostgres(..)+ , PGSConfig(..)+ , pgsDefaultConfig+ , mkPGSConfig , pgsInit , pgsInit'- , getConnectionString + , getConnectionString+ , withPG+ , P.Connection+ , liftPG+ , liftPG' -- * Wrappers and re-exports , query@@ -78,14 +95,11 @@ , execute_ , executeMany , returning- , begin- , beginLevel- , beginMode- , rollback- , commit , withTransaction , withTransactionLevel , withTransactionMode+ , withTransactionEither+ , withTransactionModeEither , formatMany , formatQuery @@ -101,6 +115,11 @@ , P.TransactionMode(..) , P.IsolationLevel(..) , P.ReadWriteMode(..)+ , P.begin+ , P.beginLevel+ , P.beginMode+ , P.rollback+ , P.commit , (P.:.)(..) , ToRow(..) , FromRow(..)@@ -113,61 +132,42 @@ ) where -import Prelude hiding ((++))-import Control.Applicative-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 Data.ByteString (ByteString)-import Data.Monoid(Monoid(..))-import qualified Data.Configurator as C-import qualified Data.Configurator.Types as C-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Builder as TB-import qualified Data.Text.Lazy.Builder.Int as TB-import qualified Data.Text.Lazy.Builder.RealFloat as TB-import Data.Int-import Data.Ratio-import Data.Pool-import Database.PostgreSQL.Simple.ToRow+import qualified Control.Exception as E+import Control.Lens (set, (^#))+import Control.Monad (liftM)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Reader (ReaderT, ask, asks,+ local)+import Control.Monad.State (get)+import Control.Monad.Trans.Control (MonadBaseControl,+ liftBaseWith, restoreM)+import Data.ByteString (ByteString)+import qualified Data.Configurator as C+import qualified Data.Configurator.Types as C+import Data.Int (Int64)+import Data.Monoid (Monoid (..), (<>))+import Data.Pool (createPool)+import Data.Ratio (denominator, numerator)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TB+import qualified Data.Text.Lazy.Builder.Int as TB+import qualified Data.Text.Lazy.Builder.RealFloat as TB+import qualified Database.PostgreSQL.Simple as P import Database.PostgreSQL.Simple.FromRow-import qualified Database.PostgreSQL.Simple as P+import Database.PostgreSQL.Simple.ToRow import qualified Database.PostgreSQL.Simple.Transaction as P-import Snap import Paths_snaplet_postgresql_simple---- This is actually more portable than using <>-(++) :: Monoid a => a -> a -> a-(++) = mappend-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-+import Prelude hiding ((++))+import qualified Snap as Snap+import Snap.Snaplet.PostgresqlSimple.Internal ------------------------------------------------------------------------------ -- | Default instance-instance HasPostgres (Handler b Postgres) where+instance HasPostgres (Snap.Handler b Postgres) where getPostgresState = get+ setLocalPostgresState s = local (const s) ------------------------------------------------------------------------------@@ -176,15 +176,18 @@ -- -- > d <- nestSnaplet "db" db pgsInit -- > count <- liftIO $ runReaderT (execute "INSERT ..." params) d-instance (MonadCatchIO m) => HasPostgres (ReaderT (Snaplet Postgres) m) where- getPostgresState = asks (^# snapletValue)-+instance {-# OVERLAPPING #-} (MonadIO m, MonadBaseControl IO m)+ => HasPostgres (ReaderT (Snap.Snaplet Postgres) m) where+ getPostgresState = asks (^# Snap.snapletValue)+ setLocalPostgresState s = local (set Snap.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+instance {-# OVERLAPPING #-} (MonadIO m, MonadBaseControl IO m)+ => HasPostgres (ReaderT Postgres m) where getPostgresState = ask+ setLocalPostgresState s = local (const s) ------------------------------------------------------------------------------@@ -218,9 +221,9 @@ , ["gsslib"] , ["service"] ]- connstr <- mconcat <$> mapM showParam params- extra <- TB.fromText <$> C.lookupDefault "" config "connectionString"- return $! T.encodeUtf8 (TL.toStrict (TB.toLazyText (connstr ++ extra)))+ connstr <- fmap mconcat $ mapM showParam params+ extra <- fmap TB.fromText $ C.lookupDefault "" config "connectionString"+ return $! T.encodeUtf8 (TL.toStrict (TB.toLazyText (connstr <> extra))) where qt = TB.singleton '\'' bs = TB.singleton '\\'@@ -237,33 +240,36 @@ showParam [] = undefined showParam names@(name:_) = do mval :: Maybe C.Value <- lookupConfig names- let key = TB.fromText name ++ eq+ let key = TB.fromText name <> eq case mval of Nothing -> return mempty- Just (C.Bool x) -> return (key ++ showBool x ++ sp)- Just (C.String x) -> return (key ++ showText x ++ sp)- Just (C.Number x) -> return (key ++ showNum x ++ sp)+ Just (C.Bool x) -> return (key <> showBool x <> sp)+ Just (C.String x) -> return (key <> showText x <> sp)+ Just (C.Number x) -> return (key <> showNum x <> sp) Just (C.List _) -> return mempty 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) - showText x = qt ++ loop x+ 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))- = TB.fromText a +++ = TB.fromText a <> case T.uncons b of- Nothing -> qt- Just (c,b') -> escapeChar c ++ loop b'+ Nothing -> qt+ Just (c,b') -> escapeChar c <> loop b' escapeNeeded c = c == '\'' || c == '\\' escapeChar c = case c of- '\'' -> bs ++ qt- '\\' -> bs ++ bs+ '\'' -> bs <> qt+ '\\' -> bs <> bs _ -> TB.singleton c @@ -272,80 +278,80 @@ datadir :: Maybe (IO FilePath)-datadir = Just $ liftM (++"/resources/db") getDataDir+datadir = Just $ liftM (<>"/resources/db") getDataDir ------------------------------------------------------------------------------ -- | Initialize the snaplet-pgsInit :: SnapletInit b Postgres-pgsInit = makeSnaplet "postgresql-simple" description datadir $ do- config <- getSnapletUserConfig+pgsInit :: Snap.SnapletInit b Postgres+pgsInit = Snap.makeSnaplet "postgresql-simple" description datadir $ do+ config <- mkPGSConfig =<< Snap.getSnapletUserConfig initHelper config --------------------------------------------------------------------------------- | Initialize the snaplet-pgsInit' :: C.Config -> SnapletInit b Postgres-pgsInit' config = makeSnaplet "postgresql-simple" description datadir $ do+-- | Initialize the snaplet using a specific configuration.+pgsInit' :: PGSConfig -> Snap.SnapletInit b Postgres+pgsInit' config = Snap.makeSnaplet "postgresql-simple" description Nothing $ initHelper config -initHelper :: MonadIO m => C.Config -> m Postgres-initHelper config = do- connstr <- liftIO $ getConnectionString config- 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.connectPostgreSQL connstr) P.close stripes- (realToFrac (idle :: Double)) resources- return $ Postgres pool+------------------------------------------------------------------------------+-- | 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\",+-- \"idleTime\", and \"maxResourcesPerStripe\".+mkPGSConfig :: MonadIO m => C.Config -> m PGSConfig+mkPGSConfig config = liftIO $ do+ connstr <- getConnectionString config+ stripes <- C.lookupDefault 1 config "numStripes"+ idle <- C.lookupDefault 5 config "idleTime"+ resources <- C.lookupDefault 20 config "maxResourcesPerStripe"+ return $ PGSConfig connstr stripes idle resources ---------------------------------------------------------------------------------- | 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+initHelper :: MonadIO m => PGSConfig -> m Postgres+initHelper PGSConfig{..} = do+ pool <- liftIO $ createPool (P.connectPostgreSQL pgsConnStr) P.close+ pgsNumStripes (realToFrac pgsIdleTime)+ pgsResources+ 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' (`P.query_` 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,- MonadCatchIO m)+ ToRow params) => P.FoldOptions -> P.Query -> params@@ -353,119 +359,134 @@ -> (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)+ FromRow row) => 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' (`P.execute_` 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)+------------------------------------------------------------------------------+-- | Be careful that you do not call Snap's `finishWith` function anywhere+-- inside the function that you pass to `withTransaction`. Doing so has been+-- known to cause DB connection leaks.+withTransaction :: (HasPostgres m) => m a -> m a withTransaction = withTransactionMode P.defaultTransactionMode -withTransactionLevel :: (HasPostgres m, MonadCatchIO m)+------------------------------------------------------------------------------+-- | Be careful that you do not call Snap's `finishWith` function anywhere+-- inside the function that you pass to `withTransactionLevel`. Doing so has+-- been known to cause DB connection leaks.+withTransactionLevel :: (HasPostgres m) => P.IsolationLevel -> m a -> m a withTransactionLevel lvl = withTransactionMode P.defaultTransactionMode { P.isolationLevel = lvl } -withTransactionMode :: (HasPostgres m, MonadCatchIO m)+------------------------------------------------------------------------------+-- | Be careful that you do not call Snap's `finishWith` function anywhere+-- inside the function that you pass to `withTransactionMode`. Doing so has+-- been known to cause DB connection leaks.+withTransactionMode :: (HasPostgres m) => P.TransactionMode -> m a -> m a-withTransactionMode mode act = do- beginMode mode- r <- act `CIO.onException` rollback- commit- return r+withTransactionMode mode act = withPG $ do+ pg <- getPostgresState+ r <- liftBaseWith $ \run -> E.mask+ $ \unmask -> withConnection pg+ $ \con -> do+ P.beginMode mode con+ r <- unmask (run act) `E.onException` P.rollback con+ P.commit con+ return r+ restoreM r +------------------------------------------------------------------------------+-- | Be careful that you do not call Snap's `finishWith` function anywhere+-- inside the function that you pass to `withTransactionMode`. Doing so has+-- been known to cause DB connection leaks.+withTransactionEither :: (HasPostgres m)+ => m (Either a b) -> m (Either a b)+withTransactionEither = withTransactionModeEither P.defaultTransactionMode -formatMany :: (ToRow q, HasPostgres m, MonadCatchIO m)+------------------------------------------------------------------------------+-- | Be careful that you do not call Snap's `finishWith` function anywhere+-- inside the function that you pass to `withTransactionMode`. Doing so has+-- been known to cause DB connection leaks.+withTransactionModeEither :: (HasPostgres m)+ => P.TransactionMode -> m (Either a b) -> m (Either a b)+withTransactionModeEither mode act = withPG $ do+ pg <- getPostgresState+ r <- liftBaseWith $ \run -> E.mask+ $ \unmask -> withConnection pg+ $ \con -> do+ P.beginMode mode con+ r <- unmask (run act) `E.onException` P.rollback con+ either (const $ P.rollback con) (const $ P.commit con) $ restoreM r+ return r+ restoreM r++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,176 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Snap.Snaplet.PostgresqlSimple.Internal where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans (lift)+import Control.Monad.Trans.Control (MonadBaseControl (..),+ control)+import Control.Monad.Trans.Identity (IdentityT (IdentityT))+import Control.Monad.Trans.Maybe (MaybeT (MaybeT))+import Control.Monad.Trans.Reader (ReaderT (ReaderT))+import qualified Control.Monad.Trans.RWS.Lazy as LRWS+import qualified Control.Monad.Trans.RWS.Strict as SRWS+import qualified Control.Monad.Trans.State.Lazy as LS+import qualified Control.Monad.Trans.State.Strict as SS+import qualified Control.Monad.Trans.Writer.Lazy as LW+import qualified Control.Monad.Trans.Writer.Strict as SW+import Data.ByteString (ByteString)+import Data.Monoid (Monoid)+import Data.Pool (Pool, withResource)+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 (MonadIO m, MonadBaseControl IO m) => HasPostgres m where+ getPostgresState :: m Postgres+ setLocalPostgresState :: Postgres -> m a -> m a+++instance HasPostgres m => HasPostgres (IdentityT m) where+ getPostgresState = lift getPostgresState+ setLocalPostgresState pg (IdentityT m) = IdentityT $+ setLocalPostgresState pg m+++instance HasPostgres m => HasPostgres (MaybeT m) where+ getPostgresState = lift getPostgresState+ setLocalPostgresState pg (MaybeT m) = MaybeT $+ setLocalPostgresState pg m+++instance {-#OVERLAPPABLE #-} HasPostgres m => HasPostgres (ReaderT r m) where+ getPostgresState = lift getPostgresState+ setLocalPostgresState pg (ReaderT m) = ReaderT $ \e ->+ setLocalPostgresState pg (m e)+++instance (Monoid w, HasPostgres m) => HasPostgres (LW.WriterT w m) where+ getPostgresState = lift getPostgresState+ setLocalPostgresState pg (LW.WriterT m) = LW.WriterT $+ setLocalPostgresState pg m+++instance (Monoid w, HasPostgres m) => HasPostgres (SW.WriterT w m) where+ getPostgresState = lift getPostgresState+ setLocalPostgresState pg (SW.WriterT m) = SW.WriterT $+ setLocalPostgresState pg m+++instance HasPostgres m => HasPostgres (LS.StateT w m) where+ getPostgresState = lift getPostgresState+ setLocalPostgresState pg (LS.StateT m) = LS.StateT $ \s ->+ setLocalPostgresState pg (m s)+++instance HasPostgres m => HasPostgres (SS.StateT w m) where+ getPostgresState = lift getPostgresState+ setLocalPostgresState pg (SS.StateT m) = SS.StateT $ \s ->+ setLocalPostgresState pg (m s)+++instance (Monoid w, HasPostgres m) => HasPostgres (LRWS.RWST r w s m) where+ getPostgresState = lift getPostgresState+ setLocalPostgresState pg (LRWS.RWST m) = LRWS.RWST $ \e s ->+ setLocalPostgresState pg (m e s)+++instance (Monoid w, HasPostgres m) => HasPostgres (SRWS.RWST r w s m) where+ getPostgresState = lift getPostgresState+ setLocalPostgresState pg (SRWS.RWST m) = SRWS.RWST $ \e s ->+ setLocalPostgresState pg (m e s)+++------------------------------------------------------------------------------+-- | 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. Nested calls to withPG will only reserve one connection. For example,+-- the following code calls withPG twice in a nested way yet only results in a single+-- connection being reserved:+--+-- > myHandler = withPG $ do+-- > queryTheDatabase+-- > commonDatabaseMethod+-- >+-- > commonDatabaseMethod = withPG $ do+-- > moreDatabaseActions+-- > evenMoreDatabaseActions+--+-- This is useful in a practical setting because you may often find yourself in a situation+-- where you have common code (that requires a database connection) that you wish to call from+-- other blocks of code that may require a database connection and you still want to make sure+-- that you are only using one connection through all of your nested methods.+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 -> m a) -> m a+liftPG act = do+ pg <- getPostgresState+ control $ \run ->+ withConnection pg $ \con -> run (act con)+++-- | Convenience function for executing a function that needs a database+-- connection specialized to IO.+liftPG' :: (HasPostgres m) => (P.Connection -> IO b) -> m b+liftPG' f = do+ s <- getPostgresState+ withConnection s f+++------------------------------------------------------------------------------+-- | Convenience function for executing a function that needs a database+-- connection.+withConnection :: MonadIO m => Postgres -> (P.Connection -> IO b) -> m b+withConnection (PostgresPool p) f = liftIO (withResource p f)+withConnection (PostgresConn c) f = liftIO (f c)