Permalink
Browse files

Switch back to the regular resource-pool.

Bump version number to 0.6 to match Snap's version numbering.
Add some documentation
  • Loading branch information...
1 parent b22be04 commit e26670f376b0a7d2bfba80b97ee29dd77fcd4b22 @norm2782 committed Oct 28, 2011
Showing with 146 additions and 87 deletions.
  1. +5 −9 snaplet-hdbc.cabal
  2. +66 −52 src/Snap/Snaplet/Auth/Backends/Hdbc.hs
  3. +75 −26 src/Snap/Snaplet/Hdbc.hs
View
@@ -1,5 +1,5 @@
name: snaplet-hdbc
-version: 0.2.0
+version: 0.6.0
synopsis: HDBC snaplet
description: HDBC snaplet
license: BSD3
@@ -30,16 +30,12 @@ Library
data-lens-template >= 2.1 && < 2.2,
HDBC >= 2.2,
mtl > 2.0 && < 2.1,
- MonadCatchIO-transformers >= 0.2,
- resource-pool-catchio >= 0.2,
+ monad-control >= 0.2,
+ resource-pool >= 0.2,
snap >= 0.6 && < 0.7,
text >= 0.11,
time >= 1.2,
unordered-containers >= 0.1.4
- if impl(ghc >= 6.12.0)
- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
- -fno-warn-orphans -fno-warn-unused-do-bind
- else
- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
- -fno-warn-orphans
+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
+ -fno-warn-orphans -fno-warn-unused-do-bind
@@ -3,7 +3,7 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
-
+-- | Authentication backend using HDBC
module Snap.Snaplet.Auth.Backends.Hdbc where
import Control.Monad.State
@@ -19,50 +19,59 @@ import Snap.Snaplet.Auth
import Snap.Snaplet.Session
import Web.ClientSession
+-- | Initialises this HDBC snaplet. It automatically configures a resource
+-- pool with commonly acceptable default settings. Use `initHdbcAuthManager'`
+-- to initialise with a custom resource pool.
initHdbcAuthManager
:: IConnection conn
- => AuthSettings
- -> Lens b (Snaplet SessionManager)
- -> IO conn
- -> AuthTable
- -> Queries
+ => AuthSettings -- ^ Auth settings
+ -> Lens b (Snaplet SessionManager) -- ^ Lens to the session manager
+ -> IO conn -- ^ 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
- -> Lens b (Snaplet SessionManager)
- -> IO (Pool conn)
- -> AuthTable
- -> Queries
+ => 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 =
makeSnaplet "HdbcAuthManager"
"A snaplet providing user authentication using an HDBC backend"
Nothing $ liftIO $ do
key <- getKey (asSiteKey s)
pl <- pool
- return AuthManager {
- backend = HdbcAuthManager pl tbl qs
- , session = l
- , activeUser = Nothing
- , minPasswdLen = asMinPasswdLen s
- , rememberCookieName = asRememberCookieName s
- , rememberPeriod = asRememberPeriod s
- , siteKey = key
- , lockout = asLockout s
- }
-
-data HdbcAuthManager = forall conn. IConnection conn => HdbcAuthManager {
- authDBPool :: Pool conn
- , table :: AuthTable
- , qries :: Queries
-}
-
-data AuthTable = AuthTable {
- tblName :: String
+ return AuthManager
+ { backend = HdbcAuthManager pl tbl qs
+ , session = l
+ , activeUser = Nothing
+ , minPasswdLen = asMinPasswdLen s
+ , rememberCookieName = asRememberCookieName s
+ , rememberPeriod = asRememberPeriod s
+ , siteKey = key
+ , lockout = asLockout s }
+
+-- | Authmanager state containing the resource pool and the table/query
+-- configuration.
+data HdbcAuthManager
+ = forall conn. IConnection conn
+ => HdbcAuthManager
+ { authDBPool :: Pool conn
+ , table :: AuthTable
+ , qries :: Queries }
+
+-- | Datatype containing the names of the columns for the authentication table.
+data AuthTable
+ = AuthTable
+ { tblName :: String
, colId :: String
, colLogin :: String
, colPassword :: String
@@ -81,9 +90,11 @@ data AuthTable = AuthTable {
, colRoles :: String
, colMeta :: String }
+-- | Default authentication table layout
defAuthTable :: AuthTable
-defAuthTable = AuthTable {
- tblName = "users"
+defAuthTable
+ = AuthTable
+ { tblName = "users"
, colId = "uid"
, colLogin = "email"
, colPassword = "password"
@@ -102,35 +113,38 @@ defAuthTable = AuthTable {
, colRoles = "roles"
, colMeta = "meta" }
+-- | List of deconstructors so it's easier to extract column names form an
+-- 'AuthTable'.
colLst :: [AuthTable -> String]
-colLst = [ colLogin
- , colPassword
- , colActivatedAt
- , colSuspendedAt
- , colRememberToken
- , colLoginCount
- , colFailedLoginCount
- , colLockedOutUntil
- , colCurrentLoginAt
- , colLastLoginAt
- , colCurrentLoginIp
- , colLastLoginIp
- , colCreatedAt
- , colUpdatedAt
- , colRoles
- , colMeta ]
+colLst =
+ [ colLogin
+ , colPassword
+ , colActivatedAt
+ , colSuspendedAt
+ , colRememberToken
+ , colLoginCount
+ , colFailedLoginCount
+ , colLockedOutUntil
+ , colCurrentLoginAt
+ , colLastLoginAt
+ , colCurrentLoginIp
+ , colLastLoginIp
+ , colCreatedAt
+ , colUpdatedAt
+ , colRoles
+ , colMeta ]
data LookupQuery = ByUserId | ByLogin | ByRememberToken
type QueryAndVals = (String, [SqlValue])
type SelectQuery = AuthTable -> LookupQuery -> [SqlValue] -> QueryAndVals
type ModifyQuery = AuthTable -> AuthUser -> QueryAndVals
-data Queries = Queries {
- selectQuery :: SelectQuery
+data Queries
+ = Queries
+ { selectQuery :: SelectQuery
, saveQuery :: ModifyQuery
- , deleteQuery :: ModifyQuery
-}
+ , deleteQuery :: ModifyQuery }
defQueries :: Queries
defQueries = Queries {
View
@@ -4,10 +4,9 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
-{-|
-
- This module provides a very thin wrapper around HDBC
--}
+-- | This module provides a very thin wrapper around HDBC. It wraps some of the
+-- HDBC functions in more convenient functions and re-exports the rest of the
+-- HDBC functions.
module Snap.Snaplet.Hdbc (
-- Snaplet functions
HdbcSnaplet(..)
@@ -74,8 +73,8 @@ module Snap.Snaplet.Hdbc (
import Prelude hiding (catch)
-import Control.Exception (SomeException)
-import Control.Monad.CatchIO
+import Control.Exception.Control hiding (Handler)
+import Control.Monad.IO.Control
import Control.Monad.State
import Data.Map (Map)
import Data.Pool
@@ -84,73 +83,123 @@ import Database.HDBC (IConnection(), SqlValue, SqlError, Statement)
import Database.HDBC.ColTypes
import Snap.Snaplet
+-- | A map with the column name as key and the value from the database as value
type Row = Map String SqlValue
-class (IConnection c, MonadCatchIO m) => HasHdbc m c | m -> c where
+-- | 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
+--
+class (IConnection c, MonadControlIO m) => HasHdbc m c | m -> c where
getPool :: m (Pool c)
+-- | 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)
-data HdbcSnaplet c = IConnection c => HdbcSnaplet {
- hdbcPool :: Pool c }
-
+-- | The snaplet state type containing a resource pool, parameterised by a raw
+-- HDBC connection.
+data HdbcSnaplet c
+ = IConnection c
+ => HdbcSnaplet
+ { hdbcPool :: Pool 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
+-- for most common usecases. If a custom resource pool configuration is
+-- 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'
+-- | 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 f = do
pl <- getPool
withResource pl (\conn -> liftIO $ f conn)
+-- | 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' f = do
pl <- getPool
withResource pl (\conn -> return $ f conn)
-query :: HasHdbc m c
- => String {-^ The raw SQL to execute. Use @?@ to indicate
- placeholders. -}
- -> [SqlValue] {-^ Values for each placeholder according to its position
- in the SQL statement. -}
- -> m [Row] {-^ A 'Map' of attribute name to attribute value for each
- row. Can be the empty list. -}
+-- | 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
+ => String -- ^ The raw SQL to execute. Use @?@ to indicate placeholders.
+ -> [SqlValue] -- ^ Values for each placeholder according to its position in
+ -- the SQL statement.
+ -> m [Row] -- ^ A 'Map' of attribute name to attribute value for each
+ -- row. Can be the empty list.
query sql bind = do
stmt <- prepare sql
liftIO $ HDBC.execute stmt bind
liftIO $ HDBC.fetchAllRowsMap stmt
+-- | 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' 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.
+--
+-- > withTransaction' $ \conn -> do ...
+--
withTransaction :: HasHdbc m c => (c -> IO a) -> m a
withTransaction f = withHdbc (`HDBC.withTransaction` f)
-{-| Run an action inside a transaction. If the action throws an exception, the
-transaction will be rolled back, and the exception rethrown.
-
-> withTransaction' $ do
-> query "INSERT INTO ..." []
-> query "DELETE FROM ..." []
-
--}
+-- | Run an action inside a transaction. If the action throws an exception, the
+-- transaction will be rolled back, and the exception rethrown.
+--
+-- > withTransaction' $ do
+-- > query "INSERT INTO ..." []
+-- > query "DELETE FROM ..." []
+--
withTransaction' :: HasHdbc m c => m a -> m a
withTransaction' action = do
r <- onException action doRollback
commit
return r
where doRollback = catch rollback doRollbackHandler
- doRollbackHandler :: MonadCatchIO m => SomeException -> m ()
+ 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
+-- how they work.
+
disconnect :: HasHdbc m c => m ()
disconnect = withHdbc HDBC.disconnect

0 comments on commit e26670f

Please sign in to comment.