module Mensam.Server.Server.Route.Api.User where

import Mensam.API.Aeson
import Mensam.API.Aeson.StaticText
import Mensam.API.Data.User
import Mensam.API.Data.User.Password
import Mensam.API.Data.User.Username
import Mensam.API.Pretty
import Mensam.API.Route.Api.User
import Mensam.Server.Application.Configured.Class
import Mensam.Server.Application.Email.Class
import Mensam.Server.Application.Secret.Class
import Mensam.Server.Application.SeldaPool.Class
import Mensam.Server.Application.SeldaPool.Servant
import Mensam.Server.Configuration
import Mensam.Server.Configuration.BaseUrl
import Mensam.Server.Jpeg
import Mensam.Server.Secrets
import Mensam.Server.Server.Auth
import Mensam.Server.User

import Control.Monad.IO.Class
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Class
import Data.ByteString qualified as B
import Data.Password.Bcrypt qualified as Bcrypt
import Data.SOP qualified as SOP
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Text.Lazy qualified as TL
import Data.Time qualified as T
import Servant hiding (BasicAuthResult (..))
import Servant.API.ImageJpeg
import Servant.Auth.Server
import Servant.Server.Generic
import Text.Blaze.Html.Renderer.Text qualified as T
import Text.Blaze.Html5 qualified as H
import Text.Blaze.Html5.Attributes qualified as H.A

handler ::
  (MonadConfigured m, MonadEmail m, MonadIO m, MonadLogger m, MonadSecret m, MonadSeldaPool m) =>
  Routes (AsServerT m)
handler :: forall (m :: * -> *).
(MonadConfigured m, MonadEmail m, MonadIO m, MonadLogger m,
 MonadSecret m, MonadSeldaPool m) =>
Routes (AsServerT m)
handler =
  Routes
    { routeLogin :: AsServerT m
:- (Summary "Login"
    :> (Description "Login to your user account.\n"
        :> ("login"
            :> (Auth '[BasicAuth, JWTWithSession] UserAuthenticated
                :> UVerb
                     'POST
                     '[JSON]
                     '[WithStatus 200 ResponseLogin, WithStatus 401 ErrorBasicAuth,
                       WithStatus 500 ()]))))
routeLogin = AsServerT m
:- (Summary "Login"
    :> (Description "Login to your user account.\n"
        :> ("login"
            :> (Auth '[BasicAuth, JWTWithSession] UserAuthenticated
                :> UVerb
                     'POST
                     '[JSON]
                     '[WithStatus 200 ResponseLogin, WithStatus 401 ErrorBasicAuth,
                       WithStatus 500 ()]))))
AuthResult UserAuthenticated
-> m (Union
        '[WithStatus 200 ResponseLogin, WithStatus 401 ErrorBasicAuth,
          WithStatus 500 ()])
forall (m :: * -> *) (responses :: [*]).
(MonadConfigured m, MonadIO m, MonadLogger m, MonadSecret m,
 MonadSeldaPool m,
 IsMember (WithStatus 200 ResponseLogin) responses,
 IsMember (WithStatus 401 ErrorBasicAuth) responses,
 IsMember (WithStatus 500 ()) responses) =>
AuthResult UserAuthenticated -> m (Union responses)
login
    , routeLogout :: AsServerT m
:- (Summary "Logout"
    :> (Description
          "Logout from a user session.\nThe token used with this request will be invalidated.\n"
        :> ("logout"
            :> (Auth '[JWTWithSession] UserAuthenticated
                :> UVerb
                     'POST
                     '[JSON]
                     '[WithStatus 200 ResponseLogout, WithStatus 401 ErrorBearerAuth,
                       WithStatus 500 ()]))))
routeLogout = AsServerT m
:- (Summary "Logout"
    :> (Description
          "Logout from a user session.\nThe token used with this request will be invalidated.\n"
        :> ("logout"
            :> (Auth '[JWTWithSession] UserAuthenticated
                :> UVerb
                     'POST
                     '[JSON]
                     '[WithStatus 200 ResponseLogout, WithStatus 401 ErrorBearerAuth,
                       WithStatus 500 ()]))))
AuthResult UserAuthenticated
-> m (Union
        '[WithStatus 200 ResponseLogout, WithStatus 401 ErrorBearerAuth,
          WithStatus 500 ()])
forall (m :: * -> *) (responses :: [*]).
(MonadConfigured m, MonadLogger m, MonadSeldaPool m,
 IsMember (WithStatus 200 ResponseLogout) responses,
 IsMember (WithStatus 401 ErrorBearerAuth) responses,
 IsMember (WithStatus 500 ()) responses) =>
AuthResult UserAuthenticated -> m (Union responses)
logout
    , routeRegister :: AsServerT m
:- (Summary "Register"
    :> (Description
          "Register a new user account.\nA confirmation email will be sent to the given email address.\n"
        :> ("register"
            :> (ReqBody' '[Lenient, Required] '[JSON] RequestRegister
                :> UVerb
                     'POST
                     '[JSON]
                     '[WithStatus 201 ResponseRegister,
                       WithStatus 400 ErrorParseBodyJson,
                       WithStatus 409 (StaticText "Username is taken."),
                       WithStatus 500 ()]))))
routeRegister = AsServerT m
:- (Summary "Register"
    :> (Description
          "Register a new user account.\nA confirmation email will be sent to the given email address.\n"
        :> ("register"
            :> (ReqBody' '[Lenient, Required] '[JSON] RequestRegister
                :> UVerb
                     'POST
                     '[JSON]
                     '[WithStatus 201 ResponseRegister,
                       WithStatus 400 ErrorParseBodyJson,
                       WithStatus 409 (StaticText "Username is taken."),
                       WithStatus 500 ()]))))
Either String RequestRegister
-> m (Union
        '[WithStatus 201 ResponseRegister,
          WithStatus 400 ErrorParseBodyJson,
          WithStatus 409 (StaticText "Username is taken."),
          WithStatus 500 ()])
forall (m :: * -> *) (responses :: [*]).
(MonadConfigured m, MonadEmail m, MonadIO m, MonadLogger m,
 MonadSeldaPool m,
 IsMember (WithStatus 201 ResponseRegister) responses,
 IsMember (WithStatus 400 ErrorParseBodyJson) responses,
 IsMember
   (WithStatus 409 (StaticText "Username is taken.")) responses,
 IsMember (WithStatus 500 ()) responses) =>
Either String RequestRegister -> m (Union responses)
register
    , routePasswordChange :: AsServerT m
:- (Summary "Change Password"
    :> (Description "Set a new password for your user account.\n"
        :> ("password"
            :> (Auth '[JWTWithSession] UserAuthenticated
                :> (ReqBody' '[Lenient, Required] '[JSON] RequestPasswordChange
                    :> UVerb
                         'PATCH
                         '[JSON]
                         '[WithStatus 200 ResponsePasswordChange,
                           WithStatus 400 ErrorParseBodyJson, WithStatus 401 ErrorBearerAuth,
                           WithStatus 500 ()])))))
routePasswordChange = AsServerT m
:- (Summary "Change Password"
    :> (Description "Set a new password for your user account.\n"
        :> ("password"
            :> (Auth '[JWTWithSession] UserAuthenticated
                :> (ReqBody' '[Lenient, Required] '[JSON] RequestPasswordChange
                    :> UVerb
                         'PATCH
                         '[JSON]
                         '[WithStatus 200 ResponsePasswordChange,
                           WithStatus 400 ErrorParseBodyJson, WithStatus 401 ErrorBearerAuth,
                           WithStatus 500 ()])))))
AuthResult UserAuthenticated
-> Either String RequestPasswordChange
-> m (Union
        '[WithStatus 200 ResponsePasswordChange,
          WithStatus 400 ErrorParseBodyJson, WithStatus 401 ErrorBearerAuth,
          WithStatus 500 ()])
forall (m :: * -> *) (responses :: [*]).
(MonadLogger m, MonadSeldaPool m,
 IsMember (WithStatus 200 ResponsePasswordChange) responses,
 IsMember (WithStatus 400 ErrorParseBodyJson) responses,
 IsMember (WithStatus 401 ErrorBearerAuth) responses,
 IsMember (WithStatus 500 ()) responses) =>
AuthResult UserAuthenticated
-> Either String RequestPasswordChange -> m (Union responses)
passwordChange
    , routePictureUpload :: AsServerT m
:- (Summary "Change Profile Picture"
    :> (Description
          "Upload a new profile picture.\nThis overwrites any old profile picture.\n"
        :> ("picture"
            :> (Auth '[JWTWithSession] UserAuthenticated
                :> (ReqBody' '[Lenient, Required] '[ImageJpeg] ImageJpegBytes
                    :> UVerb
                         'PUT
                         '[JSON]
                         '[WithStatus 200 (StaticText "Uploaded profile picture."),
                           WithStatus 400 ErrorParseBodyJpeg, WithStatus 401 ErrorBearerAuth,
                           WithStatus 500 ()])))))
routePictureUpload = AsServerT m
:- (Summary "Change Profile Picture"
    :> (Description
          "Upload a new profile picture.\nThis overwrites any old profile picture.\n"
        :> ("picture"
            :> (Auth '[JWTWithSession] UserAuthenticated
                :> (ReqBody' '[Lenient, Required] '[ImageJpeg] ImageJpegBytes
                    :> UVerb
                         'PUT
                         '[JSON]
                         '[WithStatus 200 (StaticText "Uploaded profile picture."),
                           WithStatus 400 ErrorParseBodyJpeg, WithStatus 401 ErrorBearerAuth,
                           WithStatus 500 ()])))))
AuthResult UserAuthenticated
-> Either String ImageJpegBytes
-> m (Union
        '[WithStatus 200 (StaticText "Uploaded profile picture."),
          WithStatus 400 ErrorParseBodyJpeg, WithStatus 401 ErrorBearerAuth,
          WithStatus 500 ()])
forall (m :: * -> *) (responses :: [*]).
(MonadLogger m, MonadSeldaPool m,
 IsMember
   (WithStatus 200 (StaticText "Uploaded profile picture."))
   responses,
 IsMember (WithStatus 400 ErrorParseBodyJpeg) responses,
 IsMember (WithStatus 401 ErrorBearerAuth) responses,
 IsMember (WithStatus 500 ()) responses) =>
AuthResult UserAuthenticated
-> Either String ImageJpegBytes -> m (Union responses)
pictureUpload
    , routePictureDelete :: AsServerT m
:- (Summary "Delete Profile Picture"
    :> (Description "Delete your current profile picture.\n"
        :> ("picture"
            :> (Auth '[JWTWithSession] UserAuthenticated
                :> UVerb
                     'DELETE
                     '[JSON]
                     '[WithStatus 200 (StaticText "Deleted profile picture."),
                       WithStatus 401 ErrorBearerAuth, WithStatus 500 ()]))))
routePictureDelete = AsServerT m
:- (Summary "Delete Profile Picture"
    :> (Description "Delete your current profile picture.\n"
        :> ("picture"
            :> (Auth '[JWTWithSession] UserAuthenticated
                :> UVerb
                     'DELETE
                     '[JSON]
                     '[WithStatus 200 (StaticText "Deleted profile picture."),
                       WithStatus 401 ErrorBearerAuth, WithStatus 500 ()]))))
AuthResult UserAuthenticated
-> m (Union
        '[WithStatus 200 (StaticText "Deleted profile picture."),
          WithStatus 401 ErrorBearerAuth, WithStatus 500 ()])
forall (m :: * -> *) (responses :: [*]).
(MonadLogger m, MonadSeldaPool m,
 IsMember
   (WithStatus 200 (StaticText "Deleted profile picture.")) responses,
 IsMember (WithStatus 401 ErrorBearerAuth) responses,
 IsMember (WithStatus 500 ()) responses) =>
AuthResult UserAuthenticated -> m (Union responses)
pictureDelete
    , routePictureDownload :: AsServerT m
:- (Summary "View Profile Picture"
    :> (Description "View a profile picture.\n"
        :> ("picture"
            :> (Auth '[JWTWithSession] UserAuthenticated
                :> (QueryParam' '[Lenient, Required] "user" IdentifierUser
                    :> Get '[ImageJpeg] ImageJpegBytes)))))
routePictureDownload = AsServerT m
:- (Summary "View Profile Picture"
    :> (Description "View a profile picture.\n"
        :> ("picture"
            :> (Auth '[JWTWithSession] UserAuthenticated
                :> (QueryParam' '[Lenient, Required] "user" IdentifierUser
                    :> Get '[ImageJpeg] ImageJpegBytes)))))
AuthResult UserAuthenticated
-> Either Text IdentifierUser -> m ImageJpegBytes
forall (m :: * -> *).
(MonadConfigured m, MonadIO m, MonadLogger m, MonadSeldaPool m) =>
AuthResult UserAuthenticated
-> Either Text IdentifierUser -> m ImageJpegBytes
pictureDownload
    , routeConfirmationRequest :: AsServerT m
:- (Summary "Request Email Address Confirmation"
    :> (Description
          "Send an email to your email address including a link.\nThis email includes a link to verify your email address.\n"
        :> ("confirmation"
            :> ("request"
                :> (Auth '[JWTWithSession] UserAuthenticated
                    :> UVerb
                         'POST
                         '[JSON]
                         '[WithStatus 200 ResponseConfirmationRequest,
                           WithStatus 401 ErrorBearerAuth, WithStatus 500 ()])))))
routeConfirmationRequest = AsServerT m
:- (Summary "Request Email Address Confirmation"
    :> (Description
          "Send an email to your email address including a link.\nThis email includes a link to verify your email address.\n"
        :> ("confirmation"
            :> ("request"
                :> (Auth '[JWTWithSession] UserAuthenticated
                    :> UVerb
                         'POST
                         '[JSON]
                         '[WithStatus 200 ResponseConfirmationRequest,
                           WithStatus 401 ErrorBearerAuth, WithStatus 500 ()])))))
AuthResult UserAuthenticated
-> m (Union
        '[WithStatus 200 ResponseConfirmationRequest,
          WithStatus 401 ErrorBearerAuth, WithStatus 500 ()])
forall (m :: * -> *) (responses :: [*]).
(MonadConfigured m, MonadEmail m, MonadIO m, MonadLogger m,
 MonadSeldaPool m,
 IsMember (WithStatus 200 ResponseConfirmationRequest) responses,
 IsMember (WithStatus 401 ErrorBearerAuth) responses,
 IsMember (WithStatus 500 ()) responses) =>
AuthResult UserAuthenticated -> m (Union responses)
confirmationRequest
    , routeConfirm :: AsServerT m
:- (Summary "Confirm Email Address"
    :> (Description "Verify your email address.\n"
        :> ("confirm"
            :> (Auth '[JWTWithSession] UserAuthenticated
                :> (ReqBody' '[Lenient, Required] '[JSON] RequestConfirm
                    :> UVerb
                         'POST
                         '[JSON]
                         '[WithStatus 200 ResponseConfirm,
                           WithStatus 400 ErrorParseBodyJson, WithStatus 401 ErrorBearerAuth,
                           WithStatus 410 (), WithStatus 500 ()])))))
routeConfirm = AsServerT m
:- (Summary "Confirm Email Address"
    :> (Description "Verify your email address.\n"
        :> ("confirm"
            :> (Auth '[JWTWithSession] UserAuthenticated
                :> (ReqBody' '[Lenient, Required] '[JSON] RequestConfirm
                    :> UVerb
                         'POST
                         '[JSON]
                         '[WithStatus 200 ResponseConfirm,
                           WithStatus 400 ErrorParseBodyJson, WithStatus 401 ErrorBearerAuth,
                           WithStatus 410 (), WithStatus 500 ()])))))
AuthResult UserAuthenticated
-> Either String RequestConfirm
-> m (Union
        '[WithStatus 200 ResponseConfirm,
          WithStatus 400 ErrorParseBodyJson, WithStatus 401 ErrorBearerAuth,
          WithStatus 410 (), WithStatus 500 ()])
forall (m :: * -> *) (responses :: [*]).
(MonadEmail m, MonadIO m, MonadLogger m, MonadSeldaPool m,
 IsMember (WithStatus 200 ResponseConfirm) responses,
 IsMember (WithStatus 400 ErrorParseBodyJson) responses,
 IsMember (WithStatus 401 ErrorBearerAuth) responses,
 IsMember (WithStatus 410 ()) responses,
 IsMember (WithStatus 500 ()) responses) =>
AuthResult UserAuthenticated
-> Either String RequestConfirm -> m (Union responses)
confirm
    , routeNotificationPreferences :: AsServerT m
:- (Summary "Edit Notification Preferences"
    :> (Description
          "Edit your notification preferences.\nYou first have to verify your email address to be able edit your notification preferences.\n"
        :> ("notificationPreferences"
            :> (Auth '[JWTWithSession] UserAuthenticated
                :> (ReqBody' '[Lenient, Required] '[JSON] RequestNotifications
                    :> UVerb
                         'POST
                         '[JSON]
                         '[WithStatus 200 ResponseNotifications,
                           WithStatus 400 ErrorParseBodyJson, WithStatus 401 ErrorBearerAuth,
                           WithStatus 403 (StaticText "Email address is not verified."),
                           WithStatus 500 ()])))))
routeNotificationPreferences = AsServerT m
:- (Summary "Edit Notification Preferences"
    :> (Description
          "Edit your notification preferences.\nYou first have to verify your email address to be able edit your notification preferences.\n"
        :> ("notificationPreferences"
            :> (Auth '[JWTWithSession] UserAuthenticated
                :> (ReqBody' '[Lenient, Required] '[JSON] RequestNotifications
                    :> UVerb
                         'POST
                         '[JSON]
                         '[WithStatus 200 ResponseNotifications,
                           WithStatus 400 ErrorParseBodyJson, WithStatus 401 ErrorBearerAuth,
                           WithStatus 403 (StaticText "Email address is not verified."),
                           WithStatus 500 ()])))))
AuthResult UserAuthenticated
-> Either String RequestNotifications
-> m (Union
        '[WithStatus 200 ResponseNotifications,
          WithStatus 400 ErrorParseBodyJson, WithStatus 401 ErrorBearerAuth,
          WithStatus 403 (StaticText "Email address is not verified."),
          WithStatus 500 ()])
forall (m :: * -> *) (responses :: [*]).
(MonadEmail m, MonadLogger m, MonadSeldaPool m,
 IsMember (WithStatus 200 ResponseNotifications) responses,
 IsMember (WithStatus 400 ErrorParseBodyJson) responses,
 IsMember (WithStatus 401 ErrorBearerAuth) responses,
 IsMember
   (WithStatus 403 (StaticText "Email address is not verified."))
   responses,
 IsMember (WithStatus 500 ()) responses) =>
AuthResult UserAuthenticated
-> Either String RequestNotifications -> m (Union responses)
notificationPreferences
    , routeProfile :: AsServerT m
:- (Summary "View User"
    :> (Description "Request detailed user information.\n"
        :> ("profile"
            :> (Auth '[JWTWithSession] UserAuthenticated
                :> (ReqBody' '[Lenient, Required] '[JSON] RequestProfile
                    :> UVerb
                         'POST
                         '[JSON]
                         '[WithStatus 200 ResponseProfile,
                           WithStatus 400 ErrorParseBodyJson, WithStatus 401 ErrorBearerAuth,
                           WithStatus 404 (), WithStatus 500 ()])))))
routeProfile = AsServerT m
:- (Summary "View User"
    :> (Description "Request detailed user information.\n"
        :> ("profile"
            :> (Auth '[JWTWithSession] UserAuthenticated
                :> (ReqBody' '[Lenient, Required] '[JSON] RequestProfile
                    :> UVerb
                         'POST
                         '[JSON]
                         '[WithStatus 200 ResponseProfile,
                           WithStatus 400 ErrorParseBodyJson, WithStatus 401 ErrorBearerAuth,
                           WithStatus 404 (), WithStatus 500 ()])))))
AuthResult UserAuthenticated
-> Either String RequestProfile
-> m (Union
        '[WithStatus 200 ResponseProfile,
          WithStatus 400 ErrorParseBodyJson, WithStatus 401 ErrorBearerAuth,
          WithStatus 404 (), WithStatus 500 ()])
forall (m :: * -> *) (responses :: [*]).
(MonadIO m, MonadLogger m, MonadSeldaPool m,
 IsMember (WithStatus 200 ResponseProfile) responses,
 IsMember (WithStatus 400 ErrorParseBodyJson) responses,
 IsMember (WithStatus 401 ErrorBearerAuth) responses,
 IsMember (WithStatus 404 ()) responses,
 IsMember (WithStatus 500 ()) responses) =>
AuthResult UserAuthenticated
-> Either String RequestProfile -> m (Union responses)
profile
    }

login ::
  ( MonadConfigured m
  , MonadIO m
  , MonadLogger m
  , MonadSecret m
  , MonadSeldaPool m
  , IsMember (WithStatus 200 ResponseLogin) responses
  , IsMember (WithStatus 401 ErrorBasicAuth) responses
  , IsMember (WithStatus 500 ()) responses
  ) =>
  AuthResult UserAuthenticated ->
  m (Union responses)
login :: forall (m :: * -> *) (responses :: [*]).
(MonadConfigured m, MonadIO m, MonadLogger m, MonadSecret m,
 MonadSeldaPool m,
 IsMember (WithStatus 200 ResponseLogin) responses,
 IsMember (WithStatus 401 ErrorBasicAuth) responses,
 IsMember (WithStatus 500 ()) responses) =>
AuthResult UserAuthenticated -> m (Union responses)
login AuthResult UserAuthenticated
auth =
  AuthResult UserAuthenticated
-> (UserAuthenticated -> m (Union responses))
-> m (Union responses)
forall (m :: * -> *) (responses :: [*]) a.
(MonadLogger m,
 IsMember (WithStatus 401 ErrorBasicAuth) responses) =>
AuthResult a -> (a -> m (Union responses)) -> m (Union responses)
handleAuthBasic AuthResult UserAuthenticated
auth ((UserAuthenticated -> m (Union responses)) -> m (Union responses))
-> (UserAuthenticated -> m (Union responses))
-> m (Union responses)
forall a b. (a -> b) -> a -> b
$ \UserAuthenticated
authenticatedWithoutSession -> do
    Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Logging in user."
    UTCTime
timeCurrent <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
T.getCurrentTime
    Maybe UTCTime
maybeTimeout <- do
      Maybe Integer
durationValid <- AuthConfig -> Maybe Integer
authTimeoutSeconds (AuthConfig -> Maybe Integer)
-> (Configuration -> AuthConfig) -> Configuration -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Configuration -> AuthConfig
configAuth (Configuration -> Maybe Integer)
-> m Configuration -> m (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Configuration
forall (m :: * -> *). MonadConfigured m => m Configuration
configuration
      let maybeTimeExpiration :: Maybe UTCTime
maybeTimeExpiration =
            (NominalDiffTime -> UTCTime -> UTCTime
`T.addUTCTime` UTCTime
timeCurrent)
              (NominalDiffTime -> UTCTime)
-> Maybe NominalDiffTime -> Maybe UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pico -> NominalDiffTime
T.secondsToNominalDiffTime (Pico -> NominalDiffTime)
-> (Integer -> Pico) -> Integer -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Pico
forall a. Num a => Integer -> a
fromInteger (Integer -> NominalDiffTime)
-> Maybe Integer -> Maybe NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Integer
durationValid)
      Maybe UTCTime -> m (Maybe UTCTime)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UTCTime
maybeTimeExpiration
    Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug Text
"Creating session."
    SeldaResult IdentifierSession
seldaResult <-
      SeldaTransactionT m IdentifierSession
-> m (SeldaResult IdentifierSession)
forall a. SeldaTransactionT m a -> m (SeldaResult a)
forall (m :: * -> *) a.
MonadSeldaPool m =>
SeldaTransactionT m a -> m (SeldaResult a)
runSeldaTransactionT (SeldaTransactionT m IdentifierSession
 -> m (SeldaResult IdentifierSession))
-> SeldaTransactionT m IdentifierSession
-> m (SeldaResult IdentifierSession)
forall a b. (a -> b) -> a -> b
$
        IdentifierUser
-> UTCTime
-> Maybe UTCTime
-> SeldaTransactionT m IdentifierSession
forall (m :: * -> *).
(MonadLogger m, MonadSeldaPool m) =>
IdentifierUser
-> UTCTime
-> Maybe UTCTime
-> SeldaTransactionT m IdentifierSession
userSessionCreate (UserAuthenticated -> IdentifierUser
userAuthenticatedId UserAuthenticated
authenticatedWithoutSession) UTCTime
timeCurrent Maybe UTCTime
maybeTimeout
    WithStatus 500 ()
-> SeldaResult IdentifierSession
-> (IdentifierSession -> m (Union responses))
-> m (Union responses)
forall r (m :: * -> *) (responses :: [*]) a.
(HasStatus r, MonadLogger m, IsMember r responses) =>
r
-> SeldaResult a
-> (a -> m (Union responses))
-> m (Union responses)
handleSeldaSomeException (forall (k :: Nat) a. a -> WithStatus k a
WithStatus @500 ()) SeldaResult IdentifierSession
seldaResult ((IdentifierSession -> m (Union responses)) -> m (Union responses))
-> (IdentifierSession -> m (Union responses))
-> m (Union responses)
forall a b. (a -> b) -> a -> b
$ \IdentifierSession
sessionIdentifier -> do
      Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Created session successfully."
      let authenticatedWithSession :: UserAuthenticated
authenticatedWithSession = UserAuthenticated
authenticatedWithoutSession {userAuthenticatedSession = Just sessionIdentifier}
      Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Creating JWT for user: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (UserAuthenticated -> String
forall a. Show a => a -> String
show UserAuthenticated
authenticatedWithSession)
      Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"JWT timeout has been set: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Maybe UTCTime -> String
forall a. Show a => a -> String
show Maybe UTCTime
maybeTimeout)
      Either Error ByteString
eitherJwt <- do
        JWK
jwk <- Secrets -> JWK
secretsJwk (Secrets -> JWK) -> m Secrets -> m JWK
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Secrets
forall (m :: * -> *). MonadSecret m => m Secrets
secrets
        let jwtSettings :: JWTSettings
jwtSettings = JWK -> JWTSettings
mkJwtSettings JWK
jwk
        IO (Either Error ByteString) -> m (Either Error ByteString)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Error ByteString) -> m (Either Error ByteString))
-> IO (Either Error ByteString) -> m (Either Error ByteString)
forall a b. (a -> b) -> a -> b
$ UserAuthenticated
-> JWTSettings -> Maybe UTCTime -> IO (Either Error ByteString)
forall a.
ToJWT a =>
a -> JWTSettings -> Maybe UTCTime -> IO (Either Error ByteString)
makeJWT UserAuthenticated
authenticatedWithSession JWTSettings
jwtSettings Maybe UTCTime
maybeTimeout
      case Either Error ByteString
eitherJwt of
        Left Error
err -> do
          Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Failed to create JWT: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Error -> String
forall a. Show a => a -> String
show Error
err)
          WithStatus 500 () -> m (Union responses)
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 500 () -> m (Union responses))
-> WithStatus 500 () -> m (Union responses)
forall a b. (a -> b) -> a -> b
$ forall (k :: Nat) a. a -> WithStatus k a
WithStatus @500 ()
        Right ByteString
jwtByteString ->
          case ByteString -> Either UnicodeException Text
T.decodeUtf8' (ByteString -> Either UnicodeException Text)
-> ByteString -> Either UnicodeException Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B.toStrict ByteString
jwtByteString of
            Left UnicodeException
err -> do
              Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Failed to decode JWT as UTF-8: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (UnicodeException -> String
forall a. Show a => a -> String
show UnicodeException
err)
              WithStatus 500 () -> m (Union responses)
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 500 () -> m (Union responses))
-> WithStatus 500 () -> m (Union responses)
forall a b. (a -> b) -> a -> b
$ forall (k :: Nat) a. a -> WithStatus k a
WithStatus @500 ()
            Right Text
jwtText -> do
              let jwt :: Jwt
jwt = Text -> Jwt
MkJwt Text
jwtText
              Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Created JWT successfully."
              Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"User login successful."
              WithStatus 200 ResponseLogin -> m (Union responses)
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 200 ResponseLogin -> m (Union responses))
-> WithStatus 200 ResponseLogin -> m (Union responses)
forall a b. (a -> b) -> a -> b
$
                forall (k :: Nat) a. a -> WithStatus k a
WithStatus @200
                  MkResponseLogin
                    { responseLoginJwt :: Jwt
responseLoginJwt = Jwt
jwt
                    , responseLoginExpiration :: Maybe UTCTime
responseLoginExpiration = Maybe UTCTime
maybeTimeout
                    , responseLoginId :: IdentifierUser
responseLoginId = UserAuthenticated -> IdentifierUser
userAuthenticatedId UserAuthenticated
authenticatedWithSession
                    }

logout ::
  ( MonadConfigured m
  , MonadLogger m
  , MonadSeldaPool m
  , IsMember (WithStatus 200 ResponseLogout) responses
  , IsMember (WithStatus 401 ErrorBearerAuth) responses
  , IsMember (WithStatus 500 ()) responses
  ) =>
  AuthResult UserAuthenticated ->
  m (Union responses)
logout :: forall (m :: * -> *) (responses :: [*]).
(MonadConfigured m, MonadLogger m, MonadSeldaPool m,
 IsMember (WithStatus 200 ResponseLogout) responses,
 IsMember (WithStatus 401 ErrorBearerAuth) responses,
 IsMember (WithStatus 500 ()) responses) =>
AuthResult UserAuthenticated -> m (Union responses)
logout AuthResult UserAuthenticated
auth =
  AuthResult UserAuthenticated
-> (UserAuthenticated -> m (Union responses))
-> m (Union responses)
forall (m :: * -> *) (responses :: [*]) a.
(MonadLogger m,
 IsMember (WithStatus 401 ErrorBearerAuth) responses) =>
AuthResult a -> (a -> m (Union responses)) -> m (Union responses)
handleAuthBearer AuthResult UserAuthenticated
auth ((UserAuthenticated -> m (Union responses)) -> m (Union responses))
-> (UserAuthenticated -> m (Union responses))
-> m (Union responses)
forall a b. (a -> b) -> a -> b
$ \UserAuthenticated
authenticated -> do
    Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Logging out user."
    case UserAuthenticated -> Maybe IdentifierSession
userAuthenticatedSession UserAuthenticated
authenticated of
      Maybe IdentifierSession
Nothing -> do
        Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logWarn Text
"Tried to logout even though there is no session associated with this authentication."
        WithStatus 500 () -> m (Union responses)
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 500 () -> m (Union responses))
-> WithStatus 500 () -> m (Union responses)
forall a b. (a -> b) -> a -> b
$ forall (k :: Nat) a. a -> WithStatus k a
WithStatus @500 ()
      Just IdentifierSession
sessionIdentifier -> do
        Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Deleting session: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (IdentifierSession -> String
forall a. Show a => a -> String
show IdentifierSession
sessionIdentifier)
        SeldaResult ()
seldaResult <-
          SeldaTransactionT m () -> m (SeldaResult ())
forall a. SeldaTransactionT m a -> m (SeldaResult a)
forall (m :: * -> *) a.
MonadSeldaPool m =>
SeldaTransactionT m a -> m (SeldaResult a)
runSeldaTransactionT (SeldaTransactionT m () -> m (SeldaResult ()))
-> SeldaTransactionT m () -> m (SeldaResult ())
forall a b. (a -> b) -> a -> b
$
            IdentifierSession -> SeldaTransactionT m ()
forall (m :: * -> *).
(MonadLogger m, MonadSeldaPool m) =>
IdentifierSession -> SeldaTransactionT m ()
userSessionDelete IdentifierSession
sessionIdentifier
        WithStatus 500 ()
-> SeldaResult ()
-> (() -> m (Union responses))
-> m (Union responses)
forall r (m :: * -> *) (responses :: [*]) a.
(HasStatus r, MonadLogger m, IsMember r responses) =>
r
-> SeldaResult a
-> (a -> m (Union responses))
-> m (Union responses)
handleSeldaSomeException (forall (k :: Nat) a. a -> WithStatus k a
WithStatus @500 ()) SeldaResult ()
seldaResult ((() -> m (Union responses)) -> m (Union responses))
-> (() -> m (Union responses)) -> m (Union responses)
forall a b. (a -> b) -> a -> b
$ \() -> do
          Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"User logged out successfully."
          WithStatus 200 ResponseLogout -> m (Union responses)
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 200 ResponseLogout -> m (Union responses))
-> WithStatus 200 ResponseLogout -> m (Union responses)
forall a b. (a -> b) -> a -> b
$
            forall (k :: Nat) a. a -> WithStatus k a
WithStatus @200
              MkResponseLogout
                { responseLogoutUnit :: ()
responseLogoutUnit = ()
                }

register ::
  ( MonadConfigured m
  , MonadEmail m
  , MonadIO m
  , MonadLogger m
  , MonadSeldaPool m
  , IsMember (WithStatus 201 ResponseRegister) responses
  , IsMember (WithStatus 400 ErrorParseBodyJson) responses
  , IsMember (WithStatus 409 (StaticText "Username is taken.")) responses
  , IsMember (WithStatus 500 ()) responses
  ) =>
  Either String RequestRegister ->
  m (Union responses)
register :: forall (m :: * -> *) (responses :: [*]).
(MonadConfigured m, MonadEmail m, MonadIO m, MonadLogger m,
 MonadSeldaPool m,
 IsMember (WithStatus 201 ResponseRegister) responses,
 IsMember (WithStatus 400 ErrorParseBodyJson) responses,
 IsMember
   (WithStatus 409 (StaticText "Username is taken.")) responses,
 IsMember (WithStatus 500 ()) responses) =>
Either String RequestRegister -> m (Union responses)
register Either String RequestRegister
eitherRequest =
  case Either String RequestRegister
eitherRequest of
    Left String
err -> do
      Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Failed to parse request: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String -> String
forall a. Show a => a -> String
show String
err)
      WithStatus 400 ErrorParseBodyJson -> m (Union responses)
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 400 ErrorParseBodyJson -> m (Union responses))
-> WithStatus 400 ErrorParseBodyJson -> m (Union responses)
forall a b. (a -> b) -> a -> b
$ forall (k :: Nat) a. a -> WithStatus k a
WithStatus @400 (ErrorParseBodyJson -> WithStatus 400 ErrorParseBodyJson)
-> ErrorParseBodyJson -> WithStatus 400 ErrorParseBodyJson
forall a b. (a -> b) -> a -> b
$ String -> ErrorParseBodyJson
MkErrorParseBodyJson String
err
    Right request :: RequestRegister
request@MkRequestRegister {Username
requestRegisterName :: Username
requestRegisterName :: RequestRegister -> Username
requestRegisterName, Password
requestRegisterPassword :: Password
requestRegisterPassword :: RequestRegister -> Password
requestRegisterPassword, EmailAddress
requestRegisterEmail :: EmailAddress
requestRegisterEmail :: RequestRegister -> EmailAddress
requestRegisterEmail, Bool
requestRegisterEmailVisible :: Bool
requestRegisterEmailVisible :: RequestRegister -> Bool
requestRegisterEmailVisible, Bool
requestRegisterEmailNotifications :: Bool
requestRegisterEmailNotifications :: RequestRegister -> Bool
requestRegisterEmailNotifications} -> do
      Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Registering new user: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (RequestRegister -> String
forall a. Show a => a -> String
show RequestRegister
request)
      SeldaResult ConfirmationSecret
seldaResult <-
        SeldaTransactionT m ConfirmationSecret
-> m (SeldaResult ConfirmationSecret)
forall a. SeldaTransactionT m a -> m (SeldaResult a)
forall (m :: * -> *) a.
MonadSeldaPool m =>
SeldaTransactionT m a -> m (SeldaResult a)
runSeldaTransactionT (SeldaTransactionT m ConfirmationSecret
 -> m (SeldaResult ConfirmationSecret))
-> SeldaTransactionT m ConfirmationSecret
-> m (SeldaResult ConfirmationSecret)
forall a b. (a -> b) -> a -> b
$ do
          IdentifierUser
userIdentifier <-
            Username
-> Password
-> EmailAddress
-> Bool
-> Bool
-> SeldaTransactionT m IdentifierUser
forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadSeldaPool m) =>
Username
-> Password
-> EmailAddress
-> Bool
-> Bool
-> SeldaTransactionT m IdentifierUser
userCreate
              Username
requestRegisterName
              (Text -> Password
Bcrypt.mkPassword (Text -> Password) -> Text -> Password
forall a b. (a -> b) -> a -> b
$ Password -> Text
unPassword Password
requestRegisterPassword)
              EmailAddress
requestRegisterEmail
              Bool
requestRegisterEmailVisible
              Bool
requestRegisterEmailNotifications
          let effect :: ConfirmationEffect
effect = EmailAddress -> ConfirmationEffect
MkConfirmationEffectEmailValidation EmailAddress
requestRegisterEmail
          UTCTime
expirationTime <- m UTCTime -> SeldaTransactionT m UTCTime
forall (m :: * -> *) a. Monad m => m a -> SeldaTransactionT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m UTCTime -> SeldaTransactionT m UTCTime)
-> (IO UTCTime -> m UTCTime)
-> IO UTCTime
-> SeldaTransactionT m UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> SeldaTransactionT m UTCTime)
-> IO UTCTime -> SeldaTransactionT m UTCTime
forall a b. (a -> b) -> a -> b
$ (Pico -> NominalDiffTime
T.secondsToNominalDiffTime (Pico
60 Pico -> Pico -> Pico
forall a. Num a => a -> a -> a
* Pico
60) `T.addUTCTime`) (UTCTime -> UTCTime) -> IO UTCTime -> IO UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
T.getCurrentTime
          IdentifierUser
-> ConfirmationEffect
-> UTCTime
-> SeldaTransactionT m ConfirmationSecret
forall (m :: * -> *).
(MonadLogger m, MonadSeldaPool m) =>
IdentifierUser
-> ConfirmationEffect
-> UTCTime
-> SeldaTransactionT m ConfirmationSecret
userConfirmationCreate IdentifierUser
userIdentifier ConfirmationEffect
effect UTCTime
expirationTime
      Proxy SqlErrorMensamUsernameIsTaken
-> WithStatus 409 (StaticText "Username is taken.")
-> SeldaResult ConfirmationSecret
-> (SeldaResult ConfirmationSecret -> m (Union responses))
-> m (Union responses)
forall e r (m :: * -> *) (responses :: [*]) a.
(Exception e, HasStatus r, Applicative m, IsMember r responses) =>
Proxy e
-> r
-> SeldaResult a
-> (SeldaResult a -> m (Union responses))
-> m (Union responses)
handleSeldaException
        (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @SqlErrorMensamUsernameIsTaken)
        (forall (k :: Nat) a. a -> WithStatus k a
WithStatus @409 (StaticText "Username is taken."
 -> WithStatus 409 (StaticText "Username is taken."))
-> StaticText "Username is taken."
-> WithStatus 409 (StaticText "Username is taken.")
forall a b. (a -> b) -> a -> b
$ forall (text :: Symbol). StaticText text
MkStaticText @"Username is taken.")
        SeldaResult ConfirmationSecret
seldaResult
        ((SeldaResult ConfirmationSecret -> m (Union responses))
 -> m (Union responses))
-> (SeldaResult ConfirmationSecret -> m (Union responses))
-> m (Union responses)
forall a b. (a -> b) -> a -> b
$ \SeldaResult ConfirmationSecret
seldaResultAfter409 -> do
          WithStatus 500 ()
-> SeldaResult ConfirmationSecret
-> (ConfirmationSecret -> m (Union responses))
-> m (Union responses)
forall r (m :: * -> *) (responses :: [*]) a.
(HasStatus r, MonadLogger m, IsMember r responses) =>
r
-> SeldaResult a
-> (a -> m (Union responses))
-> m (Union responses)
handleSeldaSomeException (forall (k :: Nat) a. a -> WithStatus k a
WithStatus @500 ()) SeldaResult ConfirmationSecret
seldaResultAfter409 ((ConfirmationSecret -> m (Union responses))
 -> m (Union responses))
-> (ConfirmationSecret -> m (Union responses))
-> m (Union responses)
forall a b. (a -> b) -> a -> b
$ \ConfirmationSecret
confirmationSecret -> do
            Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Registered new user."
            Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug Text
"Sending confirmation email."
            Configuration
config <- m Configuration
forall (m :: * -> *). MonadConfigured m => m Configuration
configuration
            SendEmailResult
sendEmailResult <-
              Email -> m SendEmailResult
forall (m :: * -> *). MonadEmail m => Email -> m SendEmailResult
sendEmail
                MkEmail
                  { emailRecipient :: EmailAddress
emailRecipient = EmailAddress
requestRegisterEmail
                  , emailTitle :: Text
emailTitle = Text
"Account Verification: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Username -> Text
unUsername Username
requestRegisterName
                  , emailBodyHtml :: Text
emailBodyHtml = Text -> Text
TL.toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Markup -> Text
T.renderHtml (Markup -> Text) -> Markup -> Text
forall a b. (a -> b) -> a -> b
$ Markup -> Markup
H.docTypeHtml (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ do
                      Markup -> Markup
H.head (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ do
                        Markup -> Markup
H.title (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Text -> Markup
H.text (Text -> Markup) -> Text -> Markup
forall a b. (a -> b) -> a -> b
$ Text
"Account Verification: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Username -> Text
unUsername Username
requestRegisterName
                      Markup -> Markup
H.body (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ do
                        Markup -> Markup
H.p (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Text -> Markup
H.text (Text -> Markup) -> Text -> Markup
forall a b. (a -> b) -> a -> b
$ Text
"Welcome " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Username -> Text
unUsername Username
requestRegisterName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"!"
                        Markup -> Markup
H.p (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Text -> Markup
H.text Text
"You have been registered successfully. Click the link to confirm your email address."
                        let Text
confirmLink :: T.Text = BaseUrl -> Text
displayBaseUrl (Configuration -> BaseUrl
configBaseUrl Configuration
config) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"register/confirm/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ConfirmationSecret -> Text
unConfirmationSecret ConfirmationSecret
confirmationSecret
                        Markup -> Markup
H.p (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Markup -> Markup
H.a (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
H.A.href (Text -> AttributeValue
H.textValue Text
confirmLink) (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Text -> Markup
H.text Text
confirmLink
                        Markup -> Markup
H.div (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Markup -> Markup
H.small (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Text -> Markup
H.text Text
"If you did not register this account, feel free to ignore this message."
                  }
            let emailSent :: Bool
emailSent =
                  case SendEmailResult
sendEmailResult of
                    SendEmailResult
EmailSent -> Bool
True
                    SendEmailResult
EmailFailedToSend -> Bool
False
            WithStatus 201 ResponseRegister -> m (Union responses)
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 201 ResponseRegister -> m (Union responses))
-> WithStatus 201 ResponseRegister -> m (Union responses)
forall a b. (a -> b) -> a -> b
$
              forall (k :: Nat) a. a -> WithStatus k a
WithStatus @201
                MkResponseRegister
                  { responseRegisterEmailSent :: Bool
responseRegisterEmailSent = Bool
emailSent
                  }

passwordChange ::
  ( MonadLogger m
  , MonadSeldaPool m
  , IsMember (WithStatus 200 ResponsePasswordChange) responses
  , IsMember (WithStatus 400 ErrorParseBodyJson) responses
  , IsMember (WithStatus 401 ErrorBearerAuth) responses
  , IsMember (WithStatus 500 ()) responses
  ) =>
  AuthResult UserAuthenticated ->
  Either String RequestPasswordChange ->
  m (Union responses)
passwordChange :: forall (m :: * -> *) (responses :: [*]).
(MonadLogger m, MonadSeldaPool m,
 IsMember (WithStatus 200 ResponsePasswordChange) responses,
 IsMember (WithStatus 400 ErrorParseBodyJson) responses,
 IsMember (WithStatus 401 ErrorBearerAuth) responses,
 IsMember (WithStatus 500 ()) responses) =>
AuthResult UserAuthenticated
-> Either String RequestPasswordChange -> m (Union responses)
passwordChange AuthResult UserAuthenticated
auth Either String RequestPasswordChange
eitherRequest =
  AuthResult UserAuthenticated
-> (UserAuthenticated -> m (Union responses))
-> m (Union responses)
forall (m :: * -> *) (responses :: [*]) a.
(MonadLogger m,
 IsMember (WithStatus 401 ErrorBearerAuth) responses) =>
AuthResult a -> (a -> m (Union responses)) -> m (Union responses)
handleAuthBearer AuthResult UserAuthenticated
auth ((UserAuthenticated -> m (Union responses)) -> m (Union responses))
-> (UserAuthenticated -> m (Union responses))
-> m (Union responses)
forall a b. (a -> b) -> a -> b
$ \UserAuthenticated
authenticated ->
    Either String RequestPasswordChange
-> (RequestPasswordChange -> m (Union responses))
-> m (Union responses)
forall (m :: * -> *) (responses :: [*]) a.
(MonadLogger m,
 IsMember (WithStatus 400 ErrorParseBodyJson) responses) =>
Either String a
-> (a -> m (Union responses)) -> m (Union responses)
handleBadRequestBody Either String RequestPasswordChange
eitherRequest ((RequestPasswordChange -> m (Union responses))
 -> m (Union responses))
-> (RequestPasswordChange -> m (Union responses))
-> m (Union responses)
forall a b. (a -> b) -> a -> b
$ \RequestPasswordChange
request -> do
      Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Changing user password."
      SeldaResult ()
seldaResult <-
        SeldaTransactionT m () -> m (SeldaResult ())
forall a. SeldaTransactionT m a -> m (SeldaResult a)
forall (m :: * -> *) a.
MonadSeldaPool m =>
SeldaTransactionT m a -> m (SeldaResult a)
runSeldaTransactionT (SeldaTransactionT m () -> m (SeldaResult ()))
-> SeldaTransactionT m () -> m (SeldaResult ())
forall a b. (a -> b) -> a -> b
$
          IdentifierUser -> Password -> SeldaTransactionT m ()
forall (m :: * -> *).
(MonadLogger m, MonadSeldaPool m) =>
IdentifierUser -> Password -> SeldaTransactionT m ()
userSetPassword
            (UserAuthenticated -> IdentifierUser
userAuthenticatedId UserAuthenticated
authenticated)
            (Text -> Password
Bcrypt.mkPassword (Text -> Password) -> Text -> Password
forall a b. (a -> b) -> a -> b
$ Password -> Text
unPassword (Password -> Text) -> Password -> Text
forall a b. (a -> b) -> a -> b
$ RequestPasswordChange -> Password
requestPasswordChangeNewPassword RequestPasswordChange
request)
      WithStatus 500 ()
-> SeldaResult ()
-> (() -> m (Union responses))
-> m (Union responses)
forall r (m :: * -> *) (responses :: [*]) a.
(HasStatus r, MonadLogger m, IsMember r responses) =>
r
-> SeldaResult a
-> (a -> m (Union responses))
-> m (Union responses)
handleSeldaSomeException (forall (k :: Nat) a. a -> WithStatus k a
WithStatus @500 ()) SeldaResult ()
seldaResult ((() -> m (Union responses)) -> m (Union responses))
-> (() -> m (Union responses)) -> m (Union responses)
forall a b. (a -> b) -> a -> b
$ \() -> do
        Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Changed user password successfully."
        WithStatus 200 ResponsePasswordChange -> m (Union responses)
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 200 ResponsePasswordChange -> m (Union responses))
-> WithStatus 200 ResponsePasswordChange -> m (Union responses)
forall a b. (a -> b) -> a -> b
$ forall (k :: Nat) a. a -> WithStatus k a
WithStatus @200 MkResponsePasswordChange {responsePasswordChangeUnit :: ()
responsePasswordChangeUnit = ()}

pictureUpload ::
  ( MonadLogger m
  , MonadSeldaPool m
  , IsMember (WithStatus 200 (StaticText "Uploaded profile picture.")) responses
  , IsMember (WithStatus 400 ErrorParseBodyJpeg) responses
  , IsMember (WithStatus 401 ErrorBearerAuth) responses
  , IsMember (WithStatus 500 ()) responses
  ) =>
  AuthResult UserAuthenticated ->
  Either String ImageJpegBytes ->
  m (Union responses)
pictureUpload :: forall (m :: * -> *) (responses :: [*]).
(MonadLogger m, MonadSeldaPool m,
 IsMember
   (WithStatus 200 (StaticText "Uploaded profile picture."))
   responses,
 IsMember (WithStatus 400 ErrorParseBodyJpeg) responses,
 IsMember (WithStatus 401 ErrorBearerAuth) responses,
 IsMember (WithStatus 500 ()) responses) =>
AuthResult UserAuthenticated
-> Either String ImageJpegBytes -> m (Union responses)
pictureUpload AuthResult UserAuthenticated
auth Either String ImageJpegBytes
eitherRequest =
  AuthResult UserAuthenticated
-> (UserAuthenticated -> m (Union responses))
-> m (Union responses)
forall (m :: * -> *) (responses :: [*]) a.
(MonadLogger m,
 IsMember (WithStatus 401 ErrorBearerAuth) responses) =>
AuthResult a -> (a -> m (Union responses)) -> m (Union responses)
handleAuthBearer AuthResult UserAuthenticated
auth ((UserAuthenticated -> m (Union responses)) -> m (Union responses))
-> (UserAuthenticated -> m (Union responses))
-> m (Union responses)
forall a b. (a -> b) -> a -> b
$ \UserAuthenticated
authenticated ->
    Either String ImageJpegBytes
-> (ImageJpegBytes -> m (Union responses)) -> m (Union responses)
forall (m :: * -> *) (responses :: [*]) a.
(MonadLogger m,
 IsMember (WithStatus 400 ErrorParseBodyJpeg) responses) =>
Either String a
-> (a -> m (Union responses)) -> m (Union responses)
handleBadRequestBodyJpeg Either String ImageJpegBytes
eitherRequest ((ImageJpegBytes -> m (Union responses)) -> m (Union responses))
-> (ImageJpegBytes -> m (Union responses)) -> m (Union responses)
forall a b. (a -> b) -> a -> b
$ \ImageJpegBytes
request -> do
      Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Changing profile picture."
      case ImageJpegBytes -> Either String ByteStringJpeg
jpegConvertProfilePicture ImageJpegBytes
request of
        Left String
err -> do
          Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logWarn (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Failed to resize picture: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String -> String
forall a. Show a => a -> String
show String
err)
          WithStatus 400 ErrorParseBodyJpeg -> m (Union responses)
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 400 ErrorParseBodyJpeg -> m (Union responses))
-> WithStatus 400 ErrorParseBodyJpeg -> m (Union responses)
forall a b. (a -> b) -> a -> b
$ forall (k :: Nat) a. a -> WithStatus k a
WithStatus @400 (ErrorParseBodyJpeg -> WithStatus 400 ErrorParseBodyJpeg)
-> ErrorParseBodyJpeg -> WithStatus 400 ErrorParseBodyJpeg
forall a b. (a -> b) -> a -> b
$ String -> ErrorParseBodyJpeg
MkErrorParseBodyJpeg String
"Unable to read picture."
        Right ByteStringJpeg
picture -> do
          Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Successfully verified and potentially resized picture."
          SeldaResult ()
seldaResult <-
            SeldaTransactionT m () -> m (SeldaResult ())
forall a. SeldaTransactionT m a -> m (SeldaResult a)
forall (m :: * -> *) a.
MonadSeldaPool m =>
SeldaTransactionT m a -> m (SeldaResult a)
runSeldaTransactionT (SeldaTransactionT m () -> m (SeldaResult ()))
-> SeldaTransactionT m () -> m (SeldaResult ())
forall a b. (a -> b) -> a -> b
$
              IdentifierUser -> Maybe ByteStringJpeg -> SeldaTransactionT m ()
forall (m :: * -> *).
(MonadLogger m, MonadSeldaPool m) =>
IdentifierUser -> Maybe ByteStringJpeg -> SeldaTransactionT m ()
userSetPicture (UserAuthenticated -> IdentifierUser
userAuthenticatedId UserAuthenticated
authenticated) (ByteStringJpeg -> Maybe ByteStringJpeg
forall a. a -> Maybe a
Just ByteStringJpeg
picture)
          WithStatus 500 ()
-> SeldaResult ()
-> (() -> m (Union responses))
-> m (Union responses)
forall r (m :: * -> *) (responses :: [*]) a.
(HasStatus r, MonadLogger m, IsMember r responses) =>
r
-> SeldaResult a
-> (a -> m (Union responses))
-> m (Union responses)
handleSeldaSomeException (forall (k :: Nat) a. a -> WithStatus k a
WithStatus @500 ()) SeldaResult ()
seldaResult ((() -> m (Union responses)) -> m (Union responses))
-> (() -> m (Union responses)) -> m (Union responses)
forall a b. (a -> b) -> a -> b
$ \() -> do
            Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Changed profile picture successfully."
            WithStatus 200 (StaticText "Uploaded profile picture.")
-> m (Union responses)
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 200 (StaticText "Uploaded profile picture.")
 -> m (Union responses))
-> WithStatus 200 (StaticText "Uploaded profile picture.")
-> m (Union responses)
forall a b. (a -> b) -> a -> b
$ forall (k :: Nat) a. a -> WithStatus k a
WithStatus @200 (StaticText "Uploaded profile picture."
 -> WithStatus 200 (StaticText "Uploaded profile picture."))
-> StaticText "Uploaded profile picture."
-> WithStatus 200 (StaticText "Uploaded profile picture.")
forall a b. (a -> b) -> a -> b
$ forall (text :: Symbol). StaticText text
MkStaticText @"Uploaded profile picture."

pictureDelete ::
  ( MonadLogger m
  , MonadSeldaPool m
  , IsMember (WithStatus 200 (StaticText "Deleted profile picture.")) responses
  , IsMember (WithStatus 401 ErrorBearerAuth) responses
  , IsMember (WithStatus 500 ()) responses
  ) =>
  AuthResult UserAuthenticated ->
  m (Union responses)
pictureDelete :: forall (m :: * -> *) (responses :: [*]).
(MonadLogger m, MonadSeldaPool m,
 IsMember
   (WithStatus 200 (StaticText "Deleted profile picture.")) responses,
 IsMember (WithStatus 401 ErrorBearerAuth) responses,
 IsMember (WithStatus 500 ()) responses) =>
AuthResult UserAuthenticated -> m (Union responses)
pictureDelete AuthResult UserAuthenticated
auth =
  AuthResult UserAuthenticated
-> (UserAuthenticated -> m (Union responses))
-> m (Union responses)
forall (m :: * -> *) (responses :: [*]) a.
(MonadLogger m,
 IsMember (WithStatus 401 ErrorBearerAuth) responses) =>
AuthResult a -> (a -> m (Union responses)) -> m (Union responses)
handleAuthBearer AuthResult UserAuthenticated
auth ((UserAuthenticated -> m (Union responses)) -> m (Union responses))
-> (UserAuthenticated -> m (Union responses))
-> m (Union responses)
forall a b. (a -> b) -> a -> b
$ \UserAuthenticated
authenticated -> do
    Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Deleting profile picture."
    SeldaResult ()
seldaResult <-
      SeldaTransactionT m () -> m (SeldaResult ())
forall a. SeldaTransactionT m a -> m (SeldaResult a)
forall (m :: * -> *) a.
MonadSeldaPool m =>
SeldaTransactionT m a -> m (SeldaResult a)
runSeldaTransactionT (SeldaTransactionT m () -> m (SeldaResult ()))
-> SeldaTransactionT m () -> m (SeldaResult ())
forall a b. (a -> b) -> a -> b
$
        IdentifierUser -> Maybe ByteStringJpeg -> SeldaTransactionT m ()
forall (m :: * -> *).
(MonadLogger m, MonadSeldaPool m) =>
IdentifierUser -> Maybe ByteStringJpeg -> SeldaTransactionT m ()
userSetPicture (UserAuthenticated -> IdentifierUser
userAuthenticatedId UserAuthenticated
authenticated) Maybe ByteStringJpeg
forall a. Maybe a
Nothing
    WithStatus 500 ()
-> SeldaResult ()
-> (() -> m (Union responses))
-> m (Union responses)
forall r (m :: * -> *) (responses :: [*]) a.
(HasStatus r, MonadLogger m, IsMember r responses) =>
r
-> SeldaResult a
-> (a -> m (Union responses))
-> m (Union responses)
handleSeldaSomeException (forall (k :: Nat) a. a -> WithStatus k a
WithStatus @500 ()) SeldaResult ()
seldaResult ((() -> m (Union responses)) -> m (Union responses))
-> (() -> m (Union responses)) -> m (Union responses)
forall a b. (a -> b) -> a -> b
$ \() -> do
      Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Deleted profile picture successfully."
      WithStatus 200 (StaticText "Deleted profile picture.")
-> m (Union responses)
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 200 (StaticText "Deleted profile picture.")
 -> m (Union responses))
-> WithStatus 200 (StaticText "Deleted profile picture.")
-> m (Union responses)
forall a b. (a -> b) -> a -> b
$ forall (k :: Nat) a. a -> WithStatus k a
WithStatus @200 (StaticText "Deleted profile picture."
 -> WithStatus 200 (StaticText "Deleted profile picture."))
-> StaticText "Deleted profile picture."
-> WithStatus 200 (StaticText "Deleted profile picture.")
forall a b. (a -> b) -> a -> b
$ forall (text :: Symbol). StaticText text
MkStaticText @"Deleted profile picture."

pictureDownload ::
  ( MonadConfigured m
  , MonadIO m
  , MonadLogger m
  , MonadSeldaPool m
  ) =>
  AuthResult UserAuthenticated ->
  Either T.Text IdentifierUser ->
  m ImageJpegBytes
pictureDownload :: forall (m :: * -> *).
(MonadConfigured m, MonadIO m, MonadLogger m, MonadSeldaPool m) =>
AuthResult UserAuthenticated
-> Either Text IdentifierUser -> m ImageJpegBytes
pictureDownload AuthResult UserAuthenticated
auth Either Text IdentifierUser
eitherQueryParamIdentifierUser = do
  Union
  '[WithStatus 401 ErrorBearerAuth, WithStatus 500 (),
    WithStatus 400 Text, WithStatus 200 ImageJpegBytes]
handledResult <- do
    AuthResult UserAuthenticated
-> (UserAuthenticated
    -> m (Union
            '[WithStatus 401 ErrorBearerAuth, WithStatus 500 (),
              WithStatus 400 Text, WithStatus 200 ImageJpegBytes]))
-> m (Union
        '[WithStatus 401 ErrorBearerAuth, WithStatus 500 (),
          WithStatus 400 Text, WithStatus 200 ImageJpegBytes])
forall (m :: * -> *) (responses :: [*]) a.
(MonadLogger m,
 IsMember (WithStatus 401 ErrorBearerAuth) responses) =>
AuthResult a -> (a -> m (Union responses)) -> m (Union responses)
handleAuthBearer AuthResult UserAuthenticated
auth ((UserAuthenticated
  -> m (Union
          '[WithStatus 401 ErrorBearerAuth, WithStatus 500 (),
            WithStatus 400 Text, WithStatus 200 ImageJpegBytes]))
 -> m (Union
         '[WithStatus 401 ErrorBearerAuth, WithStatus 500 (),
           WithStatus 400 Text, WithStatus 200 ImageJpegBytes]))
-> (UserAuthenticated
    -> m (Union
            '[WithStatus 401 ErrorBearerAuth, WithStatus 500 (),
              WithStatus 400 Text, WithStatus 200 ImageJpegBytes]))
-> m (Union
        '[WithStatus 401 ErrorBearerAuth, WithStatus 500 (),
          WithStatus 400 Text, WithStatus 200 ImageJpegBytes])
forall a b. (a -> b) -> a -> b
$ \UserAuthenticated
_ -> do
      case Either Text IdentifierUser
eitherQueryParamIdentifierUser of
        Left Text
err -> do
          Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Unable to parse user identifier."
          WithStatus 400 Text
-> m (Union
        '[WithStatus 401 ErrorBearerAuth, WithStatus 500 (),
          WithStatus 400 Text, WithStatus 200 ImageJpegBytes])
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 400 Text
 -> m (Union
         '[WithStatus 401 ErrorBearerAuth, WithStatus 500 (),
           WithStatus 400 Text, WithStatus 200 ImageJpegBytes]))
-> WithStatus 400 Text
-> m (Union
        '[WithStatus 401 ErrorBearerAuth, WithStatus 500 (),
          WithStatus 400 Text, WithStatus 200 ImageJpegBytes])
forall a b. (a -> b) -> a -> b
$ forall (k :: Nat) a. a -> WithStatus k a
WithStatus @400 Text
err -- TODO: Handle with proper type for error. `ErrorBadQueryParam`
        Right IdentifierUser
identifierUser -> do
          Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Requesting a profile picture from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (IdentifierUser -> String
forall a. Show a => a -> String
show IdentifierUser
identifierUser)
          SeldaResult (Maybe ByteStringJpeg)
seldaResult <-
            SeldaTransactionT m (Maybe ByteStringJpeg)
-> m (SeldaResult (Maybe ByteStringJpeg))
forall a. SeldaTransactionT m a -> m (SeldaResult a)
forall (m :: * -> *) a.
MonadSeldaPool m =>
SeldaTransactionT m a -> m (SeldaResult a)
runSeldaTransactionT (SeldaTransactionT m (Maybe ByteStringJpeg)
 -> m (SeldaResult (Maybe ByteStringJpeg)))
-> SeldaTransactionT m (Maybe ByteStringJpeg)
-> m (SeldaResult (Maybe ByteStringJpeg))
forall a b. (a -> b) -> a -> b
$
              IdentifierUser -> SeldaTransactionT m (Maybe ByteStringJpeg)
forall (m :: * -> *).
(MonadLogger m, MonadSeldaPool m) =>
IdentifierUser -> SeldaTransactionT m (Maybe ByteStringJpeg)
userGetPicture IdentifierUser
identifierUser
          WithStatus 500 ()
-> SeldaResult (Maybe ByteStringJpeg)
-> (Maybe ByteStringJpeg
    -> m (Union
            '[WithStatus 401 ErrorBearerAuth, WithStatus 500 (),
              WithStatus 400 Text, WithStatus 200 ImageJpegBytes]))
-> m (Union
        '[WithStatus 401 ErrorBearerAuth, WithStatus 500 (),
          WithStatus 400 Text, WithStatus 200 ImageJpegBytes])
forall r (m :: * -> *) (responses :: [*]) a.
(HasStatus r, MonadLogger m, IsMember r responses) =>
r
-> SeldaResult a
-> (a -> m (Union responses))
-> m (Union responses)
handleSeldaSomeException (forall (k :: Nat) a. a -> WithStatus k a
WithStatus @500 ()) SeldaResult (Maybe ByteStringJpeg)
seldaResult ((Maybe ByteStringJpeg
  -> m (Union
          '[WithStatus 401 ErrorBearerAuth, WithStatus 500 (),
            WithStatus 400 Text, WithStatus 200 ImageJpegBytes]))
 -> m (Union
         '[WithStatus 401 ErrorBearerAuth, WithStatus 500 (),
           WithStatus 400 Text, WithStatus 200 ImageJpegBytes]))
-> (Maybe ByteStringJpeg
    -> m (Union
            '[WithStatus 401 ErrorBearerAuth, WithStatus 500 (),
              WithStatus 400 Text, WithStatus 200 ImageJpegBytes]))
-> m (Union
        '[WithStatus 401 ErrorBearerAuth, WithStatus 500 (),
          WithStatus 400 Text, WithStatus 200 ImageJpegBytes])
forall a b. (a -> b) -> a -> b
$ \Maybe ByteStringJpeg
maybePicture -> do
            Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Checked out profile picture successfully."
            case Maybe ByteStringJpeg
maybePicture of
              Maybe ByteStringJpeg
Nothing -> do
                Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"No profile picture set for this user. Returning default picture."
                String
defaultProfilePictureFilePath <- (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/default-profile-picture.jpeg") (String -> String)
-> (Configuration -> String) -> Configuration -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Configuration -> String
configDirectoryStatic (Configuration -> String) -> m Configuration -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Configuration
forall (m :: * -> *). MonadConfigured m => m Configuration
configuration
                ByteString
picture <- IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
B.readFile String
defaultProfilePictureFilePath
                WithStatus 200 ImageJpegBytes
-> m (Union
        '[WithStatus 401 ErrorBearerAuth, WithStatus 500 (),
          WithStatus 400 Text, WithStatus 200 ImageJpegBytes])
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 200 ImageJpegBytes
 -> m (Union
         '[WithStatus 401 ErrorBearerAuth, WithStatus 500 (),
           WithStatus 400 Text, WithStatus 200 ImageJpegBytes]))
-> WithStatus 200 ImageJpegBytes
-> m (Union
        '[WithStatus 401 ErrorBearerAuth, WithStatus 500 (),
          WithStatus 400 Text, WithStatus 200 ImageJpegBytes])
forall a b. (a -> b) -> a -> b
$ forall (k :: Nat) a. a -> WithStatus k a
WithStatus @200 (ImageJpegBytes -> WithStatus 200 ImageJpegBytes)
-> ImageJpegBytes -> WithStatus 200 ImageJpegBytes
forall a b. (a -> b) -> a -> b
$ ByteString -> ImageJpegBytes
MkImageJpegBytes (ByteString -> ImageJpegBytes)
-> (ByteString -> ByteString) -> ByteString -> ImageJpegBytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B.fromStrict (ByteString -> ImageJpegBytes) -> ByteString -> ImageJpegBytes
forall a b. (a -> b) -> a -> b
$ ByteString
picture
              Just ByteStringJpeg
picture -> do
                Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Answering with profile picture."
                WithStatus 200 ImageJpegBytes
-> m (Union
        '[WithStatus 401 ErrorBearerAuth, WithStatus 500 (),
          WithStatus 400 Text, WithStatus 200 ImageJpegBytes])
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 200 ImageJpegBytes
 -> m (Union
         '[WithStatus 401 ErrorBearerAuth, WithStatus 500 (),
           WithStatus 400 Text, WithStatus 200 ImageJpegBytes]))
-> WithStatus 200 ImageJpegBytes
-> m (Union
        '[WithStatus 401 ErrorBearerAuth, WithStatus 500 (),
          WithStatus 400 Text, WithStatus 200 ImageJpegBytes])
forall a b. (a -> b) -> a -> b
$ forall (k :: Nat) a. a -> WithStatus k a
WithStatus @200 (ImageJpegBytes -> WithStatus 200 ImageJpegBytes)
-> ImageJpegBytes -> WithStatus 200 ImageJpegBytes
forall a b. (a -> b) -> a -> b
$ ByteString -> ImageJpegBytes
MkImageJpegBytes (ByteString -> ImageJpegBytes)
-> (ByteStringJpeg -> ByteString)
-> ByteStringJpeg
-> ImageJpegBytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteStringJpeg -> ByteString
unByteStringJpeg (ByteStringJpeg -> ImageJpegBytes)
-> ByteStringJpeg -> ImageJpegBytes
forall a b. (a -> b) -> a -> b
$ ByteStringJpeg
picture
  Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Handling multi-mimetype response manually: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Union
  '[WithStatus 401 ErrorBearerAuth, WithStatus 500 (),
    WithStatus 400 Text, WithStatus 200 ImageJpegBytes]
-> String
forall a. Show a => a -> String
show Union
  '[WithStatus 401 ErrorBearerAuth, WithStatus 500 (),
    WithStatus 400 Text, WithStatus 200 ImageJpegBytes]
handledResult) -- TODO: Logging pictures right now.
  -- TODO: Add all these HTTP statuses to the API definition. Requires different output types.
  case Union
  '[WithStatus 401 ErrorBearerAuth, WithStatus 500 (),
    WithStatus 400 Text, WithStatus 200 ImageJpegBytes]
handledResult :: Union [WithStatus 401 ErrorBearerAuth, WithStatus 500 (), WithStatus 400 T.Text, WithStatus 200 ImageJpegBytes] of
    SOP.Z (SOP.I (WithStatus ErrorBearerAuth
errorBearerAuth)) -> String -> m ImageJpegBytes
forall a. HasCallStack => String -> a
error (String -> m ImageJpegBytes) -> String -> m ImageJpegBytes
forall a b. (a -> b) -> a -> b
$ ErrorBearerAuth -> String
forall a. Show a => a -> String
show ErrorBearerAuth
errorBearerAuth
    SOP.S (SOP.Z (SOP.I (WithStatus ()))) -> m ImageJpegBytes
forall a. HasCallStack => a
undefined
    SOP.S (SOP.S (SOP.Z (SOP.I (WithStatus Text
errorBadQueryParam)))) -> String -> m ImageJpegBytes
forall a. HasCallStack => String -> a
error (String -> m ImageJpegBytes) -> String -> m ImageJpegBytes
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. Show a => a -> String
show Text
errorBadQueryParam
    SOP.S (SOP.S (SOP.S (SOP.Z (SOP.I (WithStatus ImageJpegBytes
result))))) -> ImageJpegBytes -> m ImageJpegBytes
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ImageJpegBytes
result
    SOP.S (SOP.S (SOP.S (SOP.S NS I xs
impossibleCase))) -> case NS I xs
impossibleCase of {}

confirmationRequest ::
  ( MonadConfigured m
  , MonadEmail m
  , MonadIO m
  , MonadLogger m
  , MonadSeldaPool m
  , IsMember (WithStatus 200 ResponseConfirmationRequest) responses
  , IsMember (WithStatus 401 ErrorBearerAuth) responses
  , IsMember (WithStatus 500 ()) responses
  ) =>
  AuthResult UserAuthenticated ->
  m (Union responses)
confirmationRequest :: forall (m :: * -> *) (responses :: [*]).
(MonadConfigured m, MonadEmail m, MonadIO m, MonadLogger m,
 MonadSeldaPool m,
 IsMember (WithStatus 200 ResponseConfirmationRequest) responses,
 IsMember (WithStatus 401 ErrorBearerAuth) responses,
 IsMember (WithStatus 500 ()) responses) =>
AuthResult UserAuthenticated -> m (Union responses)
confirmationRequest AuthResult UserAuthenticated
auth =
  AuthResult UserAuthenticated
-> (UserAuthenticated -> m (Union responses))
-> m (Union responses)
forall (m :: * -> *) (responses :: [*]) a.
(MonadLogger m,
 IsMember (WithStatus 401 ErrorBearerAuth) responses) =>
AuthResult a -> (a -> m (Union responses)) -> m (Union responses)
handleAuthBearer AuthResult UserAuthenticated
auth ((UserAuthenticated -> m (Union responses)) -> m (Union responses))
-> (UserAuthenticated -> m (Union responses))
-> m (Union responses)
forall a b. (a -> b) -> a -> b
$ \UserAuthenticated
authenticated -> do
    Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Requesting email confirmation for user: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (UserAuthenticated -> String
forall a. Show a => a -> String
show UserAuthenticated
authenticated)
    SeldaResult ()
seldaResult <- SeldaTransactionT m () -> m (SeldaResult ())
forall a. SeldaTransactionT m a -> m (SeldaResult a)
forall (m :: * -> *) a.
MonadSeldaPool m =>
SeldaTransactionT m a -> m (SeldaResult a)
runSeldaTransactionT (SeldaTransactionT m () -> m (SeldaResult ()))
-> SeldaTransactionT m () -> m (SeldaResult ())
forall a b. (a -> b) -> a -> b
$ do
      User
user <- IdentifierUser -> SeldaTransactionT m User
forall (m :: * -> *).
(MonadLogger m, MonadSeldaPool m) =>
IdentifierUser -> SeldaTransactionT m User
userGet (UserAuthenticated -> IdentifierUser
userAuthenticatedId UserAuthenticated
authenticated)
      let effect :: ConfirmationEffect
effect = EmailAddress -> ConfirmationEffect
MkConfirmationEffectEmailValidation (EmailAddress -> ConfirmationEffect)
-> EmailAddress -> ConfirmationEffect
forall a b. (a -> b) -> a -> b
$ User -> EmailAddress
userEmail User
user
      UTCTime
expirationTime <- m UTCTime -> SeldaTransactionT m UTCTime
forall (m :: * -> *) a. Monad m => m a -> SeldaTransactionT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m UTCTime -> SeldaTransactionT m UTCTime)
-> (IO UTCTime -> m UTCTime)
-> IO UTCTime
-> SeldaTransactionT m UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> SeldaTransactionT m UTCTime)
-> IO UTCTime -> SeldaTransactionT m UTCTime
forall a b. (a -> b) -> a -> b
$ (Pico -> NominalDiffTime
T.secondsToNominalDiffTime (Pico
60 Pico -> Pico -> Pico
forall a. Num a => a -> a -> a
* Pico
60) `T.addUTCTime`) (UTCTime -> UTCTime) -> IO UTCTime -> IO UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
T.getCurrentTime
      ConfirmationSecret
confirmationSecret <- IdentifierUser
-> ConfirmationEffect
-> UTCTime
-> SeldaTransactionT m ConfirmationSecret
forall (m :: * -> *).
(MonadLogger m, MonadSeldaPool m) =>
IdentifierUser
-> ConfirmationEffect
-> UTCTime
-> SeldaTransactionT m ConfirmationSecret
userConfirmationCreate (User -> IdentifierUser
userId User
user) ConfirmationEffect
effect UTCTime
expirationTime
      m () -> SeldaTransactionT m ()
forall (m :: * -> *) a. Monad m => m a -> SeldaTransactionT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> SeldaTransactionT m ()) -> m () -> SeldaTransactionT m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug Text
"Sending confirmation email."
      Configuration
config <- m Configuration -> SeldaTransactionT m Configuration
forall (m :: * -> *) a. Monad m => m a -> SeldaTransactionT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Configuration
forall (m :: * -> *). MonadConfigured m => m Configuration
configuration
      SendEmailResult
sendEmailResult <-
        m SendEmailResult -> SeldaTransactionT m SendEmailResult
forall (m :: * -> *) a. Monad m => m a -> SeldaTransactionT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m SendEmailResult -> SeldaTransactionT m SendEmailResult)
-> m SendEmailResult -> SeldaTransactionT m SendEmailResult
forall a b. (a -> b) -> a -> b
$
          Email -> m SendEmailResult
forall (m :: * -> *). MonadEmail m => Email -> m SendEmailResult
sendEmail
            MkEmail
              { emailRecipient :: EmailAddress
emailRecipient = User -> EmailAddress
userEmail User
user
              , emailTitle :: Text
emailTitle = Text
"Email Address Verification: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Username -> Text
forall a. ToPrettyText a => a -> Text
toPrettyText (User -> Username
userName User
user)
              , emailBodyHtml :: Text
emailBodyHtml = Text -> Text
TL.toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Markup -> Text
T.renderHtml (Markup -> Text) -> Markup -> Text
forall a b. (a -> b) -> a -> b
$ Markup -> Markup
H.docTypeHtml (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ do
                  Markup -> Markup
H.head (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ do
                    Markup -> Markup
H.title (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Text -> Markup
H.text Text
"Email Address Verification: " Markup -> Markup -> Markup
forall a. Semigroup a => a -> a -> a
<> Username -> Markup
forall a. ToPrettyHtml5 a => a -> Markup
toPrettyHtml5 (User -> Username
userName User
user)
                  Markup -> Markup
H.body (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ do
                    Markup -> Markup
H.p (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Text -> Markup
H.text Text
"Click the link to confirm your email address."
                    let Text
confirmLink :: T.Text = BaseUrl -> Text
displayBaseUrl (Configuration -> BaseUrl
configBaseUrl Configuration
config) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"register/confirm/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ConfirmationSecret -> Text
unConfirmationSecret ConfirmationSecret
confirmationSecret
                    Markup -> Markup
H.p (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Markup -> Markup
H.a (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
H.A.href (Text -> AttributeValue
H.textValue Text
confirmLink) (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Text -> Markup
H.text Text
confirmLink
                    Markup -> Markup
H.div (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Markup -> Markup
H.small (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Text -> Markup
H.text Text
"If you did not register this account, feel free to ignore this message."
              }
      case SendEmailResult
sendEmailResult of
        SendEmailResult
EmailSent -> m () -> SeldaTransactionT m ()
forall (m :: * -> *) a. Monad m => m a -> SeldaTransactionT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> SeldaTransactionT m ()) -> m () -> SeldaTransactionT m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug Text
"Sent confirmation email."
        SendEmailResult
EmailFailedToSend -> String -> SeldaTransactionT m ()
forall a. HasCallStack => String -> a
error String
"Failed to send email."
    WithStatus 500 ()
-> SeldaResult ()
-> (() -> m (Union responses))
-> m (Union responses)
forall r (m :: * -> *) (responses :: [*]) a.
(HasStatus r, MonadLogger m, IsMember r responses) =>
r
-> SeldaResult a
-> (a -> m (Union responses))
-> m (Union responses)
handleSeldaSomeException (forall (k :: Nat) a. a -> WithStatus k a
WithStatus @500 ()) SeldaResult ()
seldaResult ((() -> m (Union responses)) -> m (Union responses))
-> (() -> m (Union responses)) -> m (Union responses)
forall a b. (a -> b) -> a -> b
$ \() -> do
      WithStatus 200 ResponseConfirmationRequest -> m (Union responses)
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 200 ResponseConfirmationRequest -> m (Union responses))
-> WithStatus 200 ResponseConfirmationRequest
-> m (Union responses)
forall a b. (a -> b) -> a -> b
$
        forall (k :: Nat) a. a -> WithStatus k a
WithStatus @200
          MkResponseConfirmationRequest
            { responseConfirmationRequestUnit :: ()
responseConfirmationRequestUnit = ()
            }

confirm ::
  ( MonadEmail m
  , MonadIO m
  , MonadLogger m
  , MonadSeldaPool m
  , IsMember (WithStatus 200 ResponseConfirm) responses
  , IsMember (WithStatus 400 ErrorParseBodyJson) responses
  , IsMember (WithStatus 401 ErrorBearerAuth) responses
  , IsMember (WithStatus 410 ()) responses
  , IsMember (WithStatus 500 ()) responses
  ) =>
  AuthResult UserAuthenticated ->
  Either String RequestConfirm ->
  m (Union responses)
confirm :: forall (m :: * -> *) (responses :: [*]).
(MonadEmail m, MonadIO m, MonadLogger m, MonadSeldaPool m,
 IsMember (WithStatus 200 ResponseConfirm) responses,
 IsMember (WithStatus 400 ErrorParseBodyJson) responses,
 IsMember (WithStatus 401 ErrorBearerAuth) responses,
 IsMember (WithStatus 410 ()) responses,
 IsMember (WithStatus 500 ()) responses) =>
AuthResult UserAuthenticated
-> Either String RequestConfirm -> m (Union responses)
confirm AuthResult UserAuthenticated
auth Either String RequestConfirm
eitherRequest =
  AuthResult UserAuthenticated
-> (UserAuthenticated -> m (Union responses))
-> m (Union responses)
forall (m :: * -> *) (responses :: [*]) a.
(MonadLogger m,
 IsMember (WithStatus 401 ErrorBearerAuth) responses) =>
AuthResult a -> (a -> m (Union responses)) -> m (Union responses)
handleAuthBearer AuthResult UserAuthenticated
auth ((UserAuthenticated -> m (Union responses)) -> m (Union responses))
-> (UserAuthenticated -> m (Union responses))
-> m (Union responses)
forall a b. (a -> b) -> a -> b
$ \UserAuthenticated
authenticated ->
    case Either String RequestConfirm
eitherRequest of
      Left String
err -> do
        Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Failed to parse request: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String -> String
forall a. Show a => a -> String
show String
err)
        WithStatus 400 ErrorParseBodyJson -> m (Union responses)
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 400 ErrorParseBodyJson -> m (Union responses))
-> WithStatus 400 ErrorParseBodyJson -> m (Union responses)
forall a b. (a -> b) -> a -> b
$ forall (k :: Nat) a. a -> WithStatus k a
WithStatus @400 (ErrorParseBodyJson -> WithStatus 400 ErrorParseBodyJson)
-> ErrorParseBodyJson -> WithStatus 400 ErrorParseBodyJson
forall a b. (a -> b) -> a -> b
$ String -> ErrorParseBodyJson
MkErrorParseBodyJson String
err
      Right request :: RequestConfirm
request@MkRequestConfirm {ConfirmationSecret
requestConfirmSecret :: ConfirmationSecret
requestConfirmSecret :: RequestConfirm -> ConfirmationSecret
requestConfirmSecret} -> do
        Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Running confirmation: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (RequestConfirm -> String
forall a. Show a => a -> String
show RequestConfirm
request)
        SeldaResult (Either ConfirmationError ())
seldaResult <-
          SeldaTransactionT m (Either ConfirmationError ())
-> m (SeldaResult (Either ConfirmationError ()))
forall a. SeldaTransactionT m a -> m (SeldaResult a)
forall (m :: * -> *) a.
MonadSeldaPool m =>
SeldaTransactionT m a -> m (SeldaResult a)
runSeldaTransactionT (SeldaTransactionT m (Either ConfirmationError ())
 -> m (SeldaResult (Either ConfirmationError ())))
-> SeldaTransactionT m (Either ConfirmationError ())
-> m (SeldaResult (Either ConfirmationError ()))
forall a b. (a -> b) -> a -> b
$
            IdentifierUser
-> ConfirmationSecret
-> SeldaTransactionT m (Either ConfirmationError ())
forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadSeldaPool m) =>
IdentifierUser
-> ConfirmationSecret
-> SeldaTransactionT m (Either ConfirmationError ())
userConfirmationConfirm (UserAuthenticated -> IdentifierUser
userAuthenticatedId UserAuthenticated
authenticated) ConfirmationSecret
requestConfirmSecret
        WithStatus 500 ()
-> SeldaResult (Either ConfirmationError ())
-> (Either ConfirmationError () -> m (Union responses))
-> m (Union responses)
forall r (m :: * -> *) (responses :: [*]) a.
(HasStatus r, MonadLogger m, IsMember r responses) =>
r
-> SeldaResult a
-> (a -> m (Union responses))
-> m (Union responses)
handleSeldaSomeException (forall (k :: Nat) a. a -> WithStatus k a
WithStatus @500 ()) SeldaResult (Either ConfirmationError ())
seldaResult ((Either ConfirmationError () -> m (Union responses))
 -> m (Union responses))
-> (Either ConfirmationError () -> m (Union responses))
-> m (Union responses)
forall a b. (a -> b) -> a -> b
$ \case
          Left ConfirmationError
err -> do
            Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Failed to confirm."
            case ConfirmationError
err of
              ConfirmationError
MkConfirmationErrorExpired ->
                WithStatus 410 () -> m (Union responses)
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 410 () -> m (Union responses))
-> WithStatus 410 () -> m (Union responses)
forall a b. (a -> b) -> a -> b
$ forall (k :: Nat) a. a -> WithStatus k a
WithStatus @410 ()
              ConfirmationError
MkConfirmationErrorEffectInvalid ->
                WithStatus 500 () -> m (Union responses)
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 500 () -> m (Union responses))
-> WithStatus 500 () -> m (Union responses)
forall a b. (a -> b) -> a -> b
$ forall (k :: Nat) a. a -> WithStatus k a
WithStatus @500 ()
          Right () -> do
            Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Ran confirmation."
            WithStatus 200 ResponseConfirm -> m (Union responses)
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 200 ResponseConfirm -> m (Union responses))
-> WithStatus 200 ResponseConfirm -> m (Union responses)
forall a b. (a -> b) -> a -> b
$
              forall (k :: Nat) a. a -> WithStatus k a
WithStatus @200
                MkResponseConfirm
                  { responseConfirmUnit :: ()
responseConfirmUnit = ()
                  }

notificationPreferences ::
  ( MonadEmail m
  , MonadLogger m
  , MonadSeldaPool m
  , IsMember (WithStatus 200 ResponseNotifications) responses
  , IsMember (WithStatus 400 ErrorParseBodyJson) responses
  , IsMember (WithStatus 401 ErrorBearerAuth) responses
  , IsMember (WithStatus 403 (StaticText "Email address is not verified.")) responses
  , IsMember (WithStatus 500 ()) responses
  ) =>
  AuthResult UserAuthenticated ->
  Either String RequestNotifications ->
  m (Union responses)
notificationPreferences :: forall (m :: * -> *) (responses :: [*]).
(MonadEmail m, MonadLogger m, MonadSeldaPool m,
 IsMember (WithStatus 200 ResponseNotifications) responses,
 IsMember (WithStatus 400 ErrorParseBodyJson) responses,
 IsMember (WithStatus 401 ErrorBearerAuth) responses,
 IsMember
   (WithStatus 403 (StaticText "Email address is not verified."))
   responses,
 IsMember (WithStatus 500 ()) responses) =>
AuthResult UserAuthenticated
-> Either String RequestNotifications -> m (Union responses)
notificationPreferences AuthResult UserAuthenticated
auth Either String RequestNotifications
eitherRequest =
  AuthResult UserAuthenticated
-> (UserAuthenticated -> m (Union responses))
-> m (Union responses)
forall (m :: * -> *) (responses :: [*]) a.
(MonadLogger m,
 IsMember (WithStatus 401 ErrorBearerAuth) responses) =>
AuthResult a -> (a -> m (Union responses)) -> m (Union responses)
handleAuthBearer AuthResult UserAuthenticated
auth ((UserAuthenticated -> m (Union responses)) -> m (Union responses))
-> (UserAuthenticated -> m (Union responses))
-> m (Union responses)
forall a b. (a -> b) -> a -> b
$ \UserAuthenticated
authenticated ->
    Either String RequestNotifications
-> (RequestNotifications -> m (Union responses))
-> m (Union responses)
forall (m :: * -> *) (responses :: [*]) a.
(MonadLogger m,
 IsMember (WithStatus 400 ErrorParseBodyJson) responses) =>
Either String a
-> (a -> m (Union responses)) -> m (Union responses)
handleBadRequestBody Either String RequestNotifications
eitherRequest ((RequestNotifications -> m (Union responses))
 -> m (Union responses))
-> (RequestNotifications -> m (Union responses))
-> m (Union responses)
forall a b. (a -> b) -> a -> b
$ \RequestNotifications
request -> do
      Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Getting/Setting user notification preferences."
      SeldaResult Bool
seldaResult <-
        SeldaTransactionT m Bool -> m (SeldaResult Bool)
forall a. SeldaTransactionT m a -> m (SeldaResult a)
forall (m :: * -> *) a.
MonadSeldaPool m =>
SeldaTransactionT m a -> m (SeldaResult a)
runSeldaTransactionT (SeldaTransactionT m Bool -> m (SeldaResult Bool))
-> SeldaTransactionT m Bool -> m (SeldaResult Bool)
forall a b. (a -> b) -> a -> b
$ do
          let getNotificationSettings :: SeldaTransactionT m Bool
getNotificationSettings =
                IdentifierUser -> SeldaTransactionT m EmailPreferences
forall (m :: * -> *).
(MonadLogger m, MonadSeldaPool m) =>
IdentifierUser -> SeldaTransactionT m EmailPreferences
userNotificationsPreferencesEmailGet (UserAuthenticated -> IdentifierUser
userAuthenticatedId UserAuthenticated
authenticated) SeldaTransactionT m EmailPreferences
-> (EmailPreferences -> SeldaTransactionT m Bool)
-> SeldaTransactionT m Bool
forall a b.
SeldaTransactionT m a
-> (a -> SeldaTransactionT m b) -> SeldaTransactionT m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  MkEmailPreferencesSend EmailAddress
_ -> Bool -> SeldaTransactionT m Bool
forall a. a -> SeldaTransactionT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                  EmailPreferences
MkEmailPreferencesDontSend -> Bool -> SeldaTransactionT m Bool
forall a. a -> SeldaTransactionT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
          case RequestNotifications -> Maybe Bool
requestNotificationsReceiveEmailNotifications RequestNotifications
request of
            Maybe Bool
Nothing -> do
              m () -> SeldaTransactionT m ()
forall (m :: * -> *) a. Monad m => m a -> SeldaTransactionT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> SeldaTransactionT m ()) -> m () -> SeldaTransactionT m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug Text
"Just getting user notification preferences."
              SeldaTransactionT m Bool
getNotificationSettings
            Just Bool
newPreferences -> do
              m () -> SeldaTransactionT m ()
forall (m :: * -> *) a. Monad m => m a -> SeldaTransactionT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> SeldaTransactionT m ()) -> m () -> SeldaTransactionT m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug Text
"Setting new user notification preferences."
              IdentifierUser -> Bool -> SeldaTransactionT m ()
forall (m :: * -> *).
(MonadLogger m, MonadSeldaPool m) =>
IdentifierUser -> Bool -> SeldaTransactionT m ()
userNotificationsPreferencesEmailSet (UserAuthenticated -> IdentifierUser
userAuthenticatedId UserAuthenticated
authenticated) Bool
newPreferences
              SeldaTransactionT m Bool
getNotificationSettings
      Proxy SqlErrorMensamEmailNotVerified
-> WithStatus 403 (StaticText "Email address is not verified.")
-> SeldaResult Bool
-> (SeldaResult Bool -> m (Union responses))
-> m (Union responses)
forall e r (m :: * -> *) (responses :: [*]) a.
(Exception e, HasStatus r, Applicative m, IsMember r responses) =>
Proxy e
-> r
-> SeldaResult a
-> (SeldaResult a -> m (Union responses))
-> m (Union responses)
handleSeldaException
        (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @SqlErrorMensamEmailNotVerified)
        (forall (k :: Nat) a. a -> WithStatus k a
WithStatus @403 (StaticText "Email address is not verified."
 -> WithStatus 403 (StaticText "Email address is not verified."))
-> StaticText "Email address is not verified."
-> WithStatus 403 (StaticText "Email address is not verified.")
forall a b. (a -> b) -> a -> b
$ forall (text :: Symbol). StaticText text
MkStaticText @"Email address is not verified.")
        SeldaResult Bool
seldaResult
        ((SeldaResult Bool -> m (Union responses)) -> m (Union responses))
-> (SeldaResult Bool -> m (Union responses)) -> m (Union responses)
forall a b. (a -> b) -> a -> b
$ \SeldaResult Bool
seldaResultAfter403 -> do
          WithStatus 500 ()
-> SeldaResult Bool
-> (Bool -> m (Union responses))
-> m (Union responses)
forall r (m :: * -> *) (responses :: [*]) a.
(HasStatus r, MonadLogger m, IsMember r responses) =>
r
-> SeldaResult a
-> (a -> m (Union responses))
-> m (Union responses)
handleSeldaSomeException (forall (k :: Nat) a. a -> WithStatus k a
WithStatus @500 ()) SeldaResult Bool
seldaResultAfter403 ((Bool -> m (Union responses)) -> m (Union responses))
-> (Bool -> m (Union responses)) -> m (Union responses)
forall a b. (a -> b) -> a -> b
$ \Bool
receiveEmailNotifications -> do
            WithStatus 200 ResponseNotifications -> m (Union responses)
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 200 ResponseNotifications -> m (Union responses))
-> WithStatus 200 ResponseNotifications -> m (Union responses)
forall a b. (a -> b) -> a -> b
$
              forall (k :: Nat) a. a -> WithStatus k a
WithStatus @200
                MkResponseNotifications
                  { responseNotificationsReceiveEmailNotifications :: Bool
responseNotificationsReceiveEmailNotifications = Bool
receiveEmailNotifications
                  }

profile ::
  ( MonadIO m
  , MonadLogger m
  , MonadSeldaPool m
  , IsMember (WithStatus 200 ResponseProfile) responses
  , IsMember (WithStatus 400 ErrorParseBodyJson) responses
  , IsMember (WithStatus 401 ErrorBearerAuth) responses
  , IsMember (WithStatus 404 ()) responses
  , IsMember (WithStatus 500 ()) responses
  ) =>
  AuthResult UserAuthenticated ->
  Either String RequestProfile ->
  m (Union responses)
profile :: forall (m :: * -> *) (responses :: [*]).
(MonadIO m, MonadLogger m, MonadSeldaPool m,
 IsMember (WithStatus 200 ResponseProfile) responses,
 IsMember (WithStatus 400 ErrorParseBodyJson) responses,
 IsMember (WithStatus 401 ErrorBearerAuth) responses,
 IsMember (WithStatus 404 ()) responses,
 IsMember (WithStatus 500 ()) responses) =>
AuthResult UserAuthenticated
-> Either String RequestProfile -> m (Union responses)
profile AuthResult UserAuthenticated
auth Either String RequestProfile
eitherRequest =
  AuthResult UserAuthenticated
-> (UserAuthenticated -> m (Union responses))
-> m (Union responses)
forall (m :: * -> *) (responses :: [*]) a.
(MonadLogger m,
 IsMember (WithStatus 401 ErrorBearerAuth) responses) =>
AuthResult a -> (a -> m (Union responses)) -> m (Union responses)
handleAuthBearer AuthResult UserAuthenticated
auth ((UserAuthenticated -> m (Union responses)) -> m (Union responses))
-> (UserAuthenticated -> m (Union responses))
-> m (Union responses)
forall a b. (a -> b) -> a -> b
$ \UserAuthenticated
_authenticated ->
    case Either String RequestProfile
eitherRequest of
      Left String
err -> do
        Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Failed to parse request: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String -> String
forall a. Show a => a -> String
show String
err)
        WithStatus 400 ErrorParseBodyJson -> m (Union responses)
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 400 ErrorParseBodyJson -> m (Union responses))
-> WithStatus 400 ErrorParseBodyJson -> m (Union responses)
forall a b. (a -> b) -> a -> b
$ forall (k :: Nat) a. a -> WithStatus k a
WithStatus @400 (ErrorParseBodyJson -> WithStatus 400 ErrorParseBodyJson)
-> ErrorParseBodyJson -> WithStatus 400 ErrorParseBodyJson
forall a b. (a -> b) -> a -> b
$ String -> ErrorParseBodyJson
MkErrorParseBodyJson String
err
      Right request :: RequestProfile
request@MkRequestProfile {NameOrIdentifier Username IdentifierUser
requestProfileUser :: NameOrIdentifier Username IdentifierUser
requestProfileUser :: RequestProfile -> NameOrIdentifier Username IdentifierUser
requestProfileUser} -> do
        Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Looking up user profile: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (RequestProfile -> String
forall a. Show a => a -> String
show RequestProfile
request)
        SeldaResult (Maybe User)
seldaResult <- SeldaTransactionT m (Maybe User) -> m (SeldaResult (Maybe User))
forall a. SeldaTransactionT m a -> m (SeldaResult a)
forall (m :: * -> *) a.
MonadSeldaPool m =>
SeldaTransactionT m a -> m (SeldaResult a)
runSeldaTransactionT (SeldaTransactionT m (Maybe User) -> m (SeldaResult (Maybe User)))
-> SeldaTransactionT m (Maybe User) -> m (SeldaResult (Maybe User))
forall a b. (a -> b) -> a -> b
$ do
          Maybe IdentifierUser
maybeUserIdentifier <- case NameOrIdentifier Username IdentifierUser
requestProfileUser of
            Name Username
name -> Username -> SeldaTransactionT m (Maybe IdentifierUser)
forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadSeldaPool m) =>
Username -> SeldaTransactionT m (Maybe IdentifierUser)
userLookupId Username
name
            Identifier IdentifierUser
identifier -> Maybe IdentifierUser -> SeldaTransactionT m (Maybe IdentifierUser)
forall a. a -> SeldaTransactionT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe IdentifierUser
 -> SeldaTransactionT m (Maybe IdentifierUser))
-> Maybe IdentifierUser
-> SeldaTransactionT m (Maybe IdentifierUser)
forall a b. (a -> b) -> a -> b
$ IdentifierUser -> Maybe IdentifierUser
forall a. a -> Maybe a
Just IdentifierUser
identifier
          case Maybe IdentifierUser
maybeUserIdentifier of
            Maybe IdentifierUser
Nothing -> Maybe User -> SeldaTransactionT m (Maybe User)
forall a. a -> SeldaTransactionT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe User
forall a. Maybe a
Nothing
            Just IdentifierUser
userIdentifier -> User -> Maybe User
forall a. a -> Maybe a
Just (User -> Maybe User)
-> SeldaTransactionT m User -> SeldaTransactionT m (Maybe User)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IdentifierUser -> SeldaTransactionT m User
forall (m :: * -> *).
(MonadLogger m, MonadSeldaPool m) =>
IdentifierUser -> SeldaTransactionT m User
userGet IdentifierUser
userIdentifier
        WithStatus 500 ()
-> SeldaResult (Maybe User)
-> (Maybe User -> m (Union responses))
-> m (Union responses)
forall r (m :: * -> *) (responses :: [*]) a.
(HasStatus r, MonadLogger m, IsMember r responses) =>
r
-> SeldaResult a
-> (a -> m (Union responses))
-> m (Union responses)
handleSeldaSomeException (forall (k :: Nat) a. a -> WithStatus k a
WithStatus @500 ()) SeldaResult (Maybe User)
seldaResult ((Maybe User -> m (Union responses)) -> m (Union responses))
-> (Maybe User -> m (Union responses)) -> m (Union responses)
forall a b. (a -> b) -> a -> b
$ \case
          Maybe User
Nothing -> do
            Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logWarn Text
"No such user profile."
            WithStatus 404 () -> m (Union responses)
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 404 () -> m (Union responses))
-> WithStatus 404 () -> m (Union responses)
forall a b. (a -> b) -> a -> b
$ forall (k :: Nat) a. a -> WithStatus k a
WithStatus @404 ()
          Just User
user ->
            WithStatus 200 ResponseProfile -> m (Union responses)
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 200 ResponseProfile -> m (Union responses))
-> WithStatus 200 ResponseProfile -> m (Union responses)
forall a b. (a -> b) -> a -> b
$
              forall (k :: Nat) a. a -> WithStatus k a
WithStatus @200 (ResponseProfile -> WithStatus 200 ResponseProfile)
-> ResponseProfile -> WithStatus 200 ResponseProfile
forall a b. (a -> b) -> a -> b
$
                MkResponseProfile
                  { responseProfileId :: IdentifierUser
responseProfileId = User -> IdentifierUser
userId User
user
                  , responseProfileName :: Username
responseProfileName = User -> Username
userName User
user
                  , responseProfileEmail :: Maybe EmailAddress
responseProfileEmail =
                      if User -> Bool
userEmailVisible User
user
                        then EmailAddress -> Maybe EmailAddress
forall a. a -> Maybe a
Just (EmailAddress -> Maybe EmailAddress)
-> EmailAddress -> Maybe EmailAddress
forall a b. (a -> b) -> a -> b
$ User -> EmailAddress
userEmail User
user
                        else Maybe EmailAddress
forall a. Maybe a
Nothing
                  , responseProfileEmailVerified :: Bool
responseProfileEmailVerified = User -> Bool
userEmailValidated User
user
                  }

handleBadRequestBody ::
  ( MonadLogger m
  , IsMember (WithStatus 400 ErrorParseBodyJson) responses
  ) =>
  Either String a ->
  (a -> m (Union responses)) ->
  m (Union responses)
handleBadRequestBody :: forall (m :: * -> *) (responses :: [*]) a.
(MonadLogger m,
 IsMember (WithStatus 400 ErrorParseBodyJson) responses) =>
Either String a
-> (a -> m (Union responses)) -> m (Union responses)
handleBadRequestBody Either String a
parsedRequestBody a -> m (Union responses)
handler' =
  -- TODO: Rename arguments `handler'` to `handler`
  case Either String a
parsedRequestBody of
    Right a
a -> a -> m (Union responses)
handler' a
a
    Left String
err -> WithStatus 400 ErrorParseBodyJson -> m (Union responses)
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 400 ErrorParseBodyJson -> m (Union responses))
-> WithStatus 400 ErrorParseBodyJson -> m (Union responses)
forall a b. (a -> b) -> a -> b
$ forall (k :: Nat) a. a -> WithStatus k a
WithStatus @400 (ErrorParseBodyJson -> WithStatus 400 ErrorParseBodyJson)
-> ErrorParseBodyJson -> WithStatus 400 ErrorParseBodyJson
forall a b. (a -> b) -> a -> b
$ String -> ErrorParseBodyJson
MkErrorParseBodyJson String
err

handleBadRequestBodyJpeg ::
  ( MonadLogger m
  , IsMember (WithStatus 400 ErrorParseBodyJpeg) responses
  ) =>
  Either String a ->
  (a -> m (Union responses)) ->
  m (Union responses)
handleBadRequestBodyJpeg :: forall (m :: * -> *) (responses :: [*]) a.
(MonadLogger m,
 IsMember (WithStatus 400 ErrorParseBodyJpeg) responses) =>
Either String a
-> (a -> m (Union responses)) -> m (Union responses)
handleBadRequestBodyJpeg Either String a
parsedRequestBody a -> m (Union responses)
handler' =
  -- TODO: Rename arguments `handler'` to `handler`
  case Either String a
parsedRequestBody of
    Right a
a -> a -> m (Union responses)
handler' a
a
    Left String
err -> WithStatus 400 ErrorParseBodyJpeg -> m (Union responses)
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 400 ErrorParseBodyJpeg -> m (Union responses))
-> WithStatus 400 ErrorParseBodyJpeg -> m (Union responses)
forall a b. (a -> b) -> a -> b
$ forall (k :: Nat) a. a -> WithStatus k a
WithStatus @400 (ErrorParseBodyJpeg -> WithStatus 400 ErrorParseBodyJpeg)
-> ErrorParseBodyJpeg -> WithStatus 400 ErrorParseBodyJpeg
forall a b. (a -> b) -> a -> b
$ String -> ErrorParseBodyJpeg
MkErrorParseBodyJpeg String
err