module Snap.Snaplet.Auth.Handlers where
import Control.Applicative
import Control.Monad.CatchIO (throw)
import Control.Monad.State
import Data.ByteString (ByteString)
import Data.Lens.Lazy
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 Snap.Snaplet.Auth.AuthManager
import Snap.Snaplet.Auth.Types
import Snap.Snaplet.Session
import Snap.Snaplet.Session.Common
import Snap.Snaplet.Session.SecureCookie
createUser
:: Text
-> ByteString
-> Handler b (AuthManager b) AuthUser
createUser unm pwd = withBackend (\r -> liftIO $ buildAuthUser r unm pwd)
usernameExists
:: Text
-> Handler b (AuthManager b) Bool
usernameExists username = withBackend $
\r -> liftIO $ isJust <$> lookupByLogin r username
loginByUsername
:: ByteString
-> Password
-> Bool
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginByUsername _ (Encrypted _) _ =
error "Cannot login with encrypted password"
loginByUsername unm pwd rm = do
sk <- gets siteKey
cn <- gets rememberCookieName
rp <- gets rememberPeriod
withBackend $ loginByUsername' sk cn rp
where
loginByUsername' :: (IAuthBackend t)
=> Key -> ByteString -> Maybe Int -> t
-> Handler b (AuthManager b)
(Either AuthFailure AuthUser)
loginByUsername' sk cn rp r = do
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''
loginByRememberToken :: Handler b (AuthManager b) (Maybe AuthUser)
loginByRememberToken = withBackend $ \r -> do
sk <- gets siteKey
rc <- gets rememberCookieName
rp <- gets rememberPeriod
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 :: Handler b (AuthManager b) ()
logout = do
s <- gets session
withTop s $ withSession s removeSessionUserId
rc <- gets rememberCookieName
forgetRememberToken rc
modify (\mgr -> mgr { activeUser = Nothing } )
currentUser :: Handler b (AuthManager b) (Maybe AuthUser)
currentUser = cacheOrLookup $ withBackend $ \r -> do
s <- gets session
uid <- withTop s getSessionUserId
case uid of
Nothing -> loginByRememberToken
Just uid' -> liftIO $ lookupByUserId r uid'
isLoggedIn :: Handler b (AuthManager b) Bool
isLoggedIn = isJust `fmap` currentUser
saveUser :: AuthUser -> Handler b (AuthManager b) AuthUser
saveUser u = withBackend $ liftIO . flip save u
destroyUser :: AuthUser -> Handler b (AuthManager b) ()
destroyUser u = withBackend $ liftIO . flip destroy u
markAuthFail :: AuthUser -> Handler b (AuthManager b) AuthUser
markAuthFail u = withBackend $ \r -> do
lo <- gets lockout
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) ->
if userFailedLoginCount u' >= mx
then do
now <- liftIO getCurrentTime
let reopen = addUTCTime wait now
return $ u' { userLockedOutUntil = Just reopen }
else return u'
markAuthSuccess :: AuthUser -> Handler b (AuthManager b) AuthUser
markAuthSuccess u = withBackend $ \r -> do
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 }
checkPasswordAndLogin
:: AuthUser
-> 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'
forceLogin
:: AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forceLogin u = do
s <- gets session
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"
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 "/")
setSessionUserId :: UserId -> Handler b SessionManager ()
setSessionUserId (UserId t) = setInSession "__user_id" t
removeSessionUserId :: Handler b SessionManager ()
removeSessionUserId = deleteFromSession "__user_id"
getSessionUserId :: Handler b SessionManager (Maybe UserId)
getSessionUserId = do
uid <- getFromSession "__user_id"
return $ uid >>= return . UserId
authenticatePassword
:: AuthUser
-> 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
cacheOrLookup
:: Handler b (AuthManager b) (Maybe AuthUser)
-> 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'
registerUser
:: ByteString
-> ByteString
-> Handler b (AuthManager b) AuthUser
registerUser lf pf = do
l <- fmap decodeUtf8 `fmap` getParam lf
p <- getParam pf
case liftM2 (,) l p of
Nothing -> throw PasswordMissing
Just (lgn, pwd) -> do
createUser lgn pwd
loginUser
:: ByteString
-> ByteString
-> Maybe ByteString
-> (AuthFailure -> Handler b (AuthManager b) ())
-> Handler b (AuthManager b) ()
-> Handler b (AuthManager b) ()
loginUser unf pwdf remf loginFail loginSucc = do
username <- getParam unf
password <- getParam pwdf
remember <- maybe False (=="1") `fmap`
maybe (return Nothing) getParam remf
mMatch <- case password of
Nothing -> return $ Left PasswordMissing
Just password' -> do
case username of
Nothing -> return . Left $ AuthError "Username is missing"
Just username' -> do
loginByUsername username' (ClearText password') remember
either loginFail (const loginSucc) mMatch
logoutUser
:: Handler b (AuthManager b) ()
-> Handler b (AuthManager b) ()
logoutUser target = logout >> target
requireUser
:: Lens b (Snaplet (AuthManager b))
-> Handler b v a
-> Handler b v a
-> Handler b v a
requireUser auth bad good = do
loggedIn <- withTop auth isLoggedIn
if loggedIn then good else bad
withBackend
:: (forall r. (IAuthBackend r) => r -> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
withBackend f = join $ do
(AuthManager bckend _ _ _ _ _ _ _) <- get
return $ f bckend