snaplet-hdbc 0.6.3 → 0.7
raw patch · 4 files changed
+71/−56 lines, 4 filesdep ~snap
Dependency ranges changed: snap
Files
- snaplet-hdbc.cabal +2/−2
- src/Snap/Snaplet/Auth/Backends/Hdbc.hs +14/−12
- src/Snap/Snaplet/Hdbc.hs +30/−35
- src/Snap/Snaplet/Hdbc/Types.hs +25/−7
snaplet-hdbc.cabal view
@@ -1,5 +1,5 @@ name: snaplet-hdbc-version: 0.6.3+version: 0.7 synopsis: HDBC snaplet for Snap Framework description: This snaplet consists of two parts: an HDBC abstraction snaplet and an HDBC authentication backend for Snap's authentication@@ -39,7 +39,7 @@ mtl > 2.0 && < 2.1, monad-control >= 0.2 && < 0.3, resource-pool >= 0.2 && < 0.3,- snap >= 0.6 && < 0.7,+ snap >= 0.6 && < 0.8, text >= 0.11 && < 0.12, time >= 1.1 && < 1.5, unordered-containers >= 0.1.4 && < 0.2
src/Snap/Snaplet/Auth/Backends/Hdbc.hs view
@@ -6,6 +6,7 @@ -- | Authentication backend using HDBC module Snap.Snaplet.Auth.Backends.Hdbc where +import Control.Concurrent.MVar import Control.Monad.State import Data.Convertible.Base import qualified Data.HashMap.Strict as HM@@ -37,9 +38,10 @@ makeSnaplet "HdbcAuthManager" "A snaplet providing user authentication using an HDBC backend" Nothing $ liftIO $ do- key <- getKey (asSiteKey s)+ mv <- newEmptyMVar+ key <- getKey (asSiteKey s) return AuthManager- { backend = HdbcAuthManager conn tbl qs+ { backend = HdbcAuthManager (HdbcSnaplet conn mv) tbl qs , session = l , activeUser = Nothing , minPasswdLen = asMinPasswdLen s@@ -53,9 +55,9 @@ data HdbcAuthManager = forall c s. (IConnection c, ConnSrc s) => HdbcAuthManager- { authDBPool :: s c- , table :: AuthTable- , qries :: Queries }+ { connSt :: HdbcSnaplet c s+ , table :: AuthTable+ , qries :: Queries } -- | Datatype containing the names of the columns for the authentication table. data AuthTable@@ -196,17 +198,17 @@ safeConvert (UserId uid) = Right $ toSql uid instance IAuthBackend HdbcAuthManager where- destroy (HdbcAuthManager pool tbl qs) au =+ destroy (HdbcAuthManager st tbl qs) au = let (qry, vals) = deleteQuery qs tbl au- in withConn pool $ prepExec qry vals+ in withConn st $ prepExec qry vals - save (HdbcAuthManager pool tbl qs) au = do+ save (HdbcAuthManager st tbl qs) au = do let (qry, idQry, vals) = saveQuery qs tbl au- withConn pool $ prepExec qry vals+ withConn st $ prepExec qry vals if isJust $ userId au then return au else do- rw <- withConn pool $ \conn -> withTransaction conn $ \conn' -> do+ rw <- withConn st $ \conn -> withTransaction conn $ \conn' -> do stmt' <- prepare conn' idQry _ <- execute stmt' [ toSql $ userLogin au , toSql $ userPassword au]@@ -232,8 +234,8 @@ return () authQuery :: HdbcAuthManager -> (String, [SqlValue]) -> IO (Maybe AuthUser)-authQuery (HdbcAuthManager pool tbl _) (qry, vals) = do- res <- withConn pool $ \conn -> do+authQuery (HdbcAuthManager st tbl _) (qry, vals) = do+ res <- withConn st $ \conn -> do stmt <- prepare conn qry _ <- execute stmt vals fetchRowMap stmt
src/Snap/Snaplet/Hdbc.hs view
@@ -11,6 +11,9 @@ -- Snaplet functions HdbcSnaplet(..) , HasHdbc(..)+ , HdbcIO+ , HdbcPool+ , Row , hdbcInit , query , query'@@ -73,10 +76,12 @@ import Prelude hiding (catch) +import Control.Concurrent.MVar import Control.Exception.Control hiding (Handler) import Control.Monad.IO.Control import Control.Monad.State import Data.Map (Map)+import Data.Pool import qualified Database.HDBC as HDBC import Database.HDBC (IConnection(), SqlValue, SqlError, Statement) import Database.HDBC.ColTypes@@ -89,36 +94,18 @@ -- | Instantiate this typeclass on 'Handler b YourSnapletState' so this snaplet--- can find the resource pool. Typically you would instantiate it for Snap's--- Handler type and use your snaplet's lens to this snaplet to access this--- snaplet's state, which contains the pool. Suppose your snaplet state type is--- defined as follows, where 'Connection' is the connection type from the HDBC--- database adapter of your choosing:------ > data App = App--- > { _dbLens :: Snaplet (HdbcSnaplet Connection) }------ Then a typical instance you will want to define in your own snaplet is the--- following:------ > instance HasHdbc (Handler b App) Connection where--- > getPool = with dbLens $ gets hdbcPool---+-- can find the connection source. class (IConnection c, ConnSrc s, MonadControlIO m) => HasHdbc m c s | m -> c s where- getConnSrc :: m (s c)+ getHdbcState :: m (HdbcSnaplet c s) -- | This is (hopefully) a temporary instance, which will disppear once the -- entire snap framework is switched to 'MonadControlIO'. instance MonadControlIO (Handler b v) where liftControlIO f = liftIO (f return) --- | The snaplet state type containing a resource pool, parameterised by a raw--- HDBC connection.-data HdbcSnaplet c s- = (IConnection c, ConnSrc s)- => HdbcSnaplet- { connSrc :: s c }+type HdbcIO c = HdbcSnaplet c IO+type HdbcPool c = HdbcSnaplet c Pool -- | Initialise the snaplet by providing it with a raw HDBC connection. A -- resource pool is created with some default parameters that should be fine@@ -130,23 +117,24 @@ :: (ConnSrc s, IConnection c) => s c -> SnapletInit b (HdbcSnaplet c s)-hdbcInit src = makeSnaplet "hdbc" "HDBC abstraction" Nothing $- return $ HdbcSnaplet src+hdbcInit src = makeSnaplet "hdbc" "HDBC abstraction" Nothing $ do+ mv <- liftIO newEmptyMVar+ return $ HdbcSnaplet src mv -- | Get a new connection from the resource pool, apply the provided function -- to it and return the result in of the 'IO' compution in monad @m@. withHdbc :: HasHdbc m c s => (c -> IO a) -> m a withHdbc f = do- pl <- getConnSrc- withConn pl (liftIO . f)+ st <- getHdbcState+ withConn st (liftIO . f) -- | Get a new connection from the resource pool, apply the provided function -- to it and return the result in of the compution in monad 'm'. withHdbc' :: HasHdbc m c s => (c -> a) -> m a withHdbc' f = do- pl <- getConnSrc- withConn pl (return . f)+ st <- getHdbcState+ withConn st (return . f) -- | Execute a @SELECT@ query on the database by passing the query as 'String', -- together with a list of values to bind to it. A list of 'Row's is returned.@@ -165,11 +153,18 @@ -- | Similar to 'query', but instead of returning a list of 'Row's, it returns -- an 'Integer' indicating the numbers of affected rows. This is typically used -- for @INSERT@, @UPDATE@ and @DELETE@ queries.+-- TODO: Revert to the implementation below once withTransaction' works as expected. query' :: HasHdbc m c s => String -> [SqlValue] -> m Integer-query' sql bind = withTransaction' $ do- stmt <- prepare sql+query' sql bind = withTransaction $ \conn -> do+ stmt <- HDBC.prepare conn sql liftIO $ HDBC.execute stmt bind +-- query' below doesn't work that well, due to withTransaction'+{- query' :: HasHdbc m c s => String -> [SqlValue] -> m Integer-}+{- query' sql bind = withTransaction' $ do-}+ {- stmt <- prepare sql-}+ {- liftIO $ HDBC.execute stmt bind-}+ -- | Run an action inside a transaction. If the action throws an exception, the -- transaction will be rolled back, and the exception rethrown. --@@ -184,15 +179,15 @@ -- > withTransaction' $ do -- > query "INSERT INTO ..." [] -- > query "DELETE FROM ..." []---+-- TODO: This isn't really working yet... we need something like query' withTransaction' :: HasHdbc m c s => m a -> m a withTransaction' action = do- r <- onException action doRollback+ r <- action `onException` doRollback commit return r- where doRollback = catch rollback doRollbackHandler- doRollbackHandler :: MonadControlIO m => SomeException -> m ()- doRollbackHandler _ = return ()+ where doRollback = rollback `catch` doRollbackHandler+ doRollbackHandler :: MonadControlIO m => SomeException -> m ()+ doRollbackHandler _ = return () -- | The functions provided below are wrappers around the original HDBC -- functions. Please refer to the HDBC documentation to see what they do and
src/Snap/Snaplet/Hdbc/Types.hs view
@@ -1,21 +1,39 @@+{-# LANGUAGE ExistentialQuantification #-}+ module Snap.Snaplet.Hdbc.Types where +import Control.Concurrent.MVar import Control.Monad.IO.Control import Control.Monad.State import Database.HDBC (IConnection()) import qualified Database.HDBC as HDBC import Data.Pool +-- | The snaplet state type containing a resource pool, parameterised by a raw+-- HDBC connection.+data HdbcSnaplet c s+ = (IConnection c, ConnSrc s)+ => HdbcSnaplet+ { connSrc :: s c+ , connVar :: MVar c }+ class ConnSrc s where- withConn :: (MonadControlIO m, IConnection c) => s c -> (c -> m b) -> m b- closeConn :: (MonadControlIO m, IConnection c) => s c -> c -> m ()+ withConn :: (MonadControlIO m, IConnection c) => HdbcSnaplet c s -> (c -> m b) -> m b+ closeConn :: (MonadControlIO m, IConnection c) => HdbcSnaplet c s -> c -> m () instance ConnSrc Pool where- withConn = withResource+ withConn = withResource . connSrc closeConn _ _ = return () instance ConnSrc IO where- withConn conn fn = do- conn' <- liftIO conn- fn conn'- closeConn _ = liftIO . HDBC.disconnect+ withConn st fn = do+ let cv = connVar st+ emp <- liftIO $ isEmptyMVar cv+ conn <- if emp+ then do+ conn <- liftIO $ connSrc st+ liftIO $ putMVar cv conn+ return conn+ else liftIO $ readMVar cv+ fn conn+ closeConn _ = liftIO . HDBC.disconnect