Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

374 lines (310 sloc) 12.014 kb
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
This module contains all the central authentication functionality.
It exports a number of high-level functions to be used directly in your
application handlers.
We also export a number of mid-level functions that
should be helpful when you are integrating with another way of confirming the
authentication of login requests.
-}
module Snap.Snaplet.Auth
(
-- * Higher Level Handler Functions
createUser
, saveUser
, destroyUser
, loginByUsername
, loginByRememberToken
, forceLogin
, logout
, currentUser
, isLoggedIn
-- * Lower Level Functions
, markAuthSuccess
, markAuthFail
, checkPasswordAndLogin
-- * Types
, AuthManager
, IAuthBackend
, AuthSettings(..)
, defAuthSettings
, AuthUser(..)
, UserId(..)
, Password(..)
, AuthFailure(..)
, BackendError(..)
-- * Other Utilities
, authenticatePassword
, setPassword
)
where
import Control.Monad.State
import Data.ByteString (ByteString)
import Data.Maybe (isJust)
import Data.Serialize hiding (get)
import Data.Time
import Data.Text.Encoding (decodeUtf8)
import Data.Text (Text)
import Web.ClientSession
import Snap.Core
import Snap.Snaplet
import qualified Snap.Snaplet.Auth.AuthManager as AM
import Snap.Snaplet.Auth.AuthManager (IAuthBackend(..), AuthManager(..))
import Snap.Snaplet.Auth.Types
import Snap.Snaplet.Session
import Snap.Snaplet.Session.Common
import Snap.Snaplet.Session.SecureCookie
------------------------------------------------------------------------------
-- Higher level functions
--
------------------------------------------------------------------------------
------------------------------------------------------------------------------
-- | Create a new user from just a username and password
--
-- May throw a "DuplicateLogin' if given username is not unique
createUser
:: Text -- Username
-> ByteString -- Password
-> Handler b (AuthManager b) AuthUser
createUser unm pwd = do
(AuthManager r _ _ _ _ _ _ _) <- get
liftIO $ AM.createUser r unm pwd
------------------------------------------------------------------------------
-- | Lookup a user by her username, check given password and perform login
loginByUsername
:: ByteString -- ^ Username/login for user
-> Password -- ^ Should be ClearText
-> Bool -- ^ Set remember token?
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginByUsername _ (Encrypted _) _ = error "Cannot login with encrypted password"
loginByUsername unm pwd rm = do
AuthManager r _ _ _ cn rp sk _ <- get
au <- liftIO $ lookupByLogin r (decodeUtf8 unm)
case au of
Nothing -> return $ Left UserNotFound
Just au' -> do
res <- checkPasswordAndLogin au' pwd
case res of
Left e -> return $ Left e
Right au'' -> do
case rm of
True -> do
token <- liftIO $ randomToken 64
setRememberToken sk cn rp token
let au''' = au'' { userRememberToken = Just (decodeUtf8 token) }
saveUser au'''
return $ Right au'''
False -> return $ Right au''
------------------------------------------------------------------------------
-- | Remember user from the remember token if possible and perform login
loginByRememberToken :: Handler b (AuthManager b) (Maybe AuthUser)
loginByRememberToken = do
(AuthManager r _ _ _ rc rp sk _) <- get
token <- getRememberToken sk rc rp
au <- maybe (return Nothing) (liftIO . lookupByRememberToken r . decodeUtf8) token
case au of
Just au' -> forceLogin au' >> return au
Nothing -> return Nothing
------------------------------------------------------------------------------
-- | Logout the active user
logout :: Handler b (AuthManager b) ()
logout = do
s <- gets session
withTop s $ withSession s removeSessionUserId
AuthManager _ _ _ _ rc _ _ _ <- get
forgetRememberToken rc
modify (\mgr -> mgr { activeUser = Nothing } )
------------------------------------------------------------------------------
-- | Return the current user; trying to remember from cookie if possible.
currentUser :: Handler b (AuthManager b) (Maybe AuthUser)
currentUser = cacheOrLookup f
where
f = do
(AuthManager r s _ _ _ _ _ _) <- get
uid <- withTop s getSessionUserId
case uid of
Nothing -> loginByRememberToken
Just uid' -> liftIO $ lookupByUserId r uid'
------------------------------------------------------------------------------
-- | Convenience wrapper around 'rememberUser' that returns a bool result
isLoggedIn :: Handler b (AuthManager b) Bool
isLoggedIn = isJust `fmap` currentUser
------------------------------------------------------------------------------
-- | Create or update a given user
--
-- May throw a 'BackendError' if something goes wrong.
saveUser :: AuthUser -> Handler b (AuthManager b) AuthUser
saveUser u = do
(AuthManager r _ _ _ _ _ _ _) <- get
liftIO $ save r u
------------------------------------------------------------------------------
-- | Destroy the given user
--
-- May throw a 'BackendError' if something goes wrong.
destroyUser :: AuthUser -> Handler b (AuthManager b) ()
destroyUser u = do
(AuthManager r _ _ _ _ _ _ _) <- get
liftIO $ destroy r u
------------------------------------------------------------------------------
-- Lower level helper functions
--
------------------------------------------------------------------------------
------------------------------------------------------------------------------
-- | Mutate an 'AuthUser', marking failed authentication
--
-- This will save the user to the backend.
markAuthFail :: AuthUser -> Handler b (AuthManager b) AuthUser
markAuthFail u = do
(AuthManager r _ _ _ _ _ _ lo) <- get
incFailCtr u >>= checkLockout lo >>= liftIO . save r
where
incFailCtr u' = return $ u'
{ userFailedLoginCount = userFailedLoginCount u' + 1}
checkLockout lo u' = case lo of
Nothing -> return u'
Just (mx, wait) ->
case userFailedLoginCount u' >= mx of
True -> do
now <- liftIO getCurrentTime
let reopen = addUTCTime wait now
return $ u' { userLockedOutUntil = Just reopen }
------------------------------------------------------------------------------
-- | Mutate an 'AuthUser', marking successful authentication
--
-- This will save the user to the backend.
markAuthSuccess :: AuthUser -> Handler b (AuthManager b) AuthUser
markAuthSuccess u = do
(AuthManager r _ _ _ _ _ _ _) <- get
incLoginCtr u >>= updateIp >>= updateLoginTS
>>= resetFailCtr >>= liftIO . save r
where
incLoginCtr u' = return $ u' { userLoginCount = userLoginCount u' + 1 }
updateIp u' = do
ip <- rqRemoteAddr `fmap` getRequest
return $ u' { userLastLoginIp = userCurrentLoginIp u'
, userCurrentLoginIp = Just ip }
updateLoginTS u' = do
now <- liftIO getCurrentTime
return $
u' { userCurrentLoginAt = Just now
, userLastLoginAt = userCurrentLoginAt u' }
resetFailCtr u' = return $
u' { userFailedLoginCount = 0
, userLockedOutUntil = Nothing }
------------------------------------------------------------------------------
-- | Authenticate and log the user into the current session if successful.
--
-- This is a mid-level function exposed to allow roll-your-own ways of looking
-- up a user from the database.
--
-- This function will:
--
-- 1. Check the password
--
-- 2. Login the user into the current session
--
-- 3. Mark success/failure of the authentication trial on the user record
checkPasswordAndLogin
:: AuthUser -- ^ An existing user, somehow looked up from db
-> Password -- ^ A ClearText password
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
checkPasswordAndLogin u pw =
case userLockedOutUntil u of
Just x -> do
now <- liftIO getCurrentTime
if now > x
then auth u
else return . Left $ LockedOut x
Nothing -> auth u
where
auth user =
case authenticatePassword user pw of
Just e -> do
markAuthFail user
return $ Left e
Nothing -> do
forceLogin user
modify (\mgr -> mgr { activeUser = Just user })
user' <- markAuthSuccess user
return $ Right user'
------------------------------------------------------------------------------
-- | Login and persist the given 'AuthUser' in the active session
--
-- Meant to be used if you have other means of being sure that the person is
-- who she says she is.
forceLogin
:: AuthUser
-- ^ An existing user, somehow looked up from db
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forceLogin u = do
AuthManager _ s _ _ _ _ _ _ <- get
withSession s $ do
case userId u of
Just x -> do
withTop s (setSessionUserId x)
return $ Right u
Nothing -> return . Left $
AuthError "forceLogin: Can't force the login of a user without userId"
------------------------------------------------------------------------------
-- Internal, non-exported helpers
--
------------------------------------------------------------------------------
getRememberToken :: (Serialize t, MonadSnap m)
=> Key
-> ByteString
-> Maybe Int
-> m (Maybe t)
getRememberToken sk rc rp = getSecureCookie rc sk rp
setRememberToken :: (Serialize t, MonadSnap m)
=> Key
-> ByteString
-> Maybe Int
-> t
-> m ()
setRememberToken sk rc rp token = setSecureCookie rc sk rp token
forgetRememberToken :: MonadSnap m => ByteString -> m ()
forgetRememberToken rc = expireCookie rc (Just "/")
------------------------------------------------------------------------------
-- | Set the current user's 'UserId' in the active session
setSessionUserId :: UserId -> Handler b SessionManager ()
setSessionUserId (UserId t) = setInSession "__user_id" t
------------------------------------------------------------------------------
-- | Remove 'UserId' from active session, effectively logging the user out.
removeSessionUserId :: Handler b SessionManager ()
removeSessionUserId = deleteFromSession "__user_id"
------------------------------------------------------------------------------
-- | Get the current user's 'UserId' from the active session
getSessionUserId :: Handler b SessionManager (Maybe UserId)
getSessionUserId = do
uid <- getFromSession "__user_id"
return $ uid >>= return . UserId
------------------------------------------------------------------------------
-- | Check password for a given user.
--
-- Returns 'Nothing" if check is successful and an 'IncorrectPassword' error
-- otherwise
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
------------------------------------------------------------------------------
-- | Wrap lookups around request-local cache
cacheOrLookup
:: Handler b (AuthManager b) (Maybe AuthUser)
-- ^ Lookup action to perform if request local cache is empty
-> Handler b (AuthManager b) (Maybe AuthUser)
cacheOrLookup f = do
au <- gets activeUser
if isJust au
then return au
else do
au' <- f
modify (\mgr -> mgr { activeUser = au' })
return au'
Jump to Line
Something went wrong with that request. Please try again.