{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE Rank2Types                #-}

------------------------------------------------------------------------------
-- | Pre-packaged Handlers that deal with form submissions and standard
--   use-cases involving authentication.

module Snap.Snaplet.Auth.Handlers where

------------------------------------------------------------------------------
import           Control.Applicative
import           Control.Monad (join, liftM, liftM2)
import           Control.Monad.State
import           Control.Monad.Trans.Maybe
import           Data.ByteString (ByteString)
import           Data.Maybe
import           Data.Serialize hiding (get)
import           Data.Time
import           Data.Text.Encoding (decodeUtf8)
import           Data.Text (Text, null, strip)
import           Prelude hiding (null)
import           Web.ClientSession
------------------------------------------------------------------------------
import           Snap.Core
import           Snap.Snaplet
import           Snap.Snaplet.Auth.AuthManager
import           Snap.Snaplet.Auth.Types
import           Snap.Snaplet.Session
------------------------------------------------------------------------------


                         ----------------------------
                         -- Higher level functions --
                         ----------------------------

------------------------------------------------------------------------------
-- | Create a new user from just a username and password
--
createUser :: Text              -- ^ Username
           -> ByteString        -- ^ Password
           -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
createUser :: forall b.
Text
-> ByteString
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
createUser Text
unm ByteString
pwd
  | Text -> Bool
null forall a b. (a -> b) -> a -> b
$ Text -> Text
strip Text
unm = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left AuthFailure
UsernameMissing
  | Bool
otherwise = do
     Bool
uExists <- forall b. Text -> Handler b (AuthManager b) Bool
usernameExists Text
unm
     if Bool
uExists then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left AuthFailure
DuplicateLogin
                else forall b v a.
(forall r. IAuthBackend r => r -> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
withBackend forall a b. (a -> b) -> a -> b
$ \r
r -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall r.
IAuthBackend r =>
r -> Text -> ByteString -> IO (Either AuthFailure AuthUser)
buildAuthUser r
r Text
unm ByteString
pwd


------------------------------------------------------------------------------
-- | Check whether a user with the given username exists.
--
usernameExists :: Text          -- ^ The username to be checked
               -> Handler b (AuthManager b) Bool
usernameExists :: forall b. Text -> Handler b (AuthManager b) Bool
usernameExists Text
username =
    forall b v a.
(forall r. IAuthBackend r => r -> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
withBackend forall a b. (a -> b) -> a -> b
$ \r
r -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r. IAuthBackend r => r -> Text -> IO (Maybe AuthUser)
lookupByLogin r
r Text
username


------------------------------------------------------------------------------
-- | Lookup a user by her username, check given password and perform login
--
loginByUsername :: Text             -- ^ Username/login for user
                -> Password         -- ^ Should be ClearText
                -> Bool             -- ^ Set remember token?
                -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginByUsername :: forall b.
Text
-> Password
-> Bool
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginByUsername Text
_ (Encrypted ByteString
_) Bool
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left AuthFailure
EncryptedPassword
loginByUsername Text
unm Password
pwd Bool
shouldRemember = do
    Key
sk <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall b. AuthManager b -> Key
siteKey
    ByteString
cn <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall b. AuthManager b -> ByteString
rememberCookieName
    Maybe ByteString
cd <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall b. AuthManager b -> Maybe ByteString
rememberCookieDomain
    Maybe Int
rp <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall b. AuthManager b -> Maybe Int
rememberPeriod
    forall b v a.
(forall r. IAuthBackend r => r -> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
withBackend forall a b. (a -> b) -> a -> b
$ forall t b.
IAuthBackend t =>
Key
-> ByteString
-> Maybe ByteString
-> Maybe Int
-> t
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginByUsername' Key
sk ByteString
cn Maybe ByteString
cd Maybe Int
rp

  where
    --------------------------------------------------------------------------
    loginByUsername' :: (IAuthBackend t) =>
                        Key
                     -> ByteString
                     -> Maybe ByteString
                     -> Maybe Int
                     -> t
                     -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
    loginByUsername' :: forall t b.
IAuthBackend t =>
Key
-> ByteString
-> Maybe ByteString
-> Maybe Int
-> t
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginByUsername' Key
sk ByteString
cn Maybe ByteString
cd Maybe Int
rp t
r =
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall r. IAuthBackend r => r -> Text -> IO (Maybe AuthUser)
lookupByLogin t
r Text
unm) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. a -> Either a b
Left AuthFailure
UserNotFound) AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
found

      where
        ----------------------------------------------------------------------
        found :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
found AuthUser
user = forall b.
AuthUser
-> Password
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
checkPasswordAndLogin AuthUser
user Password
pwd forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                     forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left) AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
matched

        ----------------------------------------------------------------------
        matched :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
matched AuthUser
user
            | Bool
shouldRemember = do
                  ByteString
token <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall b. AuthManager b -> RNG
randomNumberGenerator forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                           forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> RNG -> IO ByteString
randomToken Int
64

                  forall t (m :: * -> *).
(Serialize t, MonadSnap m) =>
Key -> ByteString -> Maybe ByteString -> Maybe Int -> t -> m ()
setRememberToken Key
sk ByteString
cn Maybe ByteString
cd Maybe Int
rp ByteString
token

                  let user' :: AuthUser
user' = AuthUser
user {
                                userRememberToken :: Maybe Text
userRememberToken = forall a. a -> Maybe a
Just (ByteString -> Text
decodeUtf8 ByteString
token)
                              }

                  forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
saveUser AuthUser
user'
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. b -> Either a b
Right AuthUser
user'

            | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right AuthUser
user


------------------------------------------------------------------------------
-- | Remember user from the remember token if possible and perform login
--
loginByRememberToken :: Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginByRememberToken :: forall b. Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginByRememberToken = forall b v a.
(forall r. IAuthBackend r => r -> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
withBackend forall a b. (a -> b) -> a -> b
$ \r
impl -> do
    Key
key         <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall b. AuthManager b -> Key
siteKey
    ByteString
cookieName_ <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall b. AuthManager b -> ByteString
rememberCookieName
    Maybe Int
period      <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall b. AuthManager b -> Maybe Int
rememberPeriod

    Maybe AuthUser
res <- forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
        ByteString
token <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall t (m :: * -> *).
(Serialize t, MonadSnap m) =>
Key -> ByteString -> Maybe Int -> m (Maybe t)
getRememberToken Key
key ByteString
cookieName_ Maybe Int
period
        forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall r. IAuthBackend r => r -> Text -> IO (Maybe AuthUser)
lookupByRememberToken r
impl forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 ByteString
token
    case Maybe AuthUser
res of
      Maybe AuthUser
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> AuthFailure
AuthError
                   String
"loginByRememberToken: no remember token"
      Just AuthUser
user -> do
        forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure ())
forceLogin AuthUser
user
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right AuthUser
user


------------------------------------------------------------------------------
-- | Logout the active user
--
logout :: Handler b (AuthManager b) ()
logout :: forall b. Handler b (AuthManager b) ()
logout = do
    SnapletLens b SessionManager
s <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall b. AuthManager b -> SnapletLens b SessionManager
session
    forall (m :: * -> * -> * -> *) b v' a v.
MonadSnaplet m =>
SnapletLens b v' -> m b v' a -> m b v a
withTop SnapletLens b SessionManager
s forall a b. (a -> b) -> a -> b
$ forall b v a.
SnapletLens b SessionManager -> Handler b v a -> Handler b v a
withSession SnapletLens b SessionManager
s forall b. Handler b SessionManager ()
removeSessionUserId
    ByteString
rc <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall b. AuthManager b -> ByteString
rememberCookieName
    Maybe ByteString
rd <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall b. AuthManager b -> Maybe ByteString
rememberCookieDomain
    forall (m :: * -> *).
MonadSnap m =>
ByteString -> Maybe ByteString -> m ()
expireSecureCookie ByteString
rc Maybe ByteString
rd
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \AuthManager b
mgr -> AuthManager b
mgr { activeUser :: Maybe AuthUser
activeUser = forall a. Maybe a
Nothing }


------------------------------------------------------------------------------
-- | Return the current user; trying to remember from cookie if possible.
--
currentUser :: Handler b (AuthManager b) (Maybe AuthUser)
currentUser :: forall b. Handler b (AuthManager b) (Maybe AuthUser)
currentUser = forall b.
Handler b (AuthManager b) (Maybe AuthUser)
-> Handler b (AuthManager b) (Maybe AuthUser)
cacheOrLookup forall a b. (a -> b) -> a -> b
$ forall b v a.
(forall r. IAuthBackend r => r -> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
withBackend forall a b. (a -> b) -> a -> b
$ \r
r -> do
    SnapletLens b SessionManager
s   <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall b. AuthManager b -> SnapletLens b SessionManager
session
    Maybe UserId
uid <- forall (m :: * -> * -> * -> *) b v' a v.
MonadSnaplet m =>
SnapletLens b v' -> m b v' a -> m b v a
withTop SnapletLens b SessionManager
s forall b. Handler b SessionManager (Maybe UserId)
getSessionUserId
    case Maybe UserId
uid of
      Maybe UserId
Nothing -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b. Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginByRememberToken
      Just UserId
uid' -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall r. IAuthBackend r => r -> UserId -> IO (Maybe AuthUser)
lookupByUserId r
r UserId
uid'


------------------------------------------------------------------------------
-- | Convenience wrapper around 'rememberUser' that returns a bool result
--
isLoggedIn :: Handler b (AuthManager b) Bool
isLoggedIn :: forall b. Handler b (AuthManager b) Bool
isLoggedIn = forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b. Handler b (AuthManager b) (Maybe AuthUser)
currentUser


------------------------------------------------------------------------------
-- | Create or update a given user
--
saveUser :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
saveUser :: forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
saveUser AuthUser
u
    | Text -> Bool
null forall a b. (a -> b) -> a -> b
$ AuthUser -> Text
userLogin AuthUser
u = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left AuthFailure
UsernameMissing
    | Bool
otherwise = forall b v a.
(forall r. IAuthBackend r => r -> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
withBackend forall a b. (a -> b) -> a -> b
$ \r
r -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall r.
IAuthBackend r =>
r -> AuthUser -> IO (Either AuthFailure AuthUser)
save r
r AuthUser
u


------------------------------------------------------------------------------
-- | Destroy the given user
--
destroyUser :: AuthUser -> Handler b (AuthManager b) ()
destroyUser :: forall b. AuthUser -> Handler b (AuthManager b) ()
destroyUser AuthUser
u = forall b v a.
(forall r. IAuthBackend r => r -> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
withBackend forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r. IAuthBackend r => r -> AuthUser -> IO ()
destroy AuthUser
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) (Either AuthFailure AuthUser)
markAuthFail :: forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
markAuthFail AuthUser
u = forall b v a.
(forall r. IAuthBackend r => r -> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
withBackend forall a b. (a -> b) -> a -> b
$ \r
r -> do
    Maybe (Int, NominalDiffTime)
lo <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall b. AuthManager b -> Maybe (Int, NominalDiffTime)
lockout
    forall {m :: * -> *}. Monad m => AuthUser -> m AuthUser
incFailCtr AuthUser
u forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *}.
MonadIO m =>
Maybe (Int, NominalDiffTime) -> AuthUser -> m AuthUser
checkLockout Maybe (Int, NominalDiffTime)
lo forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r.
IAuthBackend r =>
r -> AuthUser -> IO (Either AuthFailure AuthUser)
save r
r

  where
    --------------------------------------------------------------------------
    incFailCtr :: AuthUser -> m AuthUser
incFailCtr AuthUser
u' = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ AuthUser
u' {
                      userFailedLoginCount :: Int
userFailedLoginCount = AuthUser -> Int
userFailedLoginCount AuthUser
u' forall a. Num a => a -> a -> a
+ Int
1
                    }

    --------------------------------------------------------------------------
    checkLockout :: Maybe (Int, NominalDiffTime) -> AuthUser -> m AuthUser
checkLockout Maybe (Int, NominalDiffTime)
lo AuthUser
u' =
        case Maybe (Int, NominalDiffTime)
lo of
          Maybe (Int, NominalDiffTime)
Nothing          -> forall (m :: * -> *) a. Monad m => a -> m a
return AuthUser
u'
          Just (Int
mx, NominalDiffTime
wait)  ->
              if AuthUser -> Int
userFailedLoginCount AuthUser
u' forall a. Ord a => a -> a -> Bool
>= Int
mx
                then do
                  UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
                  let reopen :: UTCTime
reopen = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
wait UTCTime
now
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! AuthUser
u' { userLockedOutUntil :: Maybe UTCTime
userLockedOutUntil = forall a. a -> Maybe a
Just UTCTime
reopen }
                else forall (m :: * -> *) a. Monad m => a -> m a
return AuthUser
u'


------------------------------------------------------------------------------
-- | Mutate an 'AuthUser', marking successful authentication
--
-- This will save the user to the backend.
--
markAuthSuccess :: AuthUser
                -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
markAuthSuccess :: forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
markAuthSuccess AuthUser
u = forall b v a.
(forall r. IAuthBackend r => r -> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
withBackend forall a b. (a -> b) -> a -> b
$ \r
r ->
                        forall {m :: * -> *}. Monad m => AuthUser -> m AuthUser
incLoginCtr AuthUser
u     forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                        forall {m :: * -> *}. MonadSnap m => AuthUser -> m AuthUser
updateIp          forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                        forall {m :: * -> *}. MonadIO m => AuthUser -> m AuthUser
updateLoginTS     forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                        forall {m :: * -> *}. Monad m => AuthUser -> m AuthUser
resetFailCtr      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r.
IAuthBackend r =>
r -> AuthUser -> IO (Either AuthFailure AuthUser)
save r
r
  where
    --------------------------------------------------------------------------
    incLoginCtr :: AuthUser -> m AuthUser
incLoginCtr AuthUser
u' = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ AuthUser
u' { userLoginCount :: Int
userLoginCount = AuthUser -> Int
userLoginCount AuthUser
u' forall a. Num a => a -> a -> a
+ Int
1 }

    --------------------------------------------------------------------------
    updateIp :: AuthUser -> m AuthUser
updateIp AuthUser
u' = do
        ByteString
ip <- Request -> ByteString
rqClientAddr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadSnap m => m Request
getRequest
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ AuthUser
u' { userLastLoginIp :: Maybe ByteString
userLastLoginIp = AuthUser -> Maybe ByteString
userCurrentLoginIp AuthUser
u'
                    , userCurrentLoginIp :: Maybe ByteString
userCurrentLoginIp = forall a. a -> Maybe a
Just ByteString
ip }

    --------------------------------------------------------------------------
    updateLoginTS :: AuthUser -> m AuthUser
updateLoginTS AuthUser
u' = do
        UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
          AuthUser
u' { userCurrentLoginAt :: Maybe UTCTime
userCurrentLoginAt = forall a. a -> Maybe a
Just UTCTime
now
             , userLastLoginAt :: Maybe UTCTime
userLastLoginAt = AuthUser -> Maybe UTCTime
userCurrentLoginAt AuthUser
u' }

    --------------------------------------------------------------------------
    resetFailCtr :: AuthUser -> m AuthUser
resetFailCtr AuthUser
u' = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ AuthUser
u' { userFailedLoginCount :: Int
userFailedLoginCount = Int
0
                                  , userLockedOutUntil :: Maybe UTCTime
userLockedOutUntil = forall a. Maybe a
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 :: forall b.
AuthUser
-> Password
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
checkPasswordAndLogin AuthUser
u Password
pw =
    case AuthUser -> Maybe UTCTime
userLockedOutUntil AuthUser
u of
      Just UTCTime
x -> do
        UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
        if UTCTime
now forall a. Ord a => a -> a -> Bool
> UTCTime
x
          then forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
auth AuthUser
u
          else forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ UTCTime -> AuthFailure
LockedOut UTCTime
x
      Maybe UTCTime
Nothing -> forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
auth AuthUser
u

  where
    auth :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
    auth :: forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
auth AuthUser
user =
      case AuthUser -> Password -> Maybe AuthFailure
authenticatePassword AuthUser
user Password
pw of
        Just AuthFailure
e -> do
          forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
markAuthFail AuthUser
user
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left AuthFailure
e

        Maybe AuthFailure
Nothing -> do
          forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure ())
forceLogin AuthUser
user
          forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\AuthManager b
mgr -> AuthManager b
mgr { activeUser :: Maybe AuthUser
activeUser = forall a. a -> Maybe a
Just AuthUser
user })
          forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
markAuthSuccess AuthUser
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 ())
forceLogin :: forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure ())
forceLogin AuthUser
u = do
    SnapletLens b SessionManager
s <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall b. AuthManager b -> SnapletLens b SessionManager
session
    forall b v a.
SnapletLens b SessionManager -> Handler b v a -> Handler b v a
withSession SnapletLens b SessionManager
s forall a b. (a -> b) -> a -> b
$
        case AuthUser -> Maybe UserId
userId AuthUser
u of
          Just UserId
x -> do
            forall (m :: * -> * -> * -> *) b v' a v.
MonadSnaplet m =>
SnapletLens b v' -> m b v' a -> m b v a
withTop SnapletLens b SessionManager
s (forall b. UserId -> Handler b SessionManager ()
setSessionUserId UserId
x)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ()
          Maybe UserId
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
                     String -> AuthFailure
AuthError forall a b. (a -> b) -> a -> b
$ String
"forceLogin: Can't force the login of a user "
                                   forall a. [a] -> [a] -> [a]
++ String
"without userId"


                     ------------------------------------
                     -- Internal, non-exported helpers --
                     ------------------------------------


------------------------------------------------------------------------------
getRememberToken :: (Serialize t, MonadSnap m)
                 => Key
                 -> ByteString
                 -> Maybe Int
                 -> m (Maybe t)
getRememberToken :: forall t (m :: * -> *).
(Serialize t, MonadSnap m) =>
Key -> ByteString -> Maybe Int -> m (Maybe t)
getRememberToken Key
sk ByteString
rc Maybe Int
rp = forall (m :: * -> *) t.
(MonadSnap m, Serialize t) =>
ByteString -> Key -> Maybe Int -> m (Maybe t)
getSecureCookie ByteString
rc Key
sk Maybe Int
rp


------------------------------------------------------------------------------
setRememberToken :: (Serialize t, MonadSnap m)
                 => Key
                 -> ByteString
                 -> Maybe ByteString
                 -> Maybe Int
                 -> t
                 -> m ()
setRememberToken :: forall t (m :: * -> *).
(Serialize t, MonadSnap m) =>
Key -> ByteString -> Maybe ByteString -> Maybe Int -> t -> m ()
setRememberToken Key
sk ByteString
rc Maybe ByteString
rd Maybe Int
rp t
token = forall (m :: * -> *) t.
(MonadSnap m, Serialize t) =>
ByteString -> Maybe ByteString -> Key -> Maybe Int -> t -> m ()
setSecureCookie ByteString
rc Maybe ByteString
rd Key
sk Maybe Int
rp t
token


------------------------------------------------------------------------------
-- | Set the current user's 'UserId' in the active session
--
setSessionUserId :: UserId -> Handler b SessionManager ()
setSessionUserId :: forall b. UserId -> Handler b SessionManager ()
setSessionUserId (UserId Text
t) = forall b. Text -> Text -> Handler b SessionManager ()
setInSession Text
"__user_id" Text
t


------------------------------------------------------------------------------
-- | Remove 'UserId' from active session, effectively logging the user out.
removeSessionUserId :: Handler b SessionManager ()
removeSessionUserId :: forall b. Handler b SessionManager ()
removeSessionUserId = forall b. Text -> Handler b SessionManager ()
deleteFromSession Text
"__user_id"


------------------------------------------------------------------------------
-- | Get the current user's 'UserId' from the active session
--
getSessionUserId :: Handler b SessionManager (Maybe UserId)
getSessionUserId :: forall b. Handler b SessionManager (Maybe UserId)
getSessionUserId = do
  Maybe Text
uid <- forall b. Text -> Handler b SessionManager (Maybe Text)
getFromSession Text
"__user_id"
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Text -> UserId
UserId Maybe Text
uid


------------------------------------------------------------------------------
-- | 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 :: AuthUser -> Password -> Maybe AuthFailure
authenticatePassword AuthUser
u Password
pw = Maybe AuthFailure
auth
  where
    auth :: Maybe AuthFailure
auth    = case AuthUser -> Maybe Password
userPassword AuthUser
u of
                Maybe Password
Nothing -> forall a. a -> Maybe a
Just AuthFailure
PasswordMissing
                Just Password
upw -> Bool -> Maybe AuthFailure
check forall a b. (a -> b) -> a -> b
$ Password -> Password -> Bool
checkPassword Password
pw Password
upw

    check :: Bool -> Maybe AuthFailure
check Bool
b = if Bool
b then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just AuthFailure
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 :: forall b.
Handler b (AuthManager b) (Maybe AuthUser)
-> Handler b (AuthManager b) (Maybe AuthUser)
cacheOrLookup Handler b (AuthManager b) (Maybe AuthUser)
f = do
    Maybe AuthUser
au <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall b. AuthManager b -> Maybe AuthUser
activeUser
    if forall a. Maybe a -> Bool
isJust Maybe AuthUser
au
      then forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AuthUser
au
      else do
        Maybe AuthUser
au' <- Handler b (AuthManager b) (Maybe AuthUser)
f
        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\AuthManager b
mgr -> AuthManager b
mgr { activeUser :: Maybe AuthUser
activeUser = Maybe AuthUser
au' })
        forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AuthUser
au'


------------------------------------------------------------------------------
-- | Register a new user by specifying login and password 'Param' fields
--
registerUser
  :: ByteString            -- ^ Login field
  -> ByteString            -- ^ Password field
  -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
registerUser :: forall b.
ByteString
-> ByteString
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
registerUser ByteString
lf ByteString
pf = do
    Maybe Text
l <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
decodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadSnap m =>
ByteString -> m (Maybe ByteString)
getParam ByteString
lf
    Maybe ByteString
p <- forall (m :: * -> *).
MonadSnap m =>
ByteString -> m (Maybe ByteString)
getParam ByteString
pf

    let l' :: Either AuthFailure Text
l' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left AuthFailure
UsernameMissing) forall a b. b -> Either a b
Right Maybe Text
l
    let p' :: Either AuthFailure ByteString
p' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left AuthFailure
PasswordMissing) forall a b. b -> Either a b
Right Maybe ByteString
p

    -- In case of multiple AuthFailure, the first available one
    -- will be propagated.
    case forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) Either AuthFailure Text
l' Either AuthFailure ByteString
p' of
      Left AuthFailure
e           -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left AuthFailure
e
      Right (Text
lgn, ByteString
pwd) -> forall b.
Text
-> ByteString
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
createUser Text
lgn ByteString
pwd


------------------------------------------------------------------------------
-- | A 'MonadSnap' handler that processes a login form.
--
-- The request paremeters are passed to 'performLogin'
--
-- To make your users stay logged in for longer than the session replay
-- prevention timeout, you must pass a field name as the third parameter and
-- that field must be set to a value of \"1\" by the submitting form.  This
-- lets you use a user selectable check box.  Or if you want user remembering
-- always turned on, you can use a hidden form field.
loginUser
  :: ByteString
      -- ^ Username field
  -> ByteString
      -- ^ Password field
  -> Maybe ByteString
      -- ^ Remember field; Nothing if you want no remember function.
  -> (AuthFailure -> Handler b (AuthManager b) ())
      -- ^ Upon failure
  -> Handler b (AuthManager b) ()
      -- ^ Upon success
  -> Handler b (AuthManager b) ()
loginUser :: forall b.
ByteString
-> ByteString
-> Maybe ByteString
-> (AuthFailure -> Handler b (AuthManager b) ())
-> Handler b (AuthManager b) ()
-> Handler b (AuthManager b) ()
loginUser ByteString
unf ByteString
pwdf Maybe ByteString
remf AuthFailure -> Handler b (AuthManager b) ()
loginFail Handler b (AuthManager b) ()
loginSucc =
    forall b.
ByteString
-> ByteString
-> Maybe ByteString
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginUser' ByteString
unf ByteString
pwdf Maybe ByteString
remf forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either AuthFailure -> Handler b (AuthManager b) ()
loginFail (forall a b. a -> b -> a
const Handler b (AuthManager b) ()
loginSucc)


------------------------------------------------------------------------------
loginUser' :: ByteString
           -> ByteString
           -> Maybe ByteString
           -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginUser' :: forall b.
ByteString
-> ByteString
-> Maybe ByteString
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginUser' ByteString
unf ByteString
pwdf Maybe ByteString
remf = do
    Maybe ByteString
mbUsername <- forall (m :: * -> *).
MonadSnap m =>
ByteString -> m (Maybe ByteString)
getParam ByteString
unf
    Maybe ByteString
mbPassword <- forall (m :: * -> *).
MonadSnap m =>
ByteString -> m (Maybe ByteString)
getParam ByteString
pwdf
    Bool
remember   <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. a -> Maybe a -> a
fromMaybe Bool
False)
                    (forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$
                    do ByteString
field <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
remf
                       ByteString
value <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadSnap m =>
ByteString -> m (Maybe ByteString)
getParam ByteString
field
                       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString
value forall a. Eq a => a -> a -> Bool
== ByteString
"1" Bool -> Bool -> Bool
|| ByteString
value forall a. Eq a => a -> a -> Bool
== ByteString
"on")

    case Maybe ByteString
mbUsername of
      Maybe ByteString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left AuthFailure
UsernameMissing
      Just ByteString
u -> case Maybe ByteString
mbPassword of
        Maybe ByteString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left AuthFailure
PasswordMissing
        Just ByteString
p -> forall b.
Text
-> Password
-> Bool
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginByUsername (ByteString -> Text
decodeUtf8 ByteString
u) (ByteString -> Password
ClearText ByteString
p) Bool
remember


------------------------------------------------------------------------------
-- | Simple handler to log the user out. Deletes user from session.
--
logoutUser :: Handler b (AuthManager b) ()   -- ^ What to do after logging out
           -> Handler b (AuthManager b) ()
logoutUser :: forall b.
Handler b (AuthManager b) () -> Handler b (AuthManager b) ()
logoutUser Handler b (AuthManager b) ()
target = forall b. Handler b (AuthManager b) ()
logout forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handler b (AuthManager b) ()
target


------------------------------------------------------------------------------
-- | Require that an authenticated 'AuthUser' is present in the current
-- session.
--
-- This function has no DB cost - only checks to see if a user_id is present
-- in the current session.
--
requireUser :: SnapletLens b (AuthManager b)
                -- ^ Lens reference to an "AuthManager"
            -> Handler b v a
                -- ^ Do this if no authenticated user is present.
            -> Handler b v a
                -- ^ Do this if an authenticated user is present.
            -> Handler b v a
requireUser :: forall b v a.
SnapletLens b (AuthManager b)
-> Handler b v a -> Handler b v a -> Handler b v a
requireUser SnapletLens b (AuthManager b)
auth Handler b v a
bad Handler b v a
good = do
    Bool
loggedIn <- forall (m :: * -> * -> * -> *) b v' a v.
MonadSnaplet m =>
SnapletLens b v' -> m b v' a -> m b v a
withTop SnapletLens b (AuthManager b)
auth forall b. Handler b (AuthManager b) Bool
isLoggedIn
    if Bool
loggedIn then Handler b v a
good else Handler b v a
bad


------------------------------------------------------------------------------
-- | Run a function on the backend, and return the result.
--
-- This uses an existential type so that the backend type doesn't
-- 'escape' AuthManager.  The reason that the type is Handler b
-- (AuthManager v) a and not a is because anything that uses the
-- backend will return an IO something, which you can liftIO, or a
-- Handler b (AuthManager v) a if it uses other handler things.
--
withBackend ::
    (forall r. (IAuthBackend r) => r -> Handler b (AuthManager v) a)
      -- ^ The function to run with the handler.
  -> Handler b (AuthManager v) a
withBackend :: forall b v a.
(forall r. IAuthBackend r => r -> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
withBackend forall r. IAuthBackend r => r -> Handler b (AuthManager v) a
f = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ do
  (AuthManager r
backend_ SnapletLens v SessionManager
_ Maybe AuthUser
_ Int
_ ByteString
_ Maybe ByteString
_ Maybe Int
_ Key
_ Maybe (Int, NominalDiffTime)
_ RNG
_) <- forall s (m :: * -> *). MonadState s m => m s
get
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall r. IAuthBackend r => r -> Handler b (AuthManager v) a
f r
backend_


------------------------------------------------------------------------------
-- | This function generates a random password reset token and stores it in
-- the database for the user.  Call this function when a user forgets their
-- password.  Then use the token to autogenerate a link that the user can
-- visit to reset their password.  This function also sets a timestamp so the
-- reset token can be expired.
setPasswordResetToken :: Text -> Handler b (AuthManager b) (Maybe Text)
setPasswordResetToken :: forall b. Text -> Handler b (AuthManager b) (Maybe Text)
setPasswordResetToken Text
login = do
  ByteString
tokBS <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> RNG -> IO ByteString
randomToken Int
40 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall b. AuthManager b -> RNG
randomNumberGenerator
  let token :: Text
token = ByteString -> Text
decodeUtf8 ByteString
tokBS
  UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  Bool
success <- forall v.
Text
-> Maybe Text -> Maybe UTCTime -> Handler v (AuthManager v) Bool
modPasswordResetToken Text
login (forall a. a -> Maybe a
Just Text
token) (forall a. a -> Maybe a
Just UTCTime
now)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
success then forall a. a -> Maybe a
Just Text
token else forall a. Maybe a
Nothing


------------------------------------------------------------------------------
-- | Clears a user's password reset token.  Call this when the user
-- successfully changes their password to ensure that the password reset link
-- cannot be used again.
clearPasswordResetToken :: Text -> Handler b (AuthManager b) Bool
clearPasswordResetToken :: forall b. Text -> Handler b (AuthManager b) Bool
clearPasswordResetToken Text
login = forall v.
Text
-> Maybe Text -> Maybe UTCTime -> Handler v (AuthManager v) Bool
modPasswordResetToken Text
login forall a. Maybe a
Nothing forall a. Maybe a
Nothing


------------------------------------------------------------------------------
-- | Helper function used for setting and clearing the password reset token
-- and associated timestamp.
modPasswordResetToken :: Text
                      -> Maybe Text
                      -> Maybe UTCTime
                      -> Handler v (AuthManager v) Bool
modPasswordResetToken :: forall v.
Text
-> Maybe Text -> Maybe UTCTime -> Handler v (AuthManager v) Bool
modPasswordResetToken Text
login Maybe Text
token Maybe UTCTime
timestamp = do
  Maybe ()
res <- forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
      AuthUser
u <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall b v a.
(forall r. IAuthBackend r => r -> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
withBackend forall a b. (a -> b) -> a -> b
$ \r
b -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall r. IAuthBackend r => r -> Text -> IO (Maybe AuthUser)
lookupByLogin r
b Text
login
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
saveUser forall a b. (a -> b) -> a -> b
$ AuthUser
u
        { userResetToken :: Maybe Text
userResetToken = Maybe Text
token
        , userResetRequestedAt :: Maybe UTCTime
userResetRequestedAt = Maybe UTCTime
timestamp
        }
      forall (m :: * -> *) a. Monad m => a -> m a
return ()
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\()
_ -> Bool
True) Maybe ()
res