{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}

module Server.Handlers.AuthHandlers
    ( AuthAPI
    , authServer
    ) where

import Control.Monad.IO.Class
import Data.Password.Argon2
import Docs (logMessage)
import Docs.Hasql.Database (run)
import qualified Hasql.Session as Session
import Logging.Logs (Severity (Info))
import Logging.Scope (Scope (Scope))
import Servant
import Servant.Auth.Server
import qualified Server.Auth as Auth
import Server.HandlerUtil
import qualified UserManagement.Sessions as Sessions
import Prelude hiding (readFile)

type AuthAPI =
    "login"
        :> ReqBody '[JSON] Auth.UserLoginData
        :> Post
            '[JSON]
            ( Headers
                '[ Header "Set-Cookie" SetCookie
                 , Header "Set-Cookie" SetCookie
                 ]
                NoContent
            )
        :<|> "logout"
            :> Get
                '[JSON]
                ( Headers
                    '[ Header "Set-Cookie" SetCookie
                     , Header "Set-Cookie" SetCookie
                     ]
                    NoContent
                )

authServer :: CookieSettings -> JWTSettings -> Server AuthAPI
authServer :: CookieSettings -> JWTSettings -> Server AuthAPI
authServer CookieSettings
cookieSett JWTSettings
jwtSett =
    CookieSettings
-> JWTSettings
-> UserLoginData
-> Handler
     (Headers
        '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
          Header' '[Optional, Strict] "Set-Cookie" SetCookie]
        NoContent)
loginHandler CookieSettings
cookieSett JWTSettings
jwtSett
        (UserLoginData
 -> Handler
      (Headers
         '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
           Header' '[Optional, Strict] "Set-Cookie" SetCookie]
         NoContent))
-> Handler
     (Headers
        '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
          Header' '[Optional, Strict] "Set-Cookie" SetCookie]
        NoContent)
-> (UserLoginData
    -> Handler
         (Headers
            '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
              Header' '[Optional, Strict] "Set-Cookie" SetCookie]
            NoContent))
   :<|> Handler
          (Headers
             '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
               Header' '[Optional, Strict] "Set-Cookie" SetCookie]
             NoContent)
forall a b. a -> b -> a :<|> b
:<|> CookieSettings
-> Handler
     (Headers
        '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
          Header' '[Optional, Strict] "Set-Cookie" SetCookie]
        NoContent)
logoutHandler CookieSettings
cookieSett

loginHandler
    :: CookieSettings
    -> JWTSettings
    -> Auth.UserLoginData
    -> Handler
        ( Headers
            '[Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie]
            NoContent
        )
loginHandler :: CookieSettings
-> JWTSettings
-> UserLoginData
-> Handler
     (Headers
        '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
          Header' '[Optional, Strict] "Set-Cookie" SetCookie]
        NoContent)
loginHandler CookieSettings
cookieSett JWTSettings
jwtSett Auth.UserLoginData {Text
loginEmail :: Text
loginPassword :: Text
loginPassword :: UserLoginData -> Text
loginEmail :: UserLoginData -> Text
..} = do
    Connection
conn <- Handler Connection
tryGetDBConnection
    Either SessionError (Maybe (UserID, Text))
eUser <- IO (Either SessionError (Maybe (UserID, Text)))
-> Handler (Either SessionError (Maybe (UserID, Text)))
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SessionError (Maybe (UserID, Text)))
 -> Handler (Either SessionError (Maybe (UserID, Text))))
-> IO (Either SessionError (Maybe (UserID, Text)))
-> Handler (Either SessionError (Maybe (UserID, Text)))
forall a b. (a -> b) -> a -> b
$ Session (Maybe (UserID, Text))
-> Connection -> IO (Either SessionError (Maybe (UserID, Text)))
forall a. Session a -> Connection -> IO (Either SessionError a)
Session.run (Text -> Session (Maybe (UserID, Text))
Sessions.getLoginRequirements Text
loginEmail) Connection
conn
    case Either SessionError (Maybe (UserID, Text))
eUser of
        Right (Just (UserID
uid, Text
pwhash)) -> do
            let passwordCheck :: PasswordCheck
passwordCheck = Password -> PasswordHash Argon2 -> PasswordCheck
checkPassword (Text -> Password
mkPassword Text
loginPassword) (Text -> PasswordHash Argon2
forall a. Text -> PasswordHash a
PasswordHash Text
pwhash)
            case PasswordCheck
passwordCheck of
                PasswordCheck
PasswordCheckFail -> ServerError
-> Handler
     (Headers
        '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
          Header' '[Optional, Strict] "Set-Cookie" SetCookie]
        NoContent)
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
errWrongLoginCredentials
                PasswordCheck
PasswordCheckSuccess -> do
                    Either SessionError LogMessage
_ <-
                        IO (Either SessionError LogMessage)
-> Handler (Either SessionError LogMessage)
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                            (IO (Either SessionError LogMessage)
 -> Handler (Either SessionError LogMessage))
-> IO (Either SessionError LogMessage)
-> Handler (Either SessionError LogMessage)
forall a b. (a -> b) -> a -> b
$ (HasqlSession LogMessage
 -> Connection -> IO (Either SessionError LogMessage))
-> Connection
-> HasqlSession LogMessage
-> IO (Either SessionError LogMessage)
forall a b c. (a -> b -> c) -> b -> a -> c
flip
                                HasqlSession LogMessage
-> Connection -> IO (Either SessionError LogMessage)
forall a.
HasqlSession a -> Connection -> IO (Either SessionError a)
run
                                Connection
conn
                            (HasqlSession LogMessage -> IO (Either SessionError LogMessage))
-> HasqlSession LogMessage -> IO (Either SessionError LogMessage)
forall a b. (a -> b) -> a -> b
$ Severity
-> Maybe UserID -> Scope -> Text -> HasqlSession LogMessage
forall (m :: * -> *) v.
(HasLogMessage m, ToJSON v) =>
Severity -> Maybe UserID -> Scope -> v -> m LogMessage
logMessage
                                Severity
Info
                                (UserID -> Maybe UserID
forall a. a -> Maybe a
Just UserID
uid)
                                (Text -> Scope
Scope Text
"login")
                                (Text
loginEmail Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" logged in.")
                    Either SessionError Bool
eSuperadmin <- IO (Either SessionError Bool) -> Handler (Either SessionError Bool)
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SessionError Bool)
 -> Handler (Either SessionError Bool))
-> IO (Either SessionError Bool)
-> Handler (Either SessionError Bool)
forall a b. (a -> b) -> a -> b
$ Session Bool -> Connection -> IO (Either SessionError Bool)
forall a. Session a -> Connection -> IO (Either SessionError a)
Session.run (UserID -> Session Bool
Sessions.checkSuperadmin UserID
uid) Connection
conn
                    case Either SessionError Bool
eSuperadmin of
                        Left SessionError
_ -> ServerError
-> Handler
     (Headers
        '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
          Header' '[Optional, Strict] "Set-Cookie" SetCookie]
        NoContent)
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
errDatabaseAccessFailed
                        Right Bool
isSuperadmin -> do
                            Maybe
  (NoContent
   -> Headers
        '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
          Header' '[Optional, Strict] "Set-Cookie" SetCookie]
        NoContent)
mLoginAccepted <-
                                IO
  (Maybe
     (NoContent
      -> Headers
           '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
             Header' '[Optional, Strict] "Set-Cookie" SetCookie]
           NoContent))
-> Handler
     (Maybe
        (NoContent
         -> Headers
              '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
                Header' '[Optional, Strict] "Set-Cookie" SetCookie]
              NoContent))
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (Maybe
      (NoContent
       -> Headers
            '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
              Header' '[Optional, Strict] "Set-Cookie" SetCookie]
            NoContent))
 -> Handler
      (Maybe
         (NoContent
          -> Headers
               '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
                 Header' '[Optional, Strict] "Set-Cookie" SetCookie]
               NoContent)))
-> IO
     (Maybe
        (NoContent
         -> Headers
              '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
                Header' '[Optional, Strict] "Set-Cookie" SetCookie]
              NoContent))
-> Handler
     (Maybe
        (NoContent
         -> Headers
              '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
                Header' '[Optional, Strict] "Set-Cookie" SetCookie]
              NoContent))
forall a b. (a -> b) -> a -> b
$ CookieSettings
-> JWTSettings
-> Token
-> IO
     (Maybe
        (NoContent
         -> Headers
              '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
                Header' '[Optional, Strict] "Set-Cookie" SetCookie]
              NoContent))
forall (mods :: [*]) response withOneCookie withTwoCookies session.
(AddHeader mods "Set-Cookie" SetCookie response withOneCookie,
 AddHeader mods "Set-Cookie" SetCookie withOneCookie withTwoCookies,
 ToJWT session) =>
CookieSettings
-> JWTSettings
-> session
-> IO (Maybe (response -> withTwoCookies))
acceptLogin CookieSettings
cookieSett JWTSettings
jwtSett (UserID -> Bool -> Token
Auth.Token UserID
uid Bool
isSuperadmin)
                            case Maybe
  (NoContent
   -> Headers
        '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
          Header' '[Optional, Strict] "Set-Cookie" SetCookie]
        NoContent)
mLoginAccepted of
                                Maybe
  (NoContent
   -> Headers
        '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
          Header' '[Optional, Strict] "Set-Cookie" SetCookie]
        NoContent)
Nothing -> ServerError
-> Handler
     (Headers
        '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
          Header' '[Optional, Strict] "Set-Cookie" SetCookie]
        NoContent)
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
errLoginFailed
                                Just NoContent
-> Headers
     '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
       Header' '[Optional, Strict] "Set-Cookie" SetCookie]
     NoContent
addHeaders -> Headers
  '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
    Header' '[Optional, Strict] "Set-Cookie" SetCookie]
  NoContent
-> Handler
     (Headers
        '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
          Header' '[Optional, Strict] "Set-Cookie" SetCookie]
        NoContent)
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return (Headers
   '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
     Header' '[Optional, Strict] "Set-Cookie" SetCookie]
   NoContent
 -> Handler
      (Headers
         '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
           Header' '[Optional, Strict] "Set-Cookie" SetCookie]
         NoContent))
-> Headers
     '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
       Header' '[Optional, Strict] "Set-Cookie" SetCookie]
     NoContent
-> Handler
     (Headers
        '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
          Header' '[Optional, Strict] "Set-Cookie" SetCookie]
        NoContent)
forall a b. (a -> b) -> a -> b
$ NoContent
-> Headers
     '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
       Header' '[Optional, Strict] "Set-Cookie" SetCookie]
     NoContent
addHeaders NoContent
NoContent
        Right Maybe (UserID, Text)
Nothing -> ServerError
-> Handler
     (Headers
        '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
          Header' '[Optional, Strict] "Set-Cookie" SetCookie]
        NoContent)
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
errWrongLoginCredentials
        Left SessionError
_ -> ServerError
-> Handler
     (Headers
        '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
          Header' '[Optional, Strict] "Set-Cookie" SetCookie]
        NoContent)
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
errDatabaseAccessFailed

logoutHandler
    :: CookieSettings
    -> Handler
        ( Headers
            '[Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie]
            NoContent
        )
logoutHandler :: CookieSettings
-> Handler
     (Headers
        '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
          Header' '[Optional, Strict] "Set-Cookie" SetCookie]
        NoContent)
logoutHandler CookieSettings
cookieSett = Headers
  '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
    Header' '[Optional, Strict] "Set-Cookie" SetCookie]
  NoContent
-> Handler
     (Headers
        '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
          Header' '[Optional, Strict] "Set-Cookie" SetCookie]
        NoContent)
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return (Headers
   '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
     Header' '[Optional, Strict] "Set-Cookie" SetCookie]
   NoContent
 -> Handler
      (Headers
         '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
           Header' '[Optional, Strict] "Set-Cookie" SetCookie]
         NoContent))
-> Headers
     '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
       Header' '[Optional, Strict] "Set-Cookie" SetCookie]
     NoContent
-> Handler
     (Headers
        '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
          Header' '[Optional, Strict] "Set-Cookie" SetCookie]
        NoContent)
forall a b. (a -> b) -> a -> b
$ CookieSettings
-> NoContent
-> Headers
     '[Header' '[Optional, Strict] "Set-Cookie" SetCookie,
       Header' '[Optional, Strict] "Set-Cookie" SetCookie]
     NoContent
forall (mods :: [*]) response withOneCookie withTwoCookies.
(AddHeader mods "Set-Cookie" SetCookie response withOneCookie,
 AddHeader
   mods "Set-Cookie" SetCookie withOneCookie withTwoCookies) =>
CookieSettings -> response -> withTwoCookies
clearSession CookieSettings
cookieSett NoContent
NoContent