{-# 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 (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Text
strip Text
unm = Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a. a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
 -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthFailure -> Either AuthFailure AuthUser
forall a b. a -> Either a b
Left AuthFailure
UsernameMissing
  | Bool
otherwise = do
     Bool
uExists <- Text -> Handler b (AuthManager b) Bool
forall b. Text -> Handler b (AuthManager b) Bool
usernameExists Text
unm
     if Bool
uExists then Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a. a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
 -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthFailure -> Either AuthFailure AuthUser
forall a b. a -> Either a b
Left AuthFailure
DuplicateLogin
                else (forall r.
 IAuthBackend r =>
 r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
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 b) (Either AuthFailure AuthUser))
 -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> (forall r.
    IAuthBackend r =>
    r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ \r
r -> IO (Either AuthFailure AuthUser)
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a. IO a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either AuthFailure AuthUser)
 -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> IO (Either AuthFailure AuthUser)
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ r -> Text -> ByteString -> IO (Either AuthFailure AuthUser)
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 r. IAuthBackend r => r -> Handler b (AuthManager b) Bool)
-> Handler b (AuthManager b) Bool
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 b) Bool)
 -> Handler b (AuthManager b) Bool)
-> (forall r.
    IAuthBackend r =>
    r -> Handler b (AuthManager b) Bool)
-> Handler b (AuthManager b) Bool
forall a b. (a -> b) -> a -> b
$ \r
r -> IO Bool -> Handler b (AuthManager b) Bool
forall a. IO a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Handler b (AuthManager b) Bool)
-> IO Bool -> Handler b (AuthManager b) Bool
forall a b. (a -> b) -> a -> b
$ Maybe AuthUser -> Bool
forall a. Maybe a -> Bool
isJust (Maybe AuthUser -> Bool) -> IO (Maybe AuthUser) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> r -> Text -> IO (Maybe AuthUser)
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
_ = Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a. a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
 -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthFailure -> Either AuthFailure AuthUser
forall a b. a -> Either a b
Left AuthFailure
EncryptedPassword
loginByUsername Text
unm Password
pwd Bool
shouldRemember = do
    Key
sk <- (AuthManager b -> Key) -> Handler b (AuthManager b) Key
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> Key
forall b. AuthManager b -> Key
siteKey
    ByteString
cn <- (AuthManager b -> ByteString)
-> Handler b (AuthManager b) ByteString
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> ByteString
forall b. AuthManager b -> ByteString
rememberCookieName
    Maybe ByteString
cd <- (AuthManager b -> Maybe ByteString)
-> Handler b (AuthManager b) (Maybe ByteString)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> Maybe ByteString
forall b. AuthManager b -> Maybe ByteString
rememberCookieDomain
    Maybe Int
rp <- (AuthManager b -> Maybe Int)
-> Handler b (AuthManager b) (Maybe Int)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> Maybe Int
forall b. AuthManager b -> Maybe Int
rememberPeriod
    (forall r.
 IAuthBackend r =>
 r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
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 b) (Either AuthFailure AuthUser))
 -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> (forall r.
    IAuthBackend r =>
    r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ Key
-> ByteString
-> Maybe ByteString
-> Maybe Int
-> r
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
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 =
        IO (Maybe AuthUser) -> Handler b (AuthManager b) (Maybe AuthUser)
forall a. IO a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (t -> Text -> IO (Maybe AuthUser)
forall r. IAuthBackend r => r -> Text -> IO (Maybe AuthUser)
lookupByLogin t
r Text
unm) Handler b (AuthManager b) (Maybe AuthUser)
-> (Maybe AuthUser
    -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b.
Handler b (AuthManager b) a
-> (a -> Handler b (AuthManager b) b)
-> Handler b (AuthManager b) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        Handler b (AuthManager b) (Either AuthFailure AuthUser)
-> (AuthUser
    -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Maybe AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a. a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
 -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$! AuthFailure -> Either AuthFailure AuthUser
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 = AuthUser
-> Password
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b.
AuthUser
-> Password
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
checkPasswordAndLogin AuthUser
user Password
pwd Handler b (AuthManager b) (Either AuthFailure AuthUser)
-> (Either AuthFailure AuthUser
    -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b.
Handler b (AuthManager b) a
-> (a -> Handler b (AuthManager b) b)
-> Handler b (AuthManager b) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                     (AuthFailure
 -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> (AuthUser
    -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a. a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
 -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> (AuthFailure -> Either AuthFailure AuthUser)
-> AuthFailure
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthFailure -> Either AuthFailure AuthUser
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 <- (AuthManager b -> RNG) -> Handler b (AuthManager b) RNG
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> RNG
forall b. AuthManager b -> RNG
randomNumberGenerator Handler b (AuthManager b) RNG
-> (RNG -> Handler b (AuthManager b) ByteString)
-> Handler b (AuthManager b) ByteString
forall a b.
Handler b (AuthManager b) a
-> (a -> Handler b (AuthManager b) b)
-> Handler b (AuthManager b) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                           IO ByteString -> Handler b (AuthManager b) ByteString
forall a. IO a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> Handler b (AuthManager b) ByteString)
-> (RNG -> IO ByteString)
-> RNG
-> Handler b (AuthManager b) ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> RNG -> IO ByteString
randomToken Int
64

                  Key
-> ByteString
-> Maybe ByteString
-> Maybe Int
-> ByteString
-> Handler b (AuthManager b) ()
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 = Text -> Maybe Text
forall a. a -> Maybe a
Just (ByteString -> Text
decodeUtf8 ByteString
token)
                              }

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

            | Bool
otherwise = Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a. a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
 -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthUser -> Either AuthFailure AuthUser
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 r.
 IAuthBackend r =>
 r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
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 b) (Either AuthFailure AuthUser))
 -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> (forall r.
    IAuthBackend r =>
    r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ \r
impl -> do
    Key
key         <- (AuthManager b -> Key) -> Handler b (AuthManager b) Key
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> Key
forall b. AuthManager b -> Key
siteKey
    ByteString
cookieName_ <- (AuthManager b -> ByteString)
-> Handler b (AuthManager b) ByteString
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> ByteString
forall b. AuthManager b -> ByteString
rememberCookieName
    Maybe Int
period      <- (AuthManager b -> Maybe Int)
-> Handler b (AuthManager b) (Maybe Int)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> Maybe Int
forall b. AuthManager b -> Maybe Int
rememberPeriod

    Maybe AuthUser
res <- MaybeT (Handler b (AuthManager b)) AuthUser
-> Handler b (AuthManager b) (Maybe AuthUser)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (Handler b (AuthManager b)) AuthUser
 -> Handler b (AuthManager b) (Maybe AuthUser))
-> MaybeT (Handler b (AuthManager b)) AuthUser
-> Handler b (AuthManager b) (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ do
        ByteString
token <- Handler b (AuthManager b) (Maybe ByteString)
-> MaybeT (Handler b (AuthManager b)) ByteString
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Handler b (AuthManager b) (Maybe ByteString)
 -> MaybeT (Handler b (AuthManager b)) ByteString)
-> Handler b (AuthManager b) (Maybe ByteString)
-> MaybeT (Handler b (AuthManager b)) ByteString
forall a b. (a -> b) -> a -> b
$ Key
-> ByteString
-> Maybe Int
-> Handler b (AuthManager b) (Maybe ByteString)
forall t (m :: * -> *).
(Serialize t, MonadSnap m) =>
Key -> ByteString -> Maybe Int -> m (Maybe t)
getRememberToken Key
key ByteString
cookieName_ Maybe Int
period
        Handler b (AuthManager b) (Maybe AuthUser)
-> MaybeT (Handler b (AuthManager b)) AuthUser
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Handler b (AuthManager b) (Maybe AuthUser)
 -> MaybeT (Handler b (AuthManager b)) AuthUser)
-> Handler b (AuthManager b) (Maybe AuthUser)
-> MaybeT (Handler b (AuthManager b)) AuthUser
forall a b. (a -> b) -> a -> b
$ IO (Maybe AuthUser) -> Handler b (AuthManager b) (Maybe AuthUser)
forall a. IO a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe AuthUser) -> Handler b (AuthManager b) (Maybe AuthUser))
-> IO (Maybe AuthUser)
-> Handler b (AuthManager b) (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ r -> Text -> IO (Maybe AuthUser)
forall r. IAuthBackend r => r -> Text -> IO (Maybe AuthUser)
lookupByRememberToken r
impl (Text -> IO (Maybe AuthUser)) -> Text -> IO (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 ByteString
token
    case Maybe AuthUser
res of
      Maybe AuthUser
Nothing -> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a. a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
 -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthFailure -> Either AuthFailure AuthUser
forall a b. a -> Either a b
Left (AuthFailure -> Either AuthFailure AuthUser)
-> AuthFailure -> Either AuthFailure AuthUser
forall a b. (a -> b) -> a -> b
$ String -> AuthFailure
AuthError
                   String
"loginByRememberToken: no remember token"
      Just AuthUser
user -> do
        AuthUser -> Handler b (AuthManager b) (Either AuthFailure ())
forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure ())
forceLogin AuthUser
user
        Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a. a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
 -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthUser -> Either AuthFailure AuthUser
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 <- (AuthManager b -> SnapletLens b SessionManager)
-> Handler b (AuthManager b) (SnapletLens b SessionManager)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> SnapletLens b SessionManager
forall b. AuthManager b -> SnapletLens b SessionManager
session
    SnapletLens b SessionManager
-> Handler b SessionManager () -> Handler b (AuthManager b) ()
forall b v' a v.
SnapletLens b v' -> Handler b v' a -> Handler b v a
forall (m :: * -> * -> * -> *) b v' a v.
MonadSnaplet m =>
SnapletLens b v' -> m b v' a -> m b v a
withTop SnapletLens b SessionManager
s (Handler b SessionManager () -> Handler b (AuthManager b) ())
-> Handler b SessionManager () -> Handler b (AuthManager b) ()
forall a b. (a -> b) -> a -> b
$ SnapletLens b SessionManager
-> Handler b SessionManager () -> Handler b SessionManager ()
forall b v a.
SnapletLens b SessionManager -> Handler b v a -> Handler b v a
withSession SnapletLens b SessionManager
s Handler b SessionManager ()
forall b. Handler b SessionManager ()
removeSessionUserId
    ByteString
rc <- (AuthManager b -> ByteString)
-> Handler b (AuthManager b) ByteString
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> ByteString
forall b. AuthManager b -> ByteString
rememberCookieName
    Maybe ByteString
rd <- (AuthManager b -> Maybe ByteString)
-> Handler b (AuthManager b) (Maybe ByteString)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> Maybe ByteString
forall b. AuthManager b -> Maybe ByteString
rememberCookieDomain
    ByteString -> Maybe ByteString -> Handler b (AuthManager b) ()
forall (m :: * -> *).
MonadSnap m =>
ByteString -> Maybe ByteString -> m ()
expireSecureCookie ByteString
rc Maybe ByteString
rd
    (AuthManager b -> AuthManager b) -> Handler b (AuthManager b) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((AuthManager b -> AuthManager b) -> Handler b (AuthManager b) ())
-> (AuthManager b -> AuthManager b) -> Handler b (AuthManager b) ()
forall a b. (a -> b) -> a -> b
$ \AuthManager b
mgr -> AuthManager b
mgr { activeUser :: Maybe AuthUser
activeUser = Maybe AuthUser
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 = Handler b (AuthManager b) (Maybe AuthUser)
-> Handler b (AuthManager b) (Maybe AuthUser)
forall b.
Handler b (AuthManager b) (Maybe AuthUser)
-> Handler b (AuthManager b) (Maybe AuthUser)
cacheOrLookup (Handler b (AuthManager b) (Maybe AuthUser)
 -> Handler b (AuthManager b) (Maybe AuthUser))
-> Handler b (AuthManager b) (Maybe AuthUser)
-> Handler b (AuthManager b) (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ (forall r.
 IAuthBackend r =>
 r -> Handler b (AuthManager b) (Maybe AuthUser))
-> Handler b (AuthManager b) (Maybe AuthUser)
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 b) (Maybe AuthUser))
 -> Handler b (AuthManager b) (Maybe AuthUser))
-> (forall r.
    IAuthBackend r =>
    r -> Handler b (AuthManager b) (Maybe AuthUser))
-> Handler b (AuthManager b) (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ \r
r -> do
    SnapletLens b SessionManager
s   <- (AuthManager b -> SnapletLens b SessionManager)
-> Handler b (AuthManager b) (SnapletLens b SessionManager)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> SnapletLens b SessionManager
forall b. AuthManager b -> SnapletLens b SessionManager
session
    Maybe UserId
uid <- SnapletLens b SessionManager
-> Handler b SessionManager (Maybe UserId)
-> Handler b (AuthManager b) (Maybe UserId)
forall b v' a v.
SnapletLens b v' -> Handler b v' a -> Handler b v a
forall (m :: * -> * -> * -> *) b v' a v.
MonadSnaplet m =>
SnapletLens b v' -> m b v' a -> m b v a
withTop SnapletLens b SessionManager
s Handler b SessionManager (Maybe UserId)
forall b. Handler b SessionManager (Maybe UserId)
getSessionUserId
    case Maybe UserId
uid of
      Maybe UserId
Nothing -> (AuthFailure -> Maybe AuthUser)
-> (AuthUser -> Maybe AuthUser)
-> Either AuthFailure AuthUser
-> Maybe AuthUser
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe AuthUser -> AuthFailure -> Maybe AuthUser
forall a b. a -> b -> a
const Maybe AuthUser
forall a. Maybe a
Nothing) AuthUser -> Maybe AuthUser
forall a. a -> Maybe a
Just (Either AuthFailure AuthUser -> Maybe AuthUser)
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
-> Handler b (AuthManager b) (Maybe AuthUser)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b. Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginByRememberToken
      Just UserId
uid' -> IO (Maybe AuthUser) -> Handler b (AuthManager b) (Maybe AuthUser)
forall a. IO a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe AuthUser) -> Handler b (AuthManager b) (Maybe AuthUser))
-> IO (Maybe AuthUser)
-> Handler b (AuthManager b) (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ r -> UserId -> IO (Maybe AuthUser)
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 = Maybe AuthUser -> Bool
forall a. Maybe a -> Bool
isJust (Maybe AuthUser -> Bool)
-> Handler b (AuthManager b) (Maybe AuthUser)
-> Handler b (AuthManager b) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handler b (AuthManager b) (Maybe AuthUser)
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 (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ AuthUser -> Text
userLogin AuthUser
u = Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a. a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
 -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthFailure -> Either AuthFailure AuthUser
forall a b. a -> Either a b
Left AuthFailure
UsernameMissing
    | Bool
otherwise = (forall r.
 IAuthBackend r =>
 r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
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 b) (Either AuthFailure AuthUser))
 -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> (forall r.
    IAuthBackend r =>
    r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ \r
r -> IO (Either AuthFailure AuthUser)
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a. IO a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either AuthFailure AuthUser)
 -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> IO (Either AuthFailure AuthUser)
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ r -> AuthUser -> IO (Either AuthFailure AuthUser)
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 r. IAuthBackend r => r -> Handler b (AuthManager b) ())
-> Handler b (AuthManager b) ()
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 b) ())
 -> Handler b (AuthManager b) ())
-> (forall r. IAuthBackend r => r -> Handler b (AuthManager b) ())
-> Handler b (AuthManager b) ()
forall a b. (a -> b) -> a -> b
$ IO () -> Handler b (AuthManager b) ()
forall a. IO a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Handler b (AuthManager b) ())
-> (r -> IO ()) -> r -> Handler b (AuthManager b) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r -> AuthUser -> IO ()) -> AuthUser -> r -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip r -> AuthUser -> IO ()
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 r.
 IAuthBackend r =>
 r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
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 b) (Either AuthFailure AuthUser))
 -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> (forall r.
    IAuthBackend r =>
    r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ \r
r -> do
    Maybe (Int, NominalDiffTime)
lo <- (AuthManager b -> Maybe (Int, NominalDiffTime))
-> Handler b (AuthManager b) (Maybe (Int, NominalDiffTime))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> Maybe (Int, NominalDiffTime)
forall b. AuthManager b -> Maybe (Int, NominalDiffTime)
lockout
    AuthUser -> Handler b (AuthManager b) AuthUser
forall {m :: * -> *}. Monad m => AuthUser -> m AuthUser
incFailCtr AuthUser
u Handler b (AuthManager b) AuthUser
-> (AuthUser -> Handler b (AuthManager b) AuthUser)
-> Handler b (AuthManager b) AuthUser
forall a b.
Handler b (AuthManager b) a
-> (a -> Handler b (AuthManager b) b)
-> Handler b (AuthManager b) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Int, NominalDiffTime)
-> AuthUser -> Handler b (AuthManager b) AuthUser
forall {m :: * -> *}.
MonadIO m =>
Maybe (Int, NominalDiffTime) -> AuthUser -> m AuthUser
checkLockout Maybe (Int, NominalDiffTime)
lo Handler b (AuthManager b) AuthUser
-> (AuthUser
    -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b.
Handler b (AuthManager b) a
-> (a -> Handler b (AuthManager b) b)
-> Handler b (AuthManager b) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Either AuthFailure AuthUser)
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a. IO a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either AuthFailure AuthUser)
 -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> (AuthUser -> IO (Either AuthFailure AuthUser))
-> AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> AuthUser -> IO (Either AuthFailure AuthUser)
forall r.
IAuthBackend r =>
r -> AuthUser -> IO (Either AuthFailure AuthUser)
save r
r

  where
    --------------------------------------------------------------------------
    incFailCtr :: AuthUser -> m AuthUser
incFailCtr AuthUser
u' = AuthUser -> m AuthUser
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (AuthUser -> m AuthUser) -> AuthUser -> m AuthUser
forall a b. (a -> b) -> a -> b
$ AuthUser
u' {
                      userFailedLoginCount :: Int
userFailedLoginCount = AuthUser -> Int
userFailedLoginCount AuthUser
u' Int -> Int -> Int
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          -> AuthUser -> m AuthUser
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return AuthUser
u'
          Just (Int
mx, NominalDiffTime
wait)  ->
              if AuthUser -> Int
userFailedLoginCount AuthUser
u' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
mx
                then do
                  UTCTime
now <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
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
                  AuthUser -> m AuthUser
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (AuthUser -> m AuthUser) -> AuthUser -> m AuthUser
forall a b. (a -> b) -> a -> b
$! AuthUser
u' { userLockedOutUntil :: Maybe UTCTime
userLockedOutUntil = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
reopen }
                else AuthUser -> m AuthUser
forall a. a -> m a
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 r.
 IAuthBackend r =>
 r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
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 b) (Either AuthFailure AuthUser))
 -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> (forall r.
    IAuthBackend r =>
    r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ \r
r ->
                        AuthUser -> Handler b (AuthManager b) AuthUser
forall {m :: * -> *}. Monad m => AuthUser -> m AuthUser
incLoginCtr AuthUser
u     Handler b (AuthManager b) AuthUser
-> (AuthUser -> Handler b (AuthManager b) AuthUser)
-> Handler b (AuthManager b) AuthUser
forall a b.
Handler b (AuthManager b) a
-> (a -> Handler b (AuthManager b) b)
-> Handler b (AuthManager b) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                        AuthUser -> Handler b (AuthManager b) AuthUser
forall {m :: * -> *}. MonadSnap m => AuthUser -> m AuthUser
updateIp          Handler b (AuthManager b) AuthUser
-> (AuthUser -> Handler b (AuthManager b) AuthUser)
-> Handler b (AuthManager b) AuthUser
forall a b.
Handler b (AuthManager b) a
-> (a -> Handler b (AuthManager b) b)
-> Handler b (AuthManager b) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                        AuthUser -> Handler b (AuthManager b) AuthUser
forall {m :: * -> *}. MonadIO m => AuthUser -> m AuthUser
updateLoginTS     Handler b (AuthManager b) AuthUser
-> (AuthUser -> Handler b (AuthManager b) AuthUser)
-> Handler b (AuthManager b) AuthUser
forall a b.
Handler b (AuthManager b) a
-> (a -> Handler b (AuthManager b) b)
-> Handler b (AuthManager b) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                        AuthUser -> Handler b (AuthManager b) AuthUser
forall {m :: * -> *}. Monad m => AuthUser -> m AuthUser
resetFailCtr      Handler b (AuthManager b) AuthUser
-> (AuthUser
    -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b.
Handler b (AuthManager b) a
-> (a -> Handler b (AuthManager b) b)
-> Handler b (AuthManager b) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                        IO (Either AuthFailure AuthUser)
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a. IO a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either AuthFailure AuthUser)
 -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> (AuthUser -> IO (Either AuthFailure AuthUser))
-> AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> AuthUser -> IO (Either AuthFailure AuthUser)
forall r.
IAuthBackend r =>
r -> AuthUser -> IO (Either AuthFailure AuthUser)
save r
r
  where
    --------------------------------------------------------------------------
    incLoginCtr :: AuthUser -> m AuthUser
incLoginCtr AuthUser
u' = AuthUser -> m AuthUser
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (AuthUser -> m AuthUser) -> AuthUser -> m AuthUser
forall a b. (a -> b) -> a -> b
$ AuthUser
u' { userLoginCount :: Int
userLoginCount = AuthUser -> Int
userLoginCount AuthUser
u' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 }

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

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

        Maybe AuthFailure
Nothing -> do
          AuthUser -> Handler b (AuthManager b) (Either AuthFailure ())
forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure ())
forceLogin AuthUser
user
          (AuthManager b -> AuthManager b) -> Handler b (AuthManager b) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\AuthManager b
mgr -> AuthManager b
mgr { activeUser :: Maybe AuthUser
activeUser = AuthUser -> Maybe AuthUser
forall a. a -> Maybe a
Just AuthUser
user })
          AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
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 <- (AuthManager b -> SnapletLens b SessionManager)
-> Handler b (AuthManager b) (SnapletLens b SessionManager)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> SnapletLens b SessionManager
forall b. AuthManager b -> SnapletLens b SessionManager
session
    SnapletLens b SessionManager
-> Handler b (AuthManager b) (Either AuthFailure ())
-> Handler b (AuthManager b) (Either AuthFailure ())
forall b v a.
SnapletLens b SessionManager -> Handler b v a -> Handler b v a
withSession SnapletLens b SessionManager
s (Handler b (AuthManager b) (Either AuthFailure ())
 -> Handler b (AuthManager b) (Either AuthFailure ()))
-> Handler b (AuthManager b) (Either AuthFailure ())
-> Handler b (AuthManager b) (Either AuthFailure ())
forall a b. (a -> b) -> a -> b
$
        case AuthUser -> Maybe UserId
userId AuthUser
u of
          Just UserId
x -> do
            SnapletLens b SessionManager
-> Handler b SessionManager () -> Handler b (AuthManager b) ()
forall b v' a v.
SnapletLens b v' -> Handler b v' a -> Handler b v a
forall (m :: * -> * -> * -> *) b v' a v.
MonadSnaplet m =>
SnapletLens b v' -> m b v' a -> m b v a
withTop SnapletLens b SessionManager
s (UserId -> Handler b SessionManager ()
forall b. UserId -> Handler b SessionManager ()
setSessionUserId UserId
x)
            Either AuthFailure ()
-> Handler b (AuthManager b) (Either AuthFailure ())
forall a. a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure ()
 -> Handler b (AuthManager b) (Either AuthFailure ()))
-> Either AuthFailure ()
-> Handler b (AuthManager b) (Either AuthFailure ())
forall a b. (a -> b) -> a -> b
$ () -> Either AuthFailure ()
forall a b. b -> Either a b
Right ()
          Maybe UserId
Nothing -> Either AuthFailure ()
-> Handler b (AuthManager b) (Either AuthFailure ())
forall a. a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure ()
 -> Handler b (AuthManager b) (Either AuthFailure ()))
-> (AuthFailure -> Either AuthFailure ())
-> AuthFailure
-> Handler b (AuthManager b) (Either AuthFailure ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthFailure -> Either AuthFailure ()
forall a b. a -> Either a b
Left (AuthFailure -> Handler b (AuthManager b) (Either AuthFailure ()))
-> AuthFailure -> Handler b (AuthManager b) (Either AuthFailure ())
forall a b. (a -> b) -> a -> b
$
                     String -> AuthFailure
AuthError (String -> AuthFailure) -> String -> AuthFailure
forall a b. (a -> b) -> a -> b
$ String
"forceLogin: Can't force the login of a user "
                                   String -> String -> String
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 = ByteString -> Key -> Maybe Int -> m (Maybe t)
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 = ByteString -> Maybe ByteString -> Key -> Maybe Int -> t -> m ()
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) = Text -> Text -> Handler b SessionManager ()
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 = Text -> Handler b SessionManager ()
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 <- Text -> Handler b SessionManager (Maybe Text)
forall b. Text -> Handler b SessionManager (Maybe Text)
getFromSession Text
"__user_id"
  Maybe UserId -> Handler b SessionManager (Maybe UserId)
forall a. a -> Handler b SessionManager a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe UserId -> Handler b SessionManager (Maybe UserId))
-> Maybe UserId -> Handler b SessionManager (Maybe UserId)
forall a b. (a -> b) -> a -> b
$ (Text -> UserId) -> Maybe Text -> Maybe UserId
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 -> AuthFailure -> Maybe AuthFailure
forall a. a -> Maybe a
Just AuthFailure
PasswordMissing
                Just Password
upw -> Bool -> Maybe AuthFailure
check (Bool -> Maybe AuthFailure) -> Bool -> Maybe AuthFailure
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 Maybe AuthFailure
forall a. Maybe a
Nothing else AuthFailure -> Maybe AuthFailure
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 <- (AuthManager b -> Maybe AuthUser)
-> Handler b (AuthManager b) (Maybe AuthUser)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> Maybe AuthUser
forall b. AuthManager b -> Maybe AuthUser
activeUser
    if Maybe AuthUser -> Bool
forall a. Maybe a -> Bool
isJust Maybe AuthUser
au
      then Maybe AuthUser -> Handler b (AuthManager b) (Maybe AuthUser)
forall a. a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AuthUser
au
      else do
        Maybe AuthUser
au' <- Handler b (AuthManager b) (Maybe AuthUser)
f
        (AuthManager b -> AuthManager b) -> Handler b (AuthManager b) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\AuthManager b
mgr -> AuthManager b
mgr { activeUser :: Maybe AuthUser
activeUser = Maybe AuthUser
au' })
        Maybe AuthUser -> Handler b (AuthManager b) (Maybe AuthUser)
forall a. a -> Handler b (AuthManager b) a
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 <- (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
decodeUtf8 (Maybe ByteString -> Maybe Text)
-> Handler b (AuthManager b) (Maybe ByteString)
-> Handler b (AuthManager b) (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Handler b (AuthManager b) (Maybe ByteString)
forall (m :: * -> *).
MonadSnap m =>
ByteString -> m (Maybe ByteString)
getParam ByteString
lf
    Maybe ByteString
p <- ByteString -> Handler b (AuthManager b) (Maybe ByteString)
forall (m :: * -> *).
MonadSnap m =>
ByteString -> m (Maybe ByteString)
getParam ByteString
pf

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

    -- In case of multiple AuthFailure, the first available one
    -- will be propagated.
    case (Text -> ByteString -> (Text, ByteString))
-> Either AuthFailure Text
-> Either AuthFailure ByteString
-> Either AuthFailure (Text, ByteString)
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           -> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a. a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
 -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthFailure -> Either AuthFailure AuthUser
forall a b. a -> Either a b
Left AuthFailure
e
      Right (Text
lgn, ByteString
pwd) -> Text
-> ByteString
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
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 =
    ByteString
-> ByteString
-> Maybe ByteString
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b.
ByteString
-> ByteString
-> Maybe ByteString
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginUser' ByteString
unf ByteString
pwdf Maybe ByteString
remf Handler b (AuthManager b) (Either AuthFailure AuthUser)
-> (Either AuthFailure AuthUser -> Handler b (AuthManager b) ())
-> Handler b (AuthManager b) ()
forall a b.
Handler b (AuthManager b) a
-> (a -> Handler b (AuthManager b) b)
-> Handler b (AuthManager b) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (AuthFailure -> Handler b (AuthManager b) ())
-> (AuthUser -> Handler b (AuthManager b) ())
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either AuthFailure -> Handler b (AuthManager b) ()
loginFail (Handler b (AuthManager b) ()
-> AuthUser -> Handler b (AuthManager b) ()
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 <- ByteString -> Handler b (AuthManager b) (Maybe ByteString)
forall (m :: * -> *).
MonadSnap m =>
ByteString -> m (Maybe ByteString)
getParam ByteString
unf
    Maybe ByteString
mbPassword <- ByteString -> Handler b (AuthManager b) (Maybe ByteString)
forall (m :: * -> *).
MonadSnap m =>
ByteString -> m (Maybe ByteString)
getParam ByteString
pwdf
    Bool
remember   <- (Maybe Bool -> Bool)
-> Handler b (AuthManager b) (Maybe Bool)
-> Handler b (AuthManager b) Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False)
                    (MaybeT (Handler b (AuthManager b)) Bool
-> Handler b (AuthManager b) (Maybe Bool)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (Handler b (AuthManager b)) Bool
 -> Handler b (AuthManager b) (Maybe Bool))
-> MaybeT (Handler b (AuthManager b)) Bool
-> Handler b (AuthManager b) (Maybe Bool)
forall a b. (a -> b) -> a -> b
$
                    do ByteString
field <- Handler b (AuthManager b) (Maybe ByteString)
-> MaybeT (Handler b (AuthManager b)) ByteString
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Handler b (AuthManager b) (Maybe ByteString)
 -> MaybeT (Handler b (AuthManager b)) ByteString)
-> Handler b (AuthManager b) (Maybe ByteString)
-> MaybeT (Handler b (AuthManager b)) ByteString
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> Handler b (AuthManager b) (Maybe ByteString)
forall a. a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
remf
                       ByteString
value <- Handler b (AuthManager b) (Maybe ByteString)
-> MaybeT (Handler b (AuthManager b)) ByteString
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Handler b (AuthManager b) (Maybe ByteString)
 -> MaybeT (Handler b (AuthManager b)) ByteString)
-> Handler b (AuthManager b) (Maybe ByteString)
-> MaybeT (Handler b (AuthManager b)) ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Handler b (AuthManager b) (Maybe ByteString)
forall (m :: * -> *).
MonadSnap m =>
ByteString -> m (Maybe ByteString)
getParam ByteString
field
                       Bool -> MaybeT (Handler b (AuthManager b)) Bool
forall a. a -> MaybeT (Handler b (AuthManager b)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> MaybeT (Handler b (AuthManager b)) Bool)
-> Bool -> MaybeT (Handler b (AuthManager b)) Bool
forall a b. (a -> b) -> a -> b
$ ByteString
value ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"1" Bool -> Bool -> Bool
|| ByteString
value ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"on")

    case Maybe ByteString
mbUsername of
      Maybe ByteString
Nothing -> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a. a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
 -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthFailure -> Either AuthFailure AuthUser
forall a b. a -> Either a b
Left AuthFailure
UsernameMissing
      Just ByteString
u -> case Maybe ByteString
mbPassword of
        Maybe ByteString
Nothing -> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a. a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
 -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthFailure -> Either AuthFailure AuthUser
forall a b. a -> Either a b
Left AuthFailure
PasswordMissing
        Just ByteString
p -> Text
-> Password
-> Bool
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
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 = Handler b (AuthManager b) ()
forall b. Handler b (AuthManager b) ()
logout Handler b (AuthManager b) ()
-> Handler b (AuthManager b) () -> Handler b (AuthManager b) ()
forall a b.
Handler b (AuthManager b) a
-> Handler b (AuthManager b) b -> Handler b (AuthManager b) b
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 <- SnapletLens b (AuthManager b)
-> Handler b (AuthManager b) Bool -> Handler b v Bool
forall b v' a v.
SnapletLens b v' -> Handler b v' a -> Handler b v a
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 Handler b (AuthManager b) Bool
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 = Handler b (AuthManager v) (Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Handler b (AuthManager v) (Handler b (AuthManager v) a)
 -> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) (Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
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
_) <- Handler b (AuthManager v) (AuthManager v)
forall s (m :: * -> *). MonadState s m => m s
get
  Handler b (AuthManager v) a
-> Handler b (AuthManager v) (Handler b (AuthManager v) a)
forall a. a -> Handler b (AuthManager v) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Handler b (AuthManager v) a
 -> Handler b (AuthManager v) (Handler b (AuthManager v) a))
-> Handler b (AuthManager v) a
-> Handler b (AuthManager v) (Handler b (AuthManager v) a)
forall a b. (a -> b) -> a -> b
$ r -> Handler b (AuthManager v) a
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 <- IO ByteString -> Handler b (AuthManager b) ByteString
forall a. IO a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> Handler b (AuthManager b) ByteString)
-> (RNG -> IO ByteString)
-> RNG
-> Handler b (AuthManager b) ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> RNG -> IO ByteString
randomToken Int
40 (RNG -> Handler b (AuthManager b) ByteString)
-> Handler b (AuthManager b) RNG
-> Handler b (AuthManager b) ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (AuthManager b -> RNG) -> Handler b (AuthManager b) RNG
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> RNG
forall b. AuthManager b -> RNG
randomNumberGenerator
  let token :: Text
token = ByteString -> Text
decodeUtf8 ByteString
tokBS
  UTCTime
now <- IO UTCTime -> Handler b (AuthManager b) UTCTime
forall a. IO a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  Bool
success <- Text
-> Maybe Text -> Maybe UTCTime -> Handler b (AuthManager b) Bool
forall v.
Text
-> Maybe Text -> Maybe UTCTime -> Handler v (AuthManager v) Bool
modPasswordResetToken Text
login (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
token) (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
now)
  Maybe Text -> Handler b (AuthManager b) (Maybe Text)
forall a. a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> Handler b (AuthManager b) (Maybe Text))
-> Maybe Text -> Handler b (AuthManager b) (Maybe Text)
forall a b. (a -> b) -> a -> b
$ if Bool
success then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
token else Maybe Text
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 = Text
-> Maybe Text -> Maybe UTCTime -> Handler b (AuthManager b) Bool
forall v.
Text
-> Maybe Text -> Maybe UTCTime -> Handler v (AuthManager v) Bool
modPasswordResetToken Text
login Maybe Text
forall a. Maybe a
Nothing Maybe UTCTime
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 <- MaybeT (Handler v (AuthManager v)) ()
-> Handler v (AuthManager v) (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (Handler v (AuthManager v)) ()
 -> Handler v (AuthManager v) (Maybe ()))
-> MaybeT (Handler v (AuthManager v)) ()
-> Handler v (AuthManager v) (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
      AuthUser
u <- Handler v (AuthManager v) (Maybe AuthUser)
-> MaybeT (Handler v (AuthManager v)) AuthUser
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Handler v (AuthManager v) (Maybe AuthUser)
 -> MaybeT (Handler v (AuthManager v)) AuthUser)
-> Handler v (AuthManager v) (Maybe AuthUser)
-> MaybeT (Handler v (AuthManager v)) AuthUser
forall a b. (a -> b) -> a -> b
$ (forall r.
 IAuthBackend r =>
 r -> Handler v (AuthManager v) (Maybe AuthUser))
-> Handler v (AuthManager v) (Maybe AuthUser)
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 v (AuthManager v) (Maybe AuthUser))
 -> Handler v (AuthManager v) (Maybe AuthUser))
-> (forall r.
    IAuthBackend r =>
    r -> Handler v (AuthManager v) (Maybe AuthUser))
-> Handler v (AuthManager v) (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ \r
b -> IO (Maybe AuthUser) -> Handler v (AuthManager v) (Maybe AuthUser)
forall a. IO a -> Handler v (AuthManager v) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe AuthUser) -> Handler v (AuthManager v) (Maybe AuthUser))
-> IO (Maybe AuthUser)
-> Handler v (AuthManager v) (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ r -> Text -> IO (Maybe AuthUser)
forall r. IAuthBackend r => r -> Text -> IO (Maybe AuthUser)
lookupByLogin r
b Text
login
      Handler v (AuthManager v) (Either AuthFailure AuthUser)
-> MaybeT (Handler v (AuthManager v)) (Either AuthFailure AuthUser)
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Handler v (AuthManager v) (Either AuthFailure AuthUser)
 -> MaybeT
      (Handler v (AuthManager v)) (Either AuthFailure AuthUser))
-> Handler v (AuthManager v) (Either AuthFailure AuthUser)
-> MaybeT (Handler v (AuthManager v)) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthUser -> Handler v (AuthManager v) (Either AuthFailure AuthUser)
forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
saveUser (AuthUser
 -> Handler v (AuthManager v) (Either AuthFailure AuthUser))
-> AuthUser
-> Handler v (AuthManager v) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthUser
u
        { userResetToken :: Maybe Text
userResetToken = Maybe Text
token
        , userResetRequestedAt :: Maybe UTCTime
userResetRequestedAt = Maybe UTCTime
timestamp
        }
      () -> MaybeT (Handler v (AuthManager v)) ()
forall a. a -> MaybeT (Handler v (AuthManager v)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Bool -> Handler v (AuthManager v) Bool
forall a. a -> Handler v (AuthManager v) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Handler v (AuthManager v) Bool)
-> Bool -> Handler v (AuthManager v) Bool
forall a b. (a -> b) -> a -> b
$ Bool -> (() -> Bool) -> Maybe () -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\()
_ -> Bool
True) Maybe ()
res