diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/snaplet-hdbc.cabal b/snaplet-hdbc.cabal new file mode 100644 --- /dev/null +++ b/snaplet-hdbc.cabal @@ -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 diff --git a/src/Snap/Snaplet/Auth/Backends/Hdbc.hs b/src/Snap/Snaplet/Auth/Backends/Hdbc.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Auth/Backends/Hdbc.hs @@ -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 diff --git a/src/Snap/Snaplet/Hdbc.hs b/src/Snap/Snaplet/Hdbc.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Hdbc.hs @@ -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)