diff --git a/snap.cabal b/snap.cabal index 586a347e..b5b407d9 100644 --- a/snap.cabal +++ b/snap.cabal @@ -168,7 +168,8 @@ Library unordered-containers >= 0.1.4 && < 0.3, vector >= 0.7.1 && < 0.11, vector-algorithms >= 0.4 && < 0.6, - xmlhtml >= 0.1 && < 0.3 + xmlhtml >= 0.1 && < 0.3, + LDAP >= 0.6.8 && < 0.6.9 extensions: BangPatterns, diff --git a/src/Snap/Snaplet/Auth/AuthManager.hs b/src/Snap/Snaplet/Auth/AuthManager.hs index 0e2500ee..0d602c4f 100644 --- a/src/Snap/Snaplet/Auth/AuthManager.hs +++ b/src/Snap/Snaplet/Auth/AuthManager.hs @@ -60,6 +60,7 @@ class IAuthBackend r where lookupByUserId :: r -> UserId -> IO (Maybe AuthUser) lookupByLogin :: r -> Text -> IO (Maybe AuthUser) lookupByRememberToken :: r -> Text -> IO (Maybe AuthUser) + authenticate :: r -> AuthUser -> Password -> IO (Maybe AuthFailure) destroy :: r -> AuthUser -> IO () @@ -99,5 +100,6 @@ instance IAuthBackend (AuthManager b) where lookupByUserId AuthManager{..} u = lookupByUserId backend u lookupByLogin AuthManager{..} u = lookupByLogin backend u lookupByRememberToken AuthManager{..} u = lookupByRememberToken backend u + authenticate AuthManager{..} u = authenticate backend u destroy AuthManager{..} u = destroy backend u diff --git a/src/Snap/Snaplet/Auth/Backends/JsonFile.hs b/src/Snap/Snaplet/Auth/Backends/JsonFile.hs index 41affd56..78ed0259 100644 --- a/src/Snap/Snaplet/Auth/Backends/JsonFile.hs +++ b/src/Snap/Snaplet/Auth/Backends/JsonFile.hs @@ -270,6 +270,13 @@ instance IAuthBackend JsonFileAuthManager where f cache = getUid >>= getUser cache where getUid = HM.lookup token (tokenCache cache) + + authenticate mgr usr pwd = case userPassword usr of + Just pwd' -> if checkPassword pwd pwd' then + return $ Nothing + else + return $ Just IncorrectPassword + Nothing -> return $ Just IncorrectPassword ------------------------------------------------------------------------------ diff --git a/src/Snap/Snaplet/Auth/Backends/Ldap.hs b/src/Snap/Snaplet/Auth/Backends/Ldap.hs new file mode 100644 index 00000000..9c6fb1aa --- /dev/null +++ b/src/Snap/Snaplet/Auth/Backends/Ldap.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} + + +module Snap.Snaplet.Auth.Backends.Ldap + ( initLdapAuthManager + , mkLdapAuthMgr + ) where + + +import Control.Applicative +import Control.Monad.CatchIO (throw) +import Control.Monad.State +import Control.Concurrent.STM +import Data.Aeson +import qualified Data.Attoparsec as Atto +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString as B +import qualified Data.Map as HM +import Data.Map (Map) +import Data.Maybe (fromJust, isJust) +import Data.Text (Text, unpack) +import qualified Data.Text as T +import Data.Time +import Web.ClientSession +import System.Directory + +import Snap.Snaplet +import Snap.Snaplet.Auth.Types +import Snap.Snaplet.Auth.AuthManager +import Snap.Snaplet.Session +import qualified LDAP as L +import qualified Data.ByteString.UTF8 as Butf8 + +------------------------------------------------------------------------------ +-- | Initialize a JSON file backed 'AuthManager' +initLdapAuthManager :: AuthSettings + -- ^ Authentication settings for your app + -> Text + -- ^ LDAP hostname + -> Integer + -- ^ LDAP port + -> Maybe Text + -- ^ username postfix + -> SnapletLens b SessionManager + -- ^ Lens into a 'SessionManager' auth snaplet will + -- use + -> SnapletInit b (AuthManager b) +initLdapAuthManager s hn prt postfix l = do + makeSnaplet + "LdapAuthManager" + "A snaplet providing user authentication using LDAP backend" + Nothing $ liftIO $ do + rng <- liftIO mkRNG + key <- getKey (asSiteKey s) + ldapMgr <- mkLdapAuthMgr hn prt postfix + return $! AuthManager { + backend = ldapMgr + , session = l + , activeUser = Nothing + , minPasswdLen = asMinPasswdLen s + , rememberCookieName = asRememberCookieName s + , rememberPeriod = asRememberPeriod s + , siteKey = key + , lockout = asLockout s + , randomNumberGenerator = rng + } + + +------------------------------------------------------------------------------ +-- | Load/create a datafile into memory cache and return the manager. +-- +-- This data type can be used by itself for batch/non-handler processing. +mkLdapAuthMgr :: Text -> Integer -> Maybe Text -> IO LdapAuthManager +mkLdapAuthMgr hn prt postfix = do + return $! LdapAuthManager { + hostname = hn + , port = prt + , queryUser = Nothing + , queryPwd = Nothing + , usernamePostfix = postfix + } + + +------------------------------------------------------------------------------ +data LdapAuthManager = LdapAuthManager { + hostname :: Text + , port :: Integer + , queryUser :: Maybe Text + , queryPwd :: Maybe Text + , usernamePostfix :: Maybe Text + } + + ------------------------------------------------------------------------------ +instance IAuthBackend LdapAuthManager where + save r = return . Right + + destroy = error "LdapAuthManager: destroy is not yet implemented" + + lookupByUserId mgr u@(UserId uid) = return $ Just (defAuthUser { userId = Just $ u + , userLogin = uid }) + lookupByLogin mgr login = return $ Just (defAuthUser { userId = Just $ UserId login + , userLogin = login }) + + lookupByRememberToken mgr token = error "LdapAuthManager : lookupByRememberToken is not yet implemented" + authenticate mgr usr pwd = case pwd of + ClearText pwd' -> do + ld <- L.ldapInit (unpack $ hostname mgr) (fromInteger $ port mgr) + x' <- L.handleLDAP (return . Just . AuthError . show) + (L.ldapSimpleBind ld getDn (Butf8.toString pwd') >> return Nothing) + return x' + Encrypted _ -> return $ Just $ AuthError "cannot do LDAP authentication with encrypted password" + where getDn = let usrStr = T.unpack $ userLogin usr + in maybe usrStr (\x -> usrStr ++ T.unpack x) (usernamePostfix mgr) diff --git a/src/Snap/Snaplet/Auth/Handlers.hs b/src/Snap/Snaplet/Auth/Handlers.hs index 57c65f69..e05ccec0 100644 --- a/src/Snap/Snaplet/Auth/Handlers.hs +++ b/src/Snap/Snaplet/Auth/Handlers.hs @@ -267,8 +267,9 @@ checkPasswordAndLogin u pw = where auth :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser) - auth user = - case authenticatePassword user pw of + auth user = do + x <- authenticatePassword user pw + case x of Just e -> do markAuthFail user return $ Left e @@ -358,14 +359,8 @@ getSessionUserId = do -- authenticatePassword :: AuthUser -- ^ Looked up from the back-end -> Password -- ^ Check against this password - -> Maybe AuthFailure -authenticatePassword u pw = auth - where - auth = case userPassword u of - Nothing -> Just PasswordMissing - Just upw -> check $ checkPassword pw upw - - check b = if b then Nothing else Just IncorrectPassword + -> Handler b (AuthManager b) (Maybe AuthFailure) +authenticatePassword u pw = withBackend (\r -> liftIO $ authenticate r u pw) ------------------------------------------------------------------------------