{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}

module Snap.Snaplet.CustomAuth.User where

import Control.Error.Util
import Control.Monad.State
import Control.Monad.Trans.Maybe
import Data.ByteString (ByteString)
import Data.ByteString.Lazy (toStrict)
import qualified Data.Configurator as C
import Data.Maybe
import Data.Text.Encoding
import Data.Time.Clock (addUTCTime, getCurrentTime)
import Snap
import qualified Text.Show.ByteString

import Snap.Snaplet.CustomAuth.Types (AuthUser(..))
import Snap.Snaplet.CustomAuth.AuthManager

setUser
  :: UserData u
  => u
  -> Handler b (AuthManager u e b) ()
setUser :: u -> Handler b (AuthManager u e b) ()
setUser u
usr = do
  Config
cfg <- Handler b (AuthManager u e b) Config
forall (m :: * -> * -> * -> *) b v.
(Monad (m b v), MonadSnaplet m) =>
m b v Config
getSnapletUserConfig
  Bool
secure <- (ByteString -> Bool)
-> Handler b (AuthManager u e b) ByteString
-> Handler b (AuthManager u e b) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"https") (Handler b (AuthManager u e b) ByteString
 -> Handler b (AuthManager u e b) Bool)
-> Handler b (AuthManager u e b) ByteString
-> Handler b (AuthManager u e b) Bool
forall a b. (a -> b) -> a -> b
$ IO ByteString -> Handler b (AuthManager u e b) ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> Handler b (AuthManager u e b) ByteString)
-> IO ByteString -> Handler b (AuthManager u e b) ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Config -> Name -> IO ByteString
forall a. Configured a => a -> Config -> Name -> IO a
C.lookupDefault (ByteString
"https" :: ByteString) Config
cfg Name
"protocol"
  let udata :: AuthUser
udata = u -> AuthUser
forall a. UserData a => a -> AuthUser
extractUser u
usr
  (ByteString
name, Maybe NominalDiffTime
lifetime) <- (AuthManager u e b -> (ByteString, Maybe NominalDiffTime))
-> Handler
     b (AuthManager u e b) (ByteString, Maybe NominalDiffTime)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((,) (ByteString
 -> Maybe NominalDiffTime -> (ByteString, Maybe NominalDiffTime))
-> (AuthManager u e b -> ByteString)
-> AuthManager u e b
-> Maybe NominalDiffTime
-> (ByteString, Maybe NominalDiffTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AuthManager u e b -> ByteString
forall u e b. AuthManager u e b -> ByteString
sessionCookieName (AuthManager u e b
 -> Maybe NominalDiffTime -> (ByteString, Maybe NominalDiffTime))
-> (AuthManager u e b -> Maybe NominalDiffTime)
-> AuthManager u e b
-> (ByteString, Maybe NominalDiffTime)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AuthManager u e b -> Maybe NominalDiffTime
forall u e b. AuthManager u e b -> Maybe NominalDiffTime
cookieLifetime)
  (Response -> Response) -> Handler b (AuthManager u e b) ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse ((Response -> Response) -> Handler b (AuthManager u e b) ())
-> (Response -> Response) -> Handler b (AuthManager u e b) ()
forall a b. (a -> b) -> a -> b
$ CI ByteString -> ByteString -> Response -> Response
forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
addHeader CI ByteString
"Set-Cookie" (ByteString -> Response -> Response)
-> ByteString -> Response -> Response
forall a b. (a -> b) -> a -> b
$
    ByteString
name ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> AuthUser -> ByteString
session AuthUser
udata ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
    (ByteString
-> (NominalDiffTime -> ByteString)
-> Maybe NominalDiffTime
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" ((ByteString
"; Max-Age=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>) (ByteString -> ByteString)
-> (NominalDiffTime -> ByteString) -> NominalDiffTime -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
toStrict (ByteString -> ByteString)
-> (NominalDiffTime -> ByteString) -> NominalDiffTime -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Show Int => Int -> ByteString
forall a. Show a => a -> ByteString
Text.Show.ByteString.show @Int (Int -> ByteString)
-> (NominalDiffTime -> Int) -> NominalDiffTime -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor) Maybe NominalDiffTime
lifetime) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
    ByteString
"; Path=/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
    (if Bool
secure then ByteString
"; Secure" else ByteString
"") ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
    ByteString
"; HttpOnly" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
    ByteString
"; SameSite=Lax"
  (AuthManager u e b -> AuthManager u e b)
-> Handler b (AuthManager u e b) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((AuthManager u e b -> AuthManager u e b)
 -> Handler b (AuthManager u e b) ())
-> (AuthManager u e b -> AuthManager u e b)
-> Handler b (AuthManager u e b) ()
forall a b. (a -> b) -> a -> b
$ \AuthManager u e b
mgr -> AuthManager u e b
mgr { activeUser :: UserData u => Maybe u
activeUser = u -> Maybe u
forall a. a -> Maybe a
Just u
usr }

currentUser :: UserData u => Handler b (AuthManager u e b) (Maybe u)
currentUser :: Handler b (AuthManager u e b) (Maybe u)
currentUser = do
  AuthManager u e b
u <- Handler b (AuthManager u e b) (AuthManager u e b)
forall s (m :: * -> *). MonadState s m => m s
get
  Maybe u -> Handler b (AuthManager u e b) (Maybe u)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe u -> Handler b (AuthManager u e b) (Maybe u))
-> Maybe u -> Handler b (AuthManager u e b) (Maybe u)
forall a b. (a -> b) -> a -> b
$ AuthManager u e b -> UserData u => Maybe u
forall u e b. AuthManager u e b -> UserData u => Maybe u
activeUser AuthManager u e b
u

setFailure'
  :: AuthFailure e
  -> Handler b (AuthManager u e b) ()
setFailure' :: AuthFailure e -> Handler b (AuthManager u e b) ()
setFailure' AuthFailure e
failure = (AuthManager u e b -> AuthManager u e b)
-> Handler b (AuthManager u e b) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((AuthManager u e b -> AuthManager u e b)
 -> Handler b (AuthManager u e b) ())
-> (AuthManager u e b -> AuthManager u e b)
-> Handler b (AuthManager u e b) ()
forall a b. (a -> b) -> a -> b
$ \AuthManager u e b
mgr -> AuthManager u e b
mgr { authFailData :: Maybe (AuthFailure e)
authFailData = AuthFailure e -> Maybe (AuthFailure e)
forall a. a -> Maybe a
Just AuthFailure e
failure }

recoverSession
  :: IAuthBackend u i e b
  => Handler b (AuthManager u e b) ()
recoverSession :: Handler b (AuthManager u e b) ()
recoverSession = do
  ByteString
sesName <- (AuthManager u e b -> ByteString)
-> Handler b (AuthManager u e b) ByteString
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager u e b -> ByteString
forall u e b. AuthManager u e b -> ByteString
sessionCookieName
  let quit :: AuthFailure e -> Handler b (AuthManager u e b) ()
quit AuthFailure e
e = do
        Maybe Cookie
ses <- ByteString -> Handler b (AuthManager u e b) (Maybe Cookie)
forall (m :: * -> *). MonadSnap m => ByteString -> m (Maybe Cookie)
getCookie ByteString
sesName
        Handler b (AuthManager u e b) ()
-> (Cookie -> Handler b (AuthManager u e b) ())
-> Maybe Cookie
-> Handler b (AuthManager u e b) ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Handler b (AuthManager u e b) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Cookie -> Handler b (AuthManager u e b) ()
forall (m :: * -> *). MonadSnap m => Cookie -> m ()
expireCookie Maybe Cookie
ses
        AuthFailure e -> Handler b (AuthManager u e b) ()
forall e b u. AuthFailure e -> Handler b (AuthManager u e b) ()
setFailure' AuthFailure e
e
  Maybe (Either (AuthFailure e) u)
usr <- MaybeT (Handler b (AuthManager u e b)) (Either (AuthFailure e) u)
-> Handler b (AuthManager u e b) (Maybe (Either (AuthFailure e) u))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (Handler b (AuthManager u e b)) (Either (AuthFailure e) u)
 -> Handler
      b (AuthManager u e b) (Maybe (Either (AuthFailure e) u)))
-> MaybeT
     (Handler b (AuthManager u e b)) (Either (AuthFailure e) u)
-> Handler b (AuthManager u e b) (Maybe (Either (AuthFailure e) u))
forall a b. (a -> b) -> a -> b
$ do
    Name
val <- Handler b (AuthManager u e b) (Maybe Name)
-> MaybeT (Handler b (AuthManager u e b)) Name
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Handler b (AuthManager u e b) (Maybe Name)
 -> MaybeT (Handler b (AuthManager u e b)) Name)
-> Handler b (AuthManager u e b) (Maybe Name)
-> MaybeT (Handler b (AuthManager u e b)) Name
forall a b. (a -> b) -> a -> b
$ ((Either UnicodeException Name -> Maybe Name
forall a b. Either a b -> Maybe b
hush (Either UnicodeException Name -> Maybe Name)
-> (Cookie -> Either UnicodeException Name) -> Cookie -> Maybe Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Name
decodeUtf8' (ByteString -> Either UnicodeException Name)
-> (Cookie -> ByteString) -> Cookie -> Either UnicodeException Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cookie -> ByteString
cookieValue (Cookie -> Maybe Name) -> Maybe Cookie -> Maybe Name
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Maybe Cookie -> Maybe Name)
-> Handler b (AuthManager u e b) (Maybe Cookie)
-> Handler b (AuthManager u e b) (Maybe Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Handler b (AuthManager u e b) (Maybe Cookie)
forall (m :: * -> *). MonadSnap m => ByteString -> m (Maybe Cookie)
getCookie ByteString
sesName)
    Handler b (AuthManager u e b) (Either (AuthFailure e) u)
-> MaybeT
     (Handler b (AuthManager u e b)) (Either (AuthFailure e) u)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Handler b (AuthManager u e b) (Either (AuthFailure e) u)
 -> MaybeT
      (Handler b (AuthManager u e b)) (Either (AuthFailure e) u))
-> Handler b (AuthManager u e b) (Either (AuthFailure e) u)
-> MaybeT
     (Handler b (AuthManager u e b)) (Either (AuthFailure e) u)
forall a b. (a -> b) -> a -> b
$ Name -> Handler b (AuthManager u e b) (Either (AuthFailure e) u)
forall u i e b.
IAuthBackend u i e b =>
Name -> Handler b (AuthManager u e b) (Either (AuthFailure e) u)
recover Name
val
  (AuthManager u e b -> AuthManager u e b)
-> Handler b (AuthManager u e b) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((AuthManager u e b -> AuthManager u e b)
 -> Handler b (AuthManager u e b) ())
-> (AuthManager u e b -> AuthManager u e b)
-> Handler b (AuthManager u e b) ()
forall a b. (a -> b) -> a -> b
$ \AuthManager u e b
mgr -> AuthManager u e b
mgr { activeUser :: UserData u => Maybe u
activeUser = Maybe (Maybe u) -> Maybe u
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe u) -> Maybe u) -> Maybe (Maybe u) -> Maybe u
forall a b. (a -> b) -> a -> b
$ Either (AuthFailure e) u -> Maybe u
forall a b. Either a b -> Maybe b
hush (Either (AuthFailure e) u -> Maybe u)
-> Maybe (Either (AuthFailure e) u) -> Maybe (Maybe u)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Either (AuthFailure e) u)
usr }
  Handler b (AuthManager u e b) ()
-> (Either (AuthFailure e) u -> Handler b (AuthManager u e b) ())
-> Maybe (Either (AuthFailure e) u)
-> Handler b (AuthManager u e b) ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Handler b (AuthManager u e b) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ((AuthFailure e -> Handler b (AuthManager u e b) ())
-> (u -> Handler b (AuthManager u e b) ())
-> Either (AuthFailure e) u
-> Handler b (AuthManager u e b) ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either AuthFailure e -> Handler b (AuthManager u e b) ()
forall e b u. AuthFailure e -> Handler b (AuthManager u e b) ()
quit (Handler b (AuthManager u e b) ()
-> u -> Handler b (AuthManager u e b) ()
forall a b. a -> b -> a
const (Handler b (AuthManager u e b) ()
 -> u -> Handler b (AuthManager u e b) ())
-> Handler b (AuthManager u e b) ()
-> u
-> Handler b (AuthManager u e b) ()
forall a b. (a -> b) -> a -> b
$ () -> Handler b (AuthManager u e b) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())) Maybe (Either (AuthFailure e) u)
usr

-- Just check if the session cookie is defined
isSessionDefined
  :: Handler b (AuthManager u e b) Bool
isSessionDefined :: Handler b (AuthManager u e b) Bool
isSessionDefined = (AuthManager u e b -> ByteString)
-> Handler b (AuthManager u e b) ByteString
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager u e b -> ByteString
forall u e b. AuthManager u e b -> ByteString
sessionCookieName Handler b (AuthManager u e b) ByteString
-> (ByteString -> Handler b (AuthManager u e b) (Maybe Cookie))
-> Handler b (AuthManager u e b) (Maybe Cookie)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Handler b (AuthManager u e b) (Maybe Cookie)
forall (m :: * -> *). MonadSnap m => ByteString -> m (Maybe Cookie)
getCookie Handler b (AuthManager u e b) (Maybe Cookie)
-> (Maybe Cookie -> Handler b (AuthManager u e b) Bool)
-> Handler b (AuthManager u e b) Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Handler b (AuthManager u e b) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Handler b (AuthManager u e b) Bool)
-> (Maybe Cookie -> Bool)
-> Maybe Cookie
-> Handler b (AuthManager u e b) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Cookie -> Bool
forall a. Maybe a -> Bool
isJust