Skip to content
Browse files

Abstract from resource-pool

  • Loading branch information...
1 parent 6f89ba8 commit eb695dd19dd06df9fc4d66837a1fe278da98cfd0 @norm2782 committed
Showing with 81 additions and 78 deletions.
  1. +2 −1 snaplet-hdbc.cabal
  2. +17 −31 src/Snap/Snaplet/Auth/Backends/Hdbc.hs
  3. +40 −46 src/Snap/Snaplet/Hdbc.hs
  4. +22 −0 src/Snap/Snaplet/Hdbc/Types.hs
View
3 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 @@ Library
exposed-modules:
Snap.Snaplet.Auth.Backends.Hdbc
Snap.Snaplet.Hdbc
+ Snap.Snaplet.Hdbc.Types
build-depends:
base >= 4 && < 5,
View
48 src/Snap/Snaplet/Auth/Backends/Hdbc.hs
@@ -14,11 +14,11 @@ import Data.List
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 @@ import Web.ClientSession
-- 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 @@ initHdbcAuthManager' s l pool tbl qs =
-- | 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 }
@@ -212,24 +198,24 @@ instance Convertible UserId SqlValue where
instance IAuthBackend HdbcAuthManager where
destroy (HdbcAuthManager pool tbl qs) au =
let (qry, vals) = deleteQuery qs tbl au
- in withResource pool $ prepExec qry vals
+ in withConn pool $ prepExec qry vals
save (HdbcAuthManager pool tbl qs) au = do
let (qry, idQry, vals) = saveQuery qs tbl au
- withResource pool $ prepExec qry vals
+ withConn pool $ prepExec qry vals
if isJust $ userId au
then return au
else do
- rw <- withResource pool $ \conn -> withTransaction conn $ \conn' -> 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)
+ 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 $
@@ -247,7 +233,7 @@ prepExec qry vals conn = withTransaction conn $ \conn' -> do
authQuery :: HdbcAuthManager -> (String, [SqlValue]) -> IO (Maybe AuthUser)
authQuery (HdbcAuthManager pool tbl _) (qry, vals) = do
- res <- withResource pool $ \conn -> do
+ res <- withConn pool $ \conn -> do
stmt <- prepare conn qry
_ <- execute stmt vals
fetchRowMap stmt
View
86 src/Snap/Snaplet/Hdbc.hs
@@ -77,15 +77,17 @@ 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
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,8 @@ type Row = Map String SqlValue
-- > 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 +114,10 @@ instance MonadControlIO (Handler b v) where
-- | 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 +125,29 @@ data HdbcSnaplet c
-- 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
-
--- | 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'
+hdbcInit :: (ConnSrc s, IConnection c) => s c -> SnapletInit b (HdbcSnaplet c s)
+hdbcInit src = makeSnaplet "hdbc" "HDBC abstraction" Nothing $
+ return $ HdbcSnaplet src
+
-- | 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 +161,7 @@ query sql bind = do
-- | 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 +171,7 @@ query' sql bind = withTransaction' $ do
--
-- > 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 +181,7 @@ withTransaction f = withHdbc (`HDBC.withTransaction` f)
-- > 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 +194,56 @@ withTransaction' action = do
-- 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)
View
22 src/Snap/Snaplet/Hdbc/Types.hs
@@ -0,0 +1,22 @@
+module Snap.Snaplet.Hdbc.Types where
+
+import Prelude hiding (catch)
+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

0 comments on commit eb695dd

Please sign in to comment.
Something went wrong with that request. Please try again.