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.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 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 @@ -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 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 @@ -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) diff --git a/src/Snap/Snaplet/PostgresqlSimple/Internal.hs b/src/Snap/Snaplet/PostgresqlSimple/Internal.hs --- a/src/Snap/Snaplet/PostgresqlSimple/Internal.hs +++ b/src/Snap/Snaplet/PostgresqlSimple/Internal.hs @@ -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)