{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Server.Authentication.Mock
( handleRoot
, handleLogout
, readUserIdentityFromCookies
) where

import Server.Authentication.Utils (redirectToCurrentRefererIfAllowed)
import Server.Core
import Happstack.Server
import Control.Monad (msum, mzero)
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

handleRoot :: ServerConfiguration -> ServerResources -> ServerPart Response
handleRoot :: ServerConfiguration -> ServerResources -> ServerPart Response
handleRoot ServerConfiguration
serverConfiguration ServerResources
serverResources = [ServerPart Response] -> ServerPart Response
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
    [ String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"login" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerPart Response
handleLogin
    ]

signedInCookieName :: String
signedInCookieName :: String
signedInCookieName = String
"mock_isSignedIn"

handleLogin :: ServerPart Response
handleLogin :: ServerPart Response
handleLogin = do
    CookieLife -> Cookie -> ServerPartT IO ()
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
CookieLife -> Cookie -> m ()
addCookie CookieLife
Session (Cookie -> ServerPartT IO ()) -> Cookie -> ServerPartT IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> Cookie
mkCookie String
signedInCookieName String
"true"
    ServerPart Response
redirectToCurrentRefererIfAllowed

handleLogout :: ServerConfiguration -> ServerResources -> ServerPart ()
handleLogout :: ServerConfiguration -> ServerResources -> ServerPartT IO ()
handleLogout ServerConfiguration
serverConfiguration ServerResources
serverResources = do
    String -> ServerPartT IO ()
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
String -> m ()
expireCookie String
signedInCookieName

readUserIdentityFromCookies :: ServerConfiguration -> ServerResources -> ServerPart (Maybe UserIdentity)
readUserIdentityFromCookies :: ServerConfiguration
-> ServerResources -> ServerPart (Maybe UserIdentity)
readUserIdentityFromCookies ServerConfiguration
serverConfiguration ServerResources
serverResources = MaybeT (ServerPartT IO) UserIdentity
-> ServerPart (Maybe UserIdentity)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (ServerPartT IO) UserIdentity
 -> ServerPart (Maybe UserIdentity))
-> MaybeT (ServerPartT IO) UserIdentity
-> ServerPart (Maybe UserIdentity)
forall a b. (a -> b) -> a -> b
$ do
    String
isSignedIn <- ServerPartT IO String -> MaybeT (ServerPartT IO) String
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ServerPartT IO String -> MaybeT (ServerPartT IO) String)
-> ServerPartT IO String -> MaybeT (ServerPartT IO) String
forall a b. (a -> b) -> a -> b
$ String -> ServerPartT IO String
forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
String -> m String
lookCookieValue String
signedInCookieName
    if String
isSignedIn String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"true" then do
        let userIdentifier :: UserIdentifier
userIdentifier = Text -> Text -> UserIdentifier
UserIdentifier Text
"mock" Text
"testuser1"
        let userPictureUrl :: Text
userPictureUrl = Text
"https://lojban.io/favicon.ico"
        let userName :: Text
userName = Text
"Arthur Dent"
        UserIdentity -> MaybeT (ServerPartT IO) UserIdentity
forall a. a -> MaybeT (ServerPartT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (UserIdentity -> MaybeT (ServerPartT IO) UserIdentity)
-> UserIdentity -> MaybeT (ServerPartT IO) UserIdentity
forall a b. (a -> b) -> a -> b
$ UserIdentifier -> Text -> Text -> UserIdentity
UserIdentity UserIdentifier
userIdentifier Text
userPictureUrl Text
userName
    else
        MaybeT (ServerPartT IO) UserIdentity
forall a. MaybeT (ServerPartT IO) a
forall (m :: * -> *) a. MonadPlus m => m a
mzero