module Snap.Snaplet.Auth.Handlers where
import Control.Applicative
import Control.Monad.CatchIO (throw)
import Control.Monad.State
import Control.Monad.Trans.Error
import Control.Monad.Trans.Maybe
import Data.ByteString (ByteString)
import Data.Lens.Lazy
import Data.Maybe (fromMaybe, 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
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 shouldRemember = 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 =
liftIO (lookupByLogin r $ decodeUtf8 unm) >>=
maybe (return $! Left UserNotFound) found
where
found user = checkPasswordAndLogin user pwd >>=
either (return . Left) matched
matched user
| shouldRemember = do
token <- gets randomNumberGenerator >>=
liftIO . randomToken 64
setRememberToken sk cn rp token
let user' = user {
userRememberToken = Just (decodeUtf8 token)
}
saveUser user'
return $! Right user'
| otherwise = return $ Right user
loginByRememberToken :: Handler b (AuthManager b) (Maybe AuthUser)
loginByRememberToken = withBackend $ \impl -> do
key <- gets siteKey
cookieName_ <- gets rememberCookieName
period <- gets rememberPeriod
runMaybeT $ do
token <- MaybeT $ getRememberToken key cookieName_ period
user <- MaybeT $ liftIO $ lookupByRememberToken impl
$ decodeUtf8 token
lift $ forceLogin user
return user
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 <$> 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 ->
incLoginCtr u >>=
updateIp >>=
updateLoginTS >>=
resetFailCtr >>=
liftIO . save r
where
incLoginCtr u' = return $ u' { userLoginCount = userLoginCount u' + 1 }
updateIp u' = do
ip <- rqRemoteAddr <$> 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 <$> getParam lf
p <- getParam pf
case liftM2 (,) l p of
Nothing -> throw PasswordMissing
Just (lgn, pwd) -> 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 =
runErrorT go >>= either loginFail (const loginSucc)
where
go = do
mbUsername <- getParam unf
mbPassword <- getParam pwdf
remember <- (runMaybeT $ do
field <- MaybeT $ return remf
value <- MaybeT $ getParam field
return $ value == "1"
) >>= return . fromMaybe False
password <- maybe (throwError PasswordMissing) return mbPassword
username <- maybe (fail "Username is missing") return mbUsername
ErrorT $ loginByUsername username (ClearText password) remember
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 backend_ _ _ _ _ _ _ _ _) <- get
return $ f backend_