snaplet-hdbc (empty) → 0.6.0
raw patch · 5 files changed
+597/−0 lines, 5 filesdep +HDBCdep +basedep +bytestringsetup-changed
Dependencies added: HDBC, base, bytestring, clientsession, containers, convertible, data-lens, data-lens-template, monad-control, mtl, resource-pool, snap, text, time, unordered-containers
Files
- LICENSE +27/−0
- Setup.hs +3/−0
- snaplet-hdbc.cabal +47/−0
- src/Snap/Snaplet/Auth/Backends/Hdbc.hs +265/−0
- src/Snap/Snaplet/Hdbc.hs +255/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2009, Snap Framework authors (see CONTRIBUTORS)+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++Redistributions of source code must retain the above copyright notice, this+list of conditions and the following disclaimer.++Redistributions in binary form must reproduce the above copyright notice, this+list of conditions and the following disclaimer in the documentation and/or+other materials provided with the distribution.++Neither the name of the Snap Framework authors nor the names of its+contributors may be used to endorse or promote products derived from this+software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ snaplet-hdbc.cabal view
@@ -0,0 +1,47 @@+name: snaplet-hdbc+version: 0.6.0+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+ snaplet.+license: BSD3+license-file: LICENSE+author: Jurriën Stutterheim+maintainer: j.stutterheim@me.com+build-type: Simple+cabal-version: >= 1.6+homepage: http://norm2782.com/+category: Web++extra-source-files: LICENSE++source-repository head+ type: git+ location: https://github.com/norm2782/snaplet-hdbc.git++Library+ hs-source-dirs: src++ exposed-modules:+ Snap.Snaplet.Auth.Backends.Hdbc+ Snap.Snaplet.Hdbc++ build-depends:+ base >= 4 && < 5,+ bytestring >= 0.9.1 && < 0.10,+ clientsession >= 0.7.2 && < 0.8,+ containers >= 0.3 && < 0.5,+ convertible >= 1.0 && < 1.1,+ data-lens >= 2.0.1 && < 2.1,+ data-lens-template >= 2.1 && < 2.2,+ HDBC >= 2.2 && < 2.4,+ mtl > 2.0 && < 2.1,+ monad-control >= 0.2 && < 0.3,+ resource-pool >= 0.2 && < 0.3,+ snap >= 0.6 && < 0.7,+ text >= 0.11 && < 0.12,+ time >= 1.1 && < 1.5,+ unordered-containers >= 0.1.4 && < 0.2++ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields+ -fno-warn-orphans -fno-warn-unused-do-bind
+ src/Snap/Snaplet/Auth/Backends/Hdbc.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}++-- | Authentication backend using HDBC+module Snap.Snaplet.Auth.Backends.Hdbc where++import Control.Monad.State+import Data.Convertible.Base+import qualified Data.HashMap.Strict as HM+import Data.Lens.Lazy+import Data.List+import qualified Data.Map as DM+import Data.Pool+import Database.HDBC+import Snap.Snaplet+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 -- ^ 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 -- ^ 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 }++-- | 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+ , colActivatedAt :: String+ , colSuspendedAt :: String+ , colRememberToken :: String+ , colLoginCount :: String+ , colFailedLoginCount :: String+ , colLockedOutUntil :: String+ , colCurrentLoginAt :: String+ , colLastLoginAt :: String+ , colCurrentLoginIp :: String+ , colLastLoginIp :: String+ , colCreatedAt :: String+ , colUpdatedAt :: String+ , colRoles :: String+ , colMeta :: String }++-- | Default authentication table layout+defAuthTable :: AuthTable+defAuthTable+ = AuthTable+ { tblName = "users"+ , colId = "uid"+ , colLogin = "email"+ , colPassword = "password"+ , colActivatedAt = "activated_at"+ , colSuspendedAt = "suspended_at"+ , colRememberToken = "remember_token"+ , colLoginCount = "login_count"+ , colFailedLoginCount = "failed_login_count"+ , colLockedOutUntil = "locked_out_until"+ , colCurrentLoginAt = "current_login_at"+ , colLastLoginAt = "last_login_at"+ , colCurrentLoginIp = "current_login_ip"+ , colLastLoginIp = "last_login_ip"+ , colCreatedAt = "created_at"+ , colUpdatedAt = "updated_at"+ , 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 ]++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+ , saveQuery :: ModifyQuery+ , deleteQuery :: ModifyQuery }++defQueries :: Queries+defQueries = Queries {+ selectQuery = defSelectQuery+ , saveQuery = defSaveQuery+ , deleteQuery = defDeleteQuery }++defSelectQuery :: SelectQuery+defSelectQuery tbl luq sqlVals = case luq of+ ByUserId -> (mkSelect colId, sqlVals)+ ByLogin -> (mkSelect colLogin, sqlVals)+ ByRememberToken -> (mkSelect colRememberToken, sqlVals)+ where mkSelect whr = "SELECT * FROM " ++ tblName tbl ++ " WHERE " +++ whr tbl ++ " = ? "++defSaveQuery :: ModifyQuery+defSaveQuery tbl au = (mkQry uid, mkVals uid)+ where uid = userId au+ mkQry Nothing = "INSERT INTO " ++ tblName tbl ++ " (" +++ intercalate "," (map (\f -> f tbl) colLst)+ ++ ") VALUES (" +++ intercalate "," (map (const "?") colLst)+ ++ ")"+ mkQry (Just _) = "UPDATE " ++ tblName tbl ++ " SET " +++ intercalate "," (map (\f -> f tbl ++ " = ?") colLst)+ ++ " WHERE " ++ colId tbl ++ " = ?"+ mkVals Nothing = mkVals'+ mkVals (Just i) = mkVals' ++ [toSql i]+ mkVals' = [ toSql $ userLogin au+ , toSql $ userPassword au+ , toSql $ userActivatedAt au+ , toSql $ userSuspendedAt au+ , toSql $ userRememberToken au+ , toSql $ userLoginCount au+ , toSql $ userFailedLoginCount au+ , toSql $ userLockedOutUntil au+ , toSql $ userCurrentLoginAt au+ , toSql $ userLastLoginAt au+ , toSql $ userCurrentLoginIp au+ , toSql $ userLastLoginIp au+ , toSql $ userCreatedAt au+ , toSql $ userUpdatedAt au+ , SqlNull -- userRoles au TODO: Implement when ACL system is live+ , SqlNull -- userMeta au TODO: What should we store here?+ ]++defDeleteQuery :: ModifyQuery+defDeleteQuery tbl ausr =+ case userId ausr of+ Nothing -> error "Cannot delete user without unique ID"+ Just uid -> ( "DELETE FROM " ++ tblName tbl ++ " WHERE " +++ colId tbl ++ " = ? "+ , [toSql uid])++instance Convertible Password SqlValue where+ safeConvert (ClearText bs) = Right $ toSql bs+ safeConvert (Encrypted bs) = Right $ toSql bs++instance Convertible UserId SqlValue where+ safeConvert (UserId uid) = Right $ toSql uid++instance IAuthBackend HdbcAuthManager where+ destroy (HdbcAuthManager pool tbl qs) au = withResource pool $+ \conn -> withTransaction conn $ \conn' -> do+ let (qry, vals) = deleteQuery qs tbl au+ stmt <- prepare conn' qry+ _ <- execute stmt vals+ return ()++ save (HdbcAuthManager pool tbl qs) au = withResource pool $+ \conn -> withTransaction conn $ \conn' -> do+ let (qry, vals) = saveQuery qs tbl au+ stmt <- prepare conn' qry+ _ <- execute stmt vals+ -- TODO: Retrieve row to populate ID field after an INSERT... by username? By all fields+ return au++ lookupByUserId mgr@(HdbcAuthManager _ tbl qs) uid = authQuery mgr $+ selectQuery qs tbl ByUserId [toSql uid]+ lookupByLogin mgr@(HdbcAuthManager _ tbl qs) lgn = authQuery mgr $+ selectQuery qs tbl ByLogin [toSql lgn]+ lookupByRememberToken mgr@(HdbcAuthManager _ tbl qs) rmb = authQuery mgr $+ selectQuery qs tbl ByRememberToken [toSql rmb]++authQuery :: HdbcAuthManager -> QueryAndVals -> IO (Maybe AuthUser)+authQuery (HdbcAuthManager pool tbl _) (qry, vals) = withResource pool $ \conn -> withTransaction conn $+ \conn' -> do+ stmt <- prepare conn' qry+ _ <- execute stmt vals+ res <- fetchRowMap stmt+ case res of+ Nothing -> return Nothing+ Just mp -> return $ Just mkUser+ where colLU col' = mp DM.! col' tbl+ rdSql con col' = case colLU col' of+ SqlNull -> Nothing+ x -> Just . con $ fromSql x+ rdInt col = case colLU col of+ SqlNull -> 0+ x -> fromSql x+ mkUser = AuthUser {+ userId = rdSql UserId colId+ , userLogin = fromSql $ colLU colLogin+ , userPassword = rdSql Encrypted colPassword+ , userActivatedAt = rdSql id colActivatedAt+ , userSuspendedAt = rdSql id colSuspendedAt+ , userRememberToken = rdSql id colRememberToken+ , userLoginCount = rdInt colLoginCount+ , userFailedLoginCount = rdInt colFailedLoginCount+ , userLockedOutUntil = rdSql id colLockedOutUntil+ , userCurrentLoginAt = rdSql id colCurrentLoginAt+ , userLastLoginAt = rdSql id colLastLoginAt+ , userCurrentLoginIp = rdSql id colCurrentLoginIp+ , userLastLoginIp = rdSql id colLastLoginIp+ , userCreatedAt = rdSql id colCreatedAt+ , userUpdatedAt = rdSql id colUpdatedAt+ , userRoles = [] -- :: [Role] TODO+ , userMeta = HM.empty } -- :: HashMap Text Value TODO
+ src/Snap/Snaplet/Hdbc.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}++-- | 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(..)+ , HasHdbc(..)+ , hdbcInit+ , query+ , query'++ -- Snapletified HDBC functions+ , clone+ , commit+ , dbServerVer+ , dbTransactionSupport+ , describeTable+ , disconnect+ , getTables+ , hdbcClientVer+ , hdbcDriverName+ , prepare+ , proxiedClientName+ , proxiedClientVer+ , quickQuery+ , quickQuery'+ , rollback+ , run+ , runRaw+ , sRun+ , withHdbc+ , withHdbc'+ , withTransaction+ , withTransaction'++ -- HDBC functions+ , SqlValue(..)+ , HDBC.toSql+ , HDBC.fromSql+ , HDBC.safeFromSql+ , HDBC.nToSql+ , HDBC.iToSql+ , HDBC.posixToSql+ , HDBC.withWConn+ , Statement(..)+ , HDBC.sExecute+ , HDBC.sExecuteMany+ , HDBC.fetchRowAL+ , HDBC.fetchRowMap+ , HDBC.sFetchRow+ , HDBC.fetchAllRows+ , HDBC.fetchAllRows'+ , HDBC.fetchAllRowsAL+ , HDBC.fetchAllRowsAL'+ , HDBC.fetchAllRowsMap+ , HDBC.fetchAllRowsMap'+ , HDBC.sFetchAllRows+ , HDBC.sFetchAllRows'+ , SqlError(..)+ , HDBC.throwSqlError+ , HDBC.catchSql+ , HDBC.handleSql+ , HDBC.sqlExceptions+ , HDBC.handleSqlError+ , module Database.HDBC.ColTypes+ ) where++import Prelude hiding (catch)++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++-- | 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+-- 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)++-- | 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)++-- | 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 ..." []+--+withTransaction' :: HasHdbc m c => m a -> m a+withTransaction' action = do+ r <- onException action doRollback+ commit+ return r+ where doRollback = catch rollback 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+-- how they work.++disconnect :: HasHdbc m c => m ()+disconnect = withHdbc HDBC.disconnect++commit :: HasHdbc m c => m ()+commit = withHdbc HDBC.commit++rollback :: HasHdbc m c => m ()+rollback = withHdbc HDBC.rollback++runRaw :: HasHdbc m c => String -> m ()+runRaw str = withHdbc (`HDBC.runRaw` str)++run :: HasHdbc m c => String -> [SqlValue] -> m Integer+run str vs = withHdbc (\conn -> HDBC.run conn str vs)++prepare :: HasHdbc m c => String -> m Statement+prepare str = withHdbc (`HDBC.prepare` str)++clone :: HasHdbc m c => m c+clone = withHdbc HDBC.clone++hdbcDriverName :: HasHdbc m c => m String+hdbcDriverName = withHdbc' HDBC.hdbcDriverName++hdbcClientVer :: HasHdbc m c => m String+hdbcClientVer = withHdbc' HDBC.hdbcClientVer++proxiedClientName :: HasHdbc m c => m String+proxiedClientName = withHdbc' HDBC.proxiedClientName++proxiedClientVer :: HasHdbc m c => m String+proxiedClientVer = withHdbc' HDBC.proxiedClientVer++dbServerVer :: HasHdbc m c => m String+dbServerVer = withHdbc' HDBC.dbServerVer++dbTransactionSupport :: HasHdbc m c => m Bool+dbTransactionSupport = withHdbc' HDBC.dbTransactionSupport++getTables :: HasHdbc m c => m [String]+getTables = withHdbc HDBC.getTables++describeTable :: HasHdbc m c => String -> m [(String, SqlColDesc)]+describeTable str = withHdbc (`HDBC.describeTable` str)++quickQuery' :: HasHdbc m c => String -> [SqlValue] -> m [[SqlValue]]+quickQuery' str vs = withHdbc (\conn -> HDBC.quickQuery' conn str vs)++quickQuery :: HasHdbc m c => String -> [SqlValue] -> m [[SqlValue]]+quickQuery str vs = withHdbc (\conn -> HDBC.quickQuery conn str vs)++sRun :: HasHdbc m c => String -> [Maybe String] -> m Integer+sRun str mstrs = withHdbc (\conn -> HDBC.sRun conn str mstrs)