diff --git a/snaplet-hdbc.cabal b/snaplet-hdbc.cabal --- a/snaplet-hdbc.cabal +++ b/snaplet-hdbc.cabal @@ -1,5 +1,5 @@ name: snaplet-hdbc -version: 0.6.2.2 +version: 0.6.3 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 @@ -25,6 +25,7 @@ exposed-modules: Snap.Snaplet.Auth.Backends.Hdbc Snap.Snaplet.Hdbc + Snap.Snaplet.Hdbc.Types build-depends: base >= 4 && < 5, diff --git a/src/Snap/Snaplet/Auth/Backends/Hdbc.hs b/src/Snap/Snaplet/Auth/Backends/Hdbc.hs --- a/src/Snap/Snaplet/Auth/Backends/Hdbc.hs +++ b/src/Snap/Snaplet/Auth/Backends/Hdbc.hs @@ -14,11 +14,11 @@ import Data.Map (Map) import qualified Data.Map as DM import Data.Maybe -import Data.Pool import Data.Text (Text) import Database.HDBC import Snap.Snaplet import Snap.Snaplet.Auth +import Snap.Snaplet.Hdbc.Types import Snap.Snaplet.Session import Web.ClientSession @@ -26,34 +26,20 @@ -- pool with commonly acceptable default settings. Use `initHdbcAuthManager'` -- to initialise with a custom resource pool. initHdbcAuthManager - :: IConnection conn + :: (ConnSrc s, IConnection c) => AuthSettings -- ^ Auth settings -> Lens b (Snaplet SessionManager) -- ^ Lens to the session manager - -> IO conn -- ^ Raw HDBC connection + -> s c -- ^ Raw HDBC connection -> AuthTable -- ^ Authentication table configuration -> Queries -- ^ Queries to be used for authentication -> SnapletInit b (AuthManager b) -initHdbcAuthManager s l conn tbl qs = initHdbcAuthManager' s l pool tbl qs - where pool = createPool conn disconnect 1 300 1 - --- | Initialises this HDBC snaplet with a custom resource pool. -initHdbcAuthManager' - :: IConnection conn - => AuthSettings -- ^ Auth settings - -> Lens b (Snaplet SessionManager) -- ^ Lens to the session manager - -> IO (Pool conn) -- ^ A pre-configured resource pool which dispenses - -- HDBC connections - -> AuthTable -- ^ Authentication table configuration - -> Queries -- ^ Queries to be used for authentication - -> SnapletInit b (AuthManager b) -initHdbcAuthManager' s l pool tbl qs = +initHdbcAuthManager s l conn tbl qs = makeSnaplet "HdbcAuthManager" "A snaplet providing user authentication using an HDBC backend" Nothing $ liftIO $ do - key <- getKey (asSiteKey s) - pl <- pool + key <- getKey (asSiteKey s) return AuthManager - { backend = HdbcAuthManager pl tbl qs + { backend = HdbcAuthManager conn tbl qs , session = l , activeUser = Nothing , minPasswdLen = asMinPasswdLen s @@ -65,9 +51,9 @@ -- | Authmanager state containing the resource pool and the table/query -- configuration. data HdbcAuthManager - = forall conn. IConnection conn + = forall c s. (IConnection c, ConnSrc s) => HdbcAuthManager - { authDBPool :: Pool conn + { authDBPool :: s c , table :: AuthTable , qries :: Queries } @@ -210,30 +196,27 @@ safeConvert (UserId uid) = Right $ toSql uid instance IAuthBackend HdbcAuthManager where - destroy (HdbcAuthManager pool tbl qs) au = withResource pool $ - \conn -> do - let (qry, vals) = deleteQuery qs tbl au - _ <- prepExec conn qry vals - return () + destroy (HdbcAuthManager pool tbl qs) au = + let (qry, vals) = deleteQuery qs tbl au + in withConn pool $ prepExec qry vals - save (HdbcAuthManager pool tbl qs) au = withResource pool $ - \conn -> do - let (qry, idQry, vals) = saveQuery qs tbl au - _ <- prepExec conn qry vals - if isJust $ userId au - then return au - else do - rw <- withTransaction conn $ \conn' -> do - stmt' <- prepare conn' idQry - _ <- execute stmt' [ toSql $ userLogin au - , toSql $ userPassword au] - fetchRow stmt' - nid <- case rw of - Nothing -> fail $ "Failed to fetch the newly inserted row. " ++ - "It might not have been inserted at all." - Just [] -> fail "Something went wrong" - Just (x:_) -> return (fromSql x :: Text) - return $ au { userId = Just (UserId nid) } + save (HdbcAuthManager pool tbl qs) au = do + let (qry, idQry, vals) = saveQuery qs tbl au + withConn pool $ prepExec qry vals + if isJust $ userId au + then return au + else do + rw <- withConn pool $ \conn -> withTransaction conn $ \conn' -> do + stmt' <- prepare conn' idQry + _ <- execute stmt' [ toSql $ userLogin au + , toSql $ userPassword au] + fetchRow stmt' + nid <- case rw of + Nothing -> fail $ "Failed to fetch the newly inserted row. " ++ + "It might not have been inserted at all." + Just [] -> fail "Something went wrong" + Just (x:_) -> return (fromSql x :: Text) + return $ au { userId = Just (UserId nid) } lookupByUserId mgr@(HdbcAuthManager _ tbl qs) uid = authQuery mgr $ selectQuery qs tbl ByUserId [toSql uid] @@ -242,20 +225,19 @@ lookupByRememberToken mgr@(HdbcAuthManager _ tbl qs) rmb = authQuery mgr $ selectQuery qs tbl ByRememberToken [toSql rmb] -prepExec :: IConnection conn => conn -> String -> [SqlValue] -> IO () -prepExec conn qry vals = withTransaction conn $ \conn' -> do +prepExec :: IConnection conn => String -> [SqlValue] -> conn -> IO () +prepExec qry vals conn = withTransaction conn $ \conn' -> do stmt <- prepare conn' qry _ <- execute stmt vals return () authQuery :: HdbcAuthManager -> (String, [SqlValue]) -> IO (Maybe AuthUser) -authQuery (HdbcAuthManager pool tbl _) (qry, vals) = - withResource pool $ \conn -> do - res <- do - stmt <- prepare conn qry - _ <- execute stmt vals - fetchRowMap stmt - return $ (return . mkUser tbl) =<< res +authQuery (HdbcAuthManager pool tbl _) (qry, vals) = do + res <- withConn pool $ \conn -> do + stmt <- prepare conn qry + _ <- execute stmt vals + fetchRowMap stmt + return $ (return . mkUser tbl) =<< res mkUser :: AuthTable -> Map String SqlValue -> AuthUser mkUser tbl mp = diff --git a/src/Snap/Snaplet/Hdbc.hs b/src/Snap/Snaplet/Hdbc.hs --- a/src/Snap/Snaplet/Hdbc.hs +++ b/src/Snap/Snaplet/Hdbc.hs @@ -77,15 +77,17 @@ 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 import Snap.Snaplet +import Snap.Snaplet.Hdbc.Types + -- | A map with the column name as key and the value from the database as value type Row = Map String SqlValue + -- | 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 @@ -102,8 +104,9 @@ -- > instance HasHdbc (Handler b App) Connection where -- > getPool = with dbLens $ gets hdbcPool -- -class (IConnection c, MonadControlIO m) => HasHdbc m c | m -> c where - getPool :: m (Pool c) +class (IConnection c, ConnSrc s, MonadControlIO m) + => HasHdbc m c s | m -> c s where + getConnSrc :: m (s c) -- | This is (hopefully) a temporary instance, which will disppear once the -- entire snap framework is switched to 'MonadControlIO'. @@ -112,10 +115,10 @@ -- | The snaplet state type containing a resource pool, parameterised by a raw -- HDBC connection. -data HdbcSnaplet c - = IConnection c +data HdbcSnaplet c s + = (IConnection c, ConnSrc s) => HdbcSnaplet - { hdbcPool :: Pool c } + { connSrc :: s c } -- | Initialise the snaplet by providing it with a raw HDBC connection. A -- resource pool is created with some default parameters that should be fine @@ -123,37 +126,32 @@ -- desired, use the `hdbcInit'` initialiser instead. When the snaplet is -- unloaded, the 'disconnect' function is called to close any remaining -- connections. -hdbcInit :: IConnection c => IO c -> SnapletInit b (HdbcSnaplet c) -hdbcInit conn = hdbcInit' $ createPool conn HDBC.disconnect 1 300 1 +hdbcInit + :: (ConnSrc s, IConnection c) + => s c + -> SnapletInit b (HdbcSnaplet c s) +hdbcInit src = makeSnaplet "hdbc" "HDBC abstraction" Nothing $ + return $ HdbcSnaplet src --- | Instead of a raw HDBC connection, this initialiser expects a --- pre-configured resource pool that dispenses HDBC connections. When the --- snaplet is unloaded, the 'disconnect' function is called to close any --- remaining connections. -hdbcInit' :: IConnection c => IO (Pool c) -> SnapletInit b (HdbcSnaplet c) -hdbcInit' pl = makeSnaplet "hdbc" "HDBC abstraction" Nothing $ do - pl' <- liftIO pl - onUnload $ withResource pl' HDBC.disconnect - return $ HdbcSnaplet pl' -- | 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 => (c -> IO a) -> m a +withHdbc :: HasHdbc m c s => (c -> IO a) -> m a withHdbc f = do - pl <- getPool - withResource pl (liftIO . f) + pl <- getConnSrc + withConn pl (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 => (c -> a) -> m a +withHdbc' :: HasHdbc m c s => (c -> a) -> m a withHdbc' f = do - pl <- getPool - withResource pl (return . f) + pl <- getConnSrc + withConn pl (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. query - :: HasHdbc m c + :: HasHdbc m c s => String -- ^ The raw SQL to execute. Use @?@ to indicate placeholders. -> [SqlValue] -- ^ Values for each placeholder according to its position in -- the SQL statement. @@ -167,7 +165,7 @@ -- | 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. -query' :: HasHdbc m conn => String -> [SqlValue] -> m Integer +query' :: HasHdbc m c s => String -> [SqlValue] -> m Integer query' sql bind = withTransaction' $ do stmt <- prepare sql liftIO $ HDBC.execute stmt bind @@ -177,7 +175,7 @@ -- -- > withTransaction' $ \conn -> do ... -- -withTransaction :: HasHdbc m c => (c -> IO a) -> m a +withTransaction :: HasHdbc m c s => (c -> IO a) -> m a withTransaction f = withHdbc (`HDBC.withTransaction` f) -- | Run an action inside a transaction. If the action throws an exception, the @@ -187,7 +185,7 @@ -- > query "INSERT INTO ..." [] -- > query "DELETE FROM ..." [] -- -withTransaction' :: HasHdbc m c => m a -> m a +withTransaction' :: HasHdbc m c s => m a -> m a withTransaction' action = do r <- onException action doRollback commit @@ -200,56 +198,56 @@ -- functions. Please refer to the HDBC documentation to see what they do and -- how they work. -disconnect :: HasHdbc m c => m () +disconnect :: HasHdbc m c s => m () disconnect = withHdbc HDBC.disconnect -commit :: HasHdbc m c => m () +commit :: HasHdbc m c s => m () commit = withHdbc HDBC.commit -rollback :: HasHdbc m c => m () +rollback :: HasHdbc m c s => m () rollback = withHdbc HDBC.rollback -runRaw :: HasHdbc m c => String -> m () +runRaw :: HasHdbc m c s => String -> m () runRaw str = withHdbc (`HDBC.runRaw` str) -run :: HasHdbc m c => String -> [SqlValue] -> m Integer +run :: HasHdbc m c s => String -> [SqlValue] -> m Integer run str vs = withHdbc (\conn -> HDBC.run conn str vs) -prepare :: HasHdbc m c => String -> m Statement +prepare :: HasHdbc m c s => String -> m Statement prepare str = withHdbc (`HDBC.prepare` str) -clone :: HasHdbc m c => m c +clone :: HasHdbc m c s => m c clone = withHdbc HDBC.clone -hdbcDriverName :: HasHdbc m c => m String +hdbcDriverName :: HasHdbc m c s => m String hdbcDriverName = withHdbc' HDBC.hdbcDriverName -hdbcClientVer :: HasHdbc m c => m String +hdbcClientVer :: HasHdbc m c s => m String hdbcClientVer = withHdbc' HDBC.hdbcClientVer -proxiedClientName :: HasHdbc m c => m String +proxiedClientName :: HasHdbc m c s => m String proxiedClientName = withHdbc' HDBC.proxiedClientName -proxiedClientVer :: HasHdbc m c => m String +proxiedClientVer :: HasHdbc m c s => m String proxiedClientVer = withHdbc' HDBC.proxiedClientVer -dbServerVer :: HasHdbc m c => m String +dbServerVer :: HasHdbc m c s => m String dbServerVer = withHdbc' HDBC.dbServerVer -dbTransactionSupport :: HasHdbc m c => m Bool +dbTransactionSupport :: HasHdbc m c s => m Bool dbTransactionSupport = withHdbc' HDBC.dbTransactionSupport -getTables :: HasHdbc m c => m [String] +getTables :: HasHdbc m c s => m [String] getTables = withHdbc HDBC.getTables -describeTable :: HasHdbc m c => String -> m [(String, SqlColDesc)] +describeTable :: HasHdbc m c s => String -> m [(String, SqlColDesc)] describeTable str = withHdbc (`HDBC.describeTable` str) -quickQuery' :: HasHdbc m c => String -> [SqlValue] -> m [[SqlValue]] +quickQuery' :: HasHdbc m c s => String -> [SqlValue] -> m [[SqlValue]] quickQuery' str vs = withHdbc (\conn -> HDBC.quickQuery' conn str vs) -quickQuery :: HasHdbc m c => String -> [SqlValue] -> m [[SqlValue]] +quickQuery :: HasHdbc m c s => String -> [SqlValue] -> m [[SqlValue]] quickQuery str vs = withHdbc (\conn -> HDBC.quickQuery conn str vs) -sRun :: HasHdbc m c => String -> [Maybe String] -> m Integer +sRun :: HasHdbc m c s => String -> [Maybe String] -> m Integer sRun str mstrs = withHdbc (\conn -> HDBC.sRun conn str mstrs) diff --git a/src/Snap/Snaplet/Hdbc/Types.hs b/src/Snap/Snaplet/Hdbc/Types.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Hdbc/Types.hs @@ -0,0 +1,21 @@ +module Snap.Snaplet.Hdbc.Types where + +import Control.Monad.IO.Control +import Control.Monad.State +import Database.HDBC (IConnection()) +import qualified Database.HDBC as HDBC +import Data.Pool + +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 () + +instance ConnSrc Pool where + withConn = withResource + closeConn _ _ = return () + +instance ConnSrc IO where + withConn conn fn = do + conn' <- liftIO conn + fn conn' + closeConn _ = liftIO . HDBC.disconnect