packages feed

snaplet-postgresql-simple 0.6.0.4 → 1.0

raw patch · 4 files changed

+164/−71 lines, 4 filesdep +lifted-basedep +monad-controldep +resource-pooldep −MonadCatchIO-transformersdep −resource-pool-catchiodep ~lensdep ~snap

Dependencies added: lifted-base, monad-control, resource-pool, transformers-base

Dependencies removed: MonadCatchIO-transformers, resource-pool-catchio

Dependency ranges changed: lens, snap

Files

snaplet-postgresql-simple.cabal view
@@ -1,5 +1,5 @@ name:           snaplet-postgresql-simple-version:        0.6.0.4+version:        1.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@@ -43,14 +43,16 @@     bytestring                 >= 0.9.1   && < 0.11,     clientsession              >= 0.7.2   && < 0.10,     configurator               >= 0.2     && < 0.4,-    lens                                     < 4.13,-    MonadCatchIO-transformers  >= 0.3     && < 0.4,+    lens                                     < 4.15,+    lifted-base                >= 0.2     && < 0.3,+    monad-control              >= 1.0     && < 1.1,     mtl                        >= 2       && < 2.3,-    postgresql-simple          >= 0.3     && < 0.5,-    resource-pool-catchio      >= 0.2     && < 0.3,-    snap                       >= 0.10    && < 0.15,+    postgresql-simple          >= 0.3     && < 0.6,+    resource-pool              >= 0.2     && < 0.3,+    snap                       >= 1.0     && < 1.1,     text                       >= 0.11    && < 1.3,     transformers               >= 0.2     && < 0.5,+    transformers-base          >= 0.4     && < 0.5,     unordered-containers       >= 0.2     && < 0.3
src/Snap/Snaplet/Auth/Backends/PostgresqlSimple.hs view
@@ -90,6 +90,7 @@       , activeUser = Nothing       , minPasswdLen = asMinPasswdLen authSettings       , rememberCookieName = asRememberCookieName authSettings+      , rememberCookieDomain = Nothing       , rememberPeriod = asRememberPeriod authSettings       , siteKey = key       , lockout = asLockout authSettings@@ -104,7 +105,7 @@ -- | Create the user table if it doesn't exist. createTableIfMissing :: PostgresAuthManager -> IO () createTableIfMissing PostgresAuthManager{..} = do-    liftPG' pamConn $ \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` "'"@@ -179,13 +180,13 @@  querySingle :: (ToRow q, FromRow a)             => Postgres -> Query -> q -> IO (Maybe a)-querySingle pc q ps = liftPG' pc $ \conn -> return . listToMaybe =<<+querySingle pc q ps = withConnection pc $ \conn -> return . listToMaybe =<<     P.query conn q ps  authExecute :: ToRow q             => Postgres -> Query -> q -> IO () authExecute pc q ps = do-    liftPG' pc $ \conn -> P.execute conn q ps+    withConnection pc $ \conn -> P.execute conn q ps     return ()  instance P.ToField Password where@@ -310,7 +311,7 @@     save PostgresAuthManager{..} u@AuthUser{..} = do         let (qstr, params) = saveQuery pamTable u         let q = Query $ T.encodeUtf8 qstr-        let action = liftPG' pamConn $ \conn -> do+        let action = withConnection pamConn $ \conn -> do                 res <- P.query conn q params                 return $ Right $ fromMaybe u $ listToMaybe res         E.catch action onFailure
src/Snap/Snaplet/PostgresqlSimple.hs view
@@ -78,6 +78,7 @@   , pgsInit'   , getConnectionString   , withPG+  , P.Connection   , liftPG    -- * Wrappers and re-exports@@ -130,14 +131,14 @@  import           Prelude hiding ((++)) import           Control.Applicative+import qualified Control.Exception as E import           Control.Lens-import           Control.Monad.CatchIO (MonadCatchIO)-import qualified Control.Monad.CatchIO as CIO import           Control.Monad.IO.Class import           Control.Monad.State import           Control.Monad.Reader+import           Control.Monad.Trans.Control (MonadBaseControl(..)) import           Data.ByteString (ByteString)-import           Data.Monoid(Monoid(..))+import           Data.Monoid(Monoid(..), (<>)) import qualified Data.Configurator as C import qualified Data.Configurator.Types as C import qualified Data.Text as T@@ -157,11 +158,6 @@ import           Snap.Snaplet.PostgresqlSimple.Internal import           Paths_snaplet_postgresql_simple --- This is actually more portable than using <>-(++) :: Monoid a => a -> a -> a-(++) = mappend-infixr 5 ++- ------------------------------------------------------------------------------ -- | Default instance instance HasPostgres (Handler b Postgres) where@@ -175,14 +171,14 @@ -- -- > d <- nestSnaplet "db" db pgsInit -- > count <- liftIO $ runReaderT (execute "INSERT ..." params) d-instance (MonadCatchIO m) => HasPostgres (ReaderT (Snaplet Postgres) m) where+instance (MonadIO m, MonadBaseControl IO 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+instance (MonadIO m, MonadBaseControl IO m) => HasPostgres (ReaderT Postgres m) where     getPostgresState = ask     setLocalPostgresState s = local (const s) @@ -218,9 +214,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,12 +233,12 @@     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)@@ -254,19 +250,19 @@                              ( fromIntegral (numerator   x)                              / fromIntegral (denominator x) :: Double ) -    showText x = qt ++ loop x+    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'+                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  @@ -275,7 +271,7 @@   datadir :: Maybe (IO FilePath)-datadir = Just $ liftM (++"/resources/db") getDataDir+datadir = Just $ liftM (<>"/resources/db") getDataDir   ------------------------------------------------------------------------------@@ -299,11 +295,11 @@ -- rest of the PGSConfig fields are obtained from \"numStripes\", -- \"idleTime\", and \"maxResourcesPerStripe\". mkPGSConfig :: MonadIO m => C.Config -> m PGSConfig-mkPGSConfig 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"+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  @@ -319,20 +315,20 @@ -- | See 'P.query' query :: (HasPostgres m, ToRow q, FromRow r)       => P.Query -> q -> m [r]-query q params = liftPG (\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 = liftPG (`P.query_` 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 = liftPG (\c -> P.returning c q params)+returning q params = liftPG' (\c -> P.returning c q params)   ------------------------------------------------------------------------------@@ -341,15 +337,14 @@          FromRow row,          ToRow params)      => P.Query -> params -> b -> (b -> row -> IO b) -> m b-fold template qs a f = liftPG (\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@@ -357,16 +352,15 @@                 -> (b -> row -> IO b)                 -> m b foldWithOptions opts template qs a f =-    liftPG (\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 = liftPG (\c -> P.fold_ c template a f)+fold_ template a f = liftPG' (\c -> P.fold_ c template a f)   ------------------------------------------------------------------------------@@ -379,7 +373,7 @@                  -> (b -> row -> IO b)                  -> m b foldWithOptions_ opts template a f =-    liftPG (\c -> P.foldWithOptions_ opts c template a f)+    liftPG' (\c -> P.foldWithOptions_ opts c template a f)   ------------------------------------------------------------------------------@@ -388,7 +382,7 @@             FromRow r,             ToRow q)         => P.Query -> q -> (r -> IO ()) -> m ()-forEach template qs f = liftPG (\c -> P.forEach c template qs f)+forEach template qs f = liftPG' (\c -> P.forEach c template qs f)   ------------------------------------------------------------------------------@@ -396,54 +390,71 @@ forEach_ :: (HasPostgres m,              FromRow r)          => P.Query -> (r -> IO ()) -> m ()-forEach_ template f = liftPG (\c -> P.forEach_ c template f)+forEach_ template f = liftPG' (\c -> P.forEach_ c template f)   ------------------------------------------------------------------------------ -- | execute :: (HasPostgres m, ToRow q)         => P.Query -> q -> m Int64-execute template qs = liftPG (\c -> P.execute c template qs)+execute template qs = liftPG' (\c -> P.execute c template qs)   ------------------------------------------------------------------------------ -- | execute_ :: (HasPostgres m)          => P.Query -> m Int64-execute_ template = liftPG (`P.execute_` template)+execute_ template = liftPG' (`P.execute_` template)   ------------------------------------------------------------------------------ -- | executeMany :: (HasPostgres m, ToRow q)         => P.Query -> [q] -> m Int64-executeMany template qs = liftPG (\c -> P.executeMany c template qs)+executeMany template qs = liftPG' (\c -> P.executeMany c template qs)  +------------------------------------------------------------------------------+-- | 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  +------------------------------------------------------------------------------+-- | 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 }  +------------------------------------------------------------------------------+-- | 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 = withPG $ CIO.block $ do-    liftPG $ P.beginMode mode-    r <- CIO.unblock act `CIO.onException` liftPG P.rollback-    liftPG P.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  formatMany :: (ToRow q, HasPostgres m)            => P.Query -> [q] -> m ByteString-formatMany q qs = liftPG (\c -> P.formatMany c q qs)+formatMany q qs = liftPG' (\c -> P.formatMany c q qs)   formatQuery :: (ToRow q, HasPostgres m)             => P.Query -> q -> m ByteString-formatQuery q qs = liftPG (\c -> P.formatQuery c q qs)+formatQuery q qs = liftPG' (\c -> P.formatQuery c q qs)
src/Snap/Snaplet/PostgresqlSimple/Internal.hs view
@@ -5,10 +5,21 @@  module Snap.Snaplet.PostgresqlSimple.Internal where -import           Prelude hiding ((++))-import           Control.Monad.CatchIO (MonadCatchIO) import           Control.Monad.IO.Class+import           Control.Monad.Trans+import           Control.Monad.Trans.Control (MonadBaseControl(..), control)+import           Control.Monad.Trans.Identity+import           Control.Monad.Trans.List+import           Control.Monad.Trans.Maybe+import           Control.Monad.Trans.Reader+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 import           Data.Pool import qualified Database.PostgreSQL.Simple as P @@ -25,11 +36,71 @@ -- 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+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 (ListT m) where+    getPostgresState = lift getPostgresState+    setLocalPostgresState pg (ListT m) = ListT $+      setLocalPostgresState pg m+++instance HasPostgres m => HasPostgres (MaybeT m) where+    getPostgresState = lift getPostgresState+    setLocalPostgresState pg (MaybeT m) = MaybeT $+      setLocalPostgresState pg m+++instance 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@@ -88,16 +159,24 @@ ------------------------------------------------------------------------------ -- | Convenience function for executing a function that needs a database -- connection.-liftPG :: (HasPostgres m) => (P.Connection -> IO b) -> m b-liftPG f = do+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-    liftPG' s f+    withConnection 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)-+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)