{-# LANGUAGE OverloadedLabels #-}

module WikiMusic.SSR.Servant.LoginRoutes where

import Principium
import Servant
import Servant.Multipart
import WikiMusic.Interaction.Model.User
import WikiMusic.Model.Auth
import WikiMusic.SSR.Backend.Rest ()
import WikiMusic.SSR.Free.Backend
import WikiMusic.SSR.Free.View
import WikiMusic.SSR.Servant.Utilities
import WikiMusic.SSR.View.Html ()

submitLoginRoute :: (MonadIO m, MonadError ServerError m) => Env -> MultipartData tag -> m a
submitLoginRoute :: forall (m :: * -> *) tag a.
(MonadIO m, MonadError ServerError m) =>
Env -> MultipartData tag -> m a
submitLoginRoute Env
env MultipartData tag
multipartData = do
  Either Text Text
maybeAuthToken <- IO (Either Text Text) -> m (Either Text Text)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text Text) -> m (Either Text Text))
-> IO (Either Text Text) -> m (Either Text Text)
forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Exec f => Free f a -> IO a
exec @Backend (Env -> LoginRequest -> Free Backend (Either Text Text)
forall (f :: * -> *).
(Backend :<: f) =>
Env -> LoginRequest -> Free f (Either Text Text)
login Env
env (LoginRequest {$sel:wikimusicEmail:LoginRequest :: String
wikimusicEmail = String
email, $sel:wikimusicPassword:LoginRequest :: String
wikimusicPassword = String
password}))
  case Either Text Text
maybeAuthToken of
    Left Text
e -> do
      CookieConfig -> Text -> Map Text Text -> m a
forall (m :: * -> *) a.
MonadError ServerError m =>
CookieConfig -> Text -> Map Text Text -> m a
setCookieRoute (Env
env Env -> Optic' A_Lens NoIx Env CookieConfig -> CookieConfig
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic A_Lens NoIx Env Env AppConfig AppConfig
#cfg Optic A_Lens NoIx Env Env AppConfig AppConfig
-> Optic A_Lens NoIx AppConfig AppConfig CookieConfig CookieConfig
-> Optic' A_Lens NoIx Env CookieConfig
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx AppConfig AppConfig CookieConfig CookieConfig
#cookie) Text
"/login" Map Text Text
forall k a. Map k a
emptyMap
    Right Text
authToken -> CookieConfig -> Text -> Map Text Text -> m a
forall (m :: * -> *) a.
MonadError ServerError m =>
CookieConfig -> Text -> Map Text Text -> m a
setCookieRoute (Env
env Env -> Optic' A_Lens NoIx Env CookieConfig -> CookieConfig
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic A_Lens NoIx Env Env AppConfig AppConfig
#cfg Optic A_Lens NoIx Env Env AppConfig AppConfig
-> Optic A_Lens NoIx AppConfig AppConfig CookieConfig CookieConfig
-> Optic' A_Lens NoIx Env CookieConfig
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx AppConfig AppConfig CookieConfig CookieConfig
#cookie) Text
"/songs" ([(Text, Text)] -> Map Text Text
forall a b. Ord a => [(a, b)] -> Map a b
mapFromList [(Text
authCookieName, Text -> Text
encodeToken Text
authToken)])
  where
    email :: String
email = Text -> String
unpackText (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ MultipartData tag -> Text -> Text -> Text
forall tag. MultipartData tag -> Text -> Text -> Text
fromForm MultipartData tag
multipartData Text
"" Text
"email"
    password :: String
password = Text -> String
unpackText (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ MultipartData tag -> Text -> Text -> Text
forall tag. MultipartData tag -> Text -> Text -> Text
fromForm MultipartData tag
multipartData Text
"" Text
"password"

loginFormRoute :: (MonadIO m) => Env -> Maybe Text -> m Html
loginFormRoute :: forall (m :: * -> *). MonadIO m => Env -> Maybe Text -> m Html
loginFormRoute Env
env Maybe Text
cookie = IO Html -> m Html
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Html -> m Html) -> IO Html -> m Html
forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Exec f => Free f a -> IO a
exec @View (Env -> ViewVars -> Free View Html
forall (f :: * -> *).
(View :<: f) =>
Env -> ViewVars -> Free f Html
loginPage Env
env ViewVars
vv)
  where
    vv :: ViewVars
vv = Maybe Text -> ViewVars
vvFromCookies Maybe Text
cookie

doPasswordResetFormRoute :: (MonadIO m) => Env -> Maybe Text -> Maybe Text -> m Html
doPasswordResetFormRoute :: forall (m :: * -> *).
MonadIO m =>
Env -> Maybe Text -> Maybe Text -> m Html
doPasswordResetFormRoute Env
env Maybe Text
cookie Maybe Text
maybeToken = IO Html -> m Html
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Html -> m Html) -> IO Html -> m Html
forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Exec f => Free f a -> IO a
exec @View (Env -> ViewVars -> Maybe Text -> Free View Html
forall (f :: * -> *).
(View :<: f) =>
Env -> ViewVars -> Maybe Text -> Free f Html
doPasswordResetPage Env
env ViewVars
vv Maybe Text
maybeToken)
  where
    vv :: ViewVars
vv = Maybe Text -> ViewVars
vvFromCookies Maybe Text
cookie

requestPasswordResetRoute :: (MonadIO m) => Env -> Maybe Text -> m Html
requestPasswordResetRoute :: forall (m :: * -> *). MonadIO m => Env -> Maybe Text -> m Html
requestPasswordResetRoute Env
env Maybe Text
cookie = IO Html -> m Html
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Html -> m Html) -> IO Html -> m Html
forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Exec f => Free f a -> IO a
exec @View (Env -> ViewVars -> Free View Html
forall (f :: * -> *).
(View :<: f) =>
Env -> ViewVars -> Free f Html
requestPasswordResetPage Env
env ViewVars
vv)
  where
    vv :: ViewVars
vv = Maybe Text -> ViewVars
vvFromCookies Maybe Text
cookie

doRequestPasswordResetRoute :: (MonadIO m, MonadError ServerError m) => Env -> MultipartData tag -> m a
doRequestPasswordResetRoute :: forall (m :: * -> *) tag a.
(MonadIO m, MonadError ServerError m) =>
Env -> MultipartData tag -> m a
doRequestPasswordResetRoute Env
env MultipartData tag
multipartData = do
  Either Text MakeResetPasswordLinkResponse
_ <-
    IO (Either Text MakeResetPasswordLinkResponse)
-> m (Either Text MakeResetPasswordLinkResponse)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      (IO (Either Text MakeResetPasswordLinkResponse)
 -> m (Either Text MakeResetPasswordLinkResponse))
-> IO (Either Text MakeResetPasswordLinkResponse)
-> m (Either Text MakeResetPasswordLinkResponse)
forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Exec f => Free f a -> IO a
exec @Backend
        ( Env
-> Text -> Free Backend (Either Text MakeResetPasswordLinkResponse)
forall (f :: * -> *).
(Backend :<: f) =>
Env -> Text -> Free f (Either Text MakeResetPasswordLinkResponse)
resetPassword
            Env
env
            Text
email
        )
  ServerResponse -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadError ServerError m) =>
ServerResponse -> m a
respondWithHttp
    ServerResponse
httpFound
      { cause = Just "Requested password reset!",
        headers = [withLocation ("/login?email=" <> email)]
      }
  where
    email :: Text
email = MultipartData tag -> Text -> Text -> Text
forall tag. MultipartData tag -> Text -> Text -> Text
fromForm MultipartData tag
multipartData Text
"" Text
"email"

doPasswordResetRoute :: (MonadIO m, MonadError ServerError m) => Env -> MultipartData tag -> m a
doPasswordResetRoute :: forall (m :: * -> *) tag a.
(MonadIO m, MonadError ServerError m) =>
Env -> MultipartData tag -> m a
doPasswordResetRoute Env
env MultipartData tag
multipartData = do
  Either Text ()
_ <-
    IO (Either Text ()) -> m (Either Text ())
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      (IO (Either Text ()) -> m (Either Text ()))
-> IO (Either Text ()) -> m (Either Text ())
forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Exec f => Free f a -> IO a
exec @Backend
        ( Env -> DoPasswordResetRequest -> Free Backend (Either Text ())
forall (f :: * -> *).
(Backend :<: f) =>
Env -> DoPasswordResetRequest -> Free f (Either Text ())
resetPasswordDo
            Env
env
            ( DoPasswordResetRequest
                { $sel:email:DoPasswordResetRequest :: Text
email = Text
email,
                  $sel:token:DoPasswordResetRequest :: Text
token = Text
token,
                  $sel:password:DoPasswordResetRequest :: Text
password = Text
password,
                  $sel:passwordConfirm:DoPasswordResetRequest :: Text
passwordConfirm = Text
passwordConfirm
                }
            )
        )
  ServerResponse -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadError ServerError m) =>
ServerResponse -> m a
respondWithHttp
    ServerResponse
httpFound
      { cause = Just "Reset password!",
        headers = [withLocation ("/login?email=" <> email)]
      }
  where
    email :: Text
email = MultipartData tag -> Text -> Text -> Text
forall tag. MultipartData tag -> Text -> Text -> Text
fromForm MultipartData tag
multipartData Text
"" Text
"email"
    password :: Text
password = MultipartData tag -> Text -> Text -> Text
forall tag. MultipartData tag -> Text -> Text -> Text
fromForm MultipartData tag
multipartData Text
"" Text
"password"
    passwordConfirm :: Text
passwordConfirm = MultipartData tag -> Text -> Text -> Text
forall tag. MultipartData tag -> Text -> Text -> Text
fromForm MultipartData tag
multipartData Text
"" Text
"passwordConfirm"
    token :: Text
token = MultipartData tag -> Text -> Text -> Text
forall tag. MultipartData tag -> Text -> Text -> Text
fromForm MultipartData tag
multipartData Text
"" Text
"token"

inviteUsersRoute :: (MonadIO m) => Env -> Maybe Text -> m Html
inviteUsersRoute :: forall (m :: * -> *). MonadIO m => Env -> Maybe Text -> m Html
inviteUsersRoute Env
env Maybe Text
cookie = IO Html -> m Html
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Html -> m Html) -> IO Html -> m Html
forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Exec f => Free f a -> IO a
exec @View (Env -> ViewVars -> Free View Html
forall (f :: * -> *).
(View :<: f) =>
Env -> ViewVars -> Free f Html
inviteUsersPage Env
env ViewVars
vv)
  where
    vv :: ViewVars
vv = Maybe Text -> ViewVars
vvFromCookies Maybe Text
cookie

inviteUsersFormRoute :: (MonadIO m, MonadError ServerError m) => Env -> Maybe Text -> MultipartData tag -> m a
inviteUsersFormRoute :: forall (m :: * -> *) tag a.
(MonadIO m, MonadError ServerError m) =>
Env -> Maybe Text -> MultipartData tag -> m a
inviteUsersFormRoute Env
env Maybe Text
cookie MultipartData tag
multipartData = do
  Either Text MakeResetPasswordLinkResponse
_ <-
    IO (Either Text MakeResetPasswordLinkResponse)
-> m (Either Text MakeResetPasswordLinkResponse)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      (IO (Either Text MakeResetPasswordLinkResponse)
 -> m (Either Text MakeResetPasswordLinkResponse))
-> IO (Either Text MakeResetPasswordLinkResponse)
-> m (Either Text MakeResetPasswordLinkResponse)
forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Exec f => Free f a -> IO a
exec @Backend
        ( Env
-> AuthToken
-> InviteUsersRequest
-> Free Backend (Either Text MakeResetPasswordLinkResponse)
forall (f :: * -> *).
(Backend :<: f) =>
Env
-> AuthToken
-> InviteUsersRequest
-> Free f (Either Text MakeResetPasswordLinkResponse)
userInvite
            Env
env
            (ViewVars
vv ViewVars -> Optic' A_Lens NoIx ViewVars AuthToken -> AuthToken
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ViewVars AuthToken
#authToken)
            InviteUsersRequest {Maybe Text
Text
UserRole
email :: Text
displayName :: Text
description :: Maybe Text
role :: UserRole
$sel:displayName:InviteUsersRequest :: Text
$sel:email:InviteUsersRequest :: Text
$sel:role:InviteUsersRequest :: UserRole
$sel:description:InviteUsersRequest :: Maybe Text
..}
        )
  ServerResponse -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadError ServerError m) =>
ServerResponse -> m a
respondWithHttp
    ServerResponse
httpFound
      { cause = Just "Requested password reset!",
        headers = [withLocation ("/login?email=" <> email)]
      }
  where
    vv :: ViewVars
vv = Maybe Text -> ViewVars
vvFromCookies Maybe Text
cookie
    email :: Text
email = MultipartData tag -> Text -> Text -> Text
forall tag. MultipartData tag -> Text -> Text -> Text
fromForm MultipartData tag
multipartData Text
"" Text
"email"
    displayName :: Text
displayName = MultipartData tag -> Text -> Text -> Text
forall tag. MultipartData tag -> Text -> Text -> Text
fromForm MultipartData tag
multipartData Text
"" Text
"displayName"
    description :: Maybe Text
description = MultipartData tag -> Text -> Maybe Text
forall tag. MultipartData tag -> Text -> Maybe Text
maybeFromForm MultipartData tag
multipartData Text
"description"
    role :: UserRole
role = (String -> UserRole
forall a. Read a => String -> a
read (String -> UserRole) -> (Text -> String) -> Text -> UserRole
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpackText (Text -> UserRole) -> Text -> UserRole
forall a b. (a -> b) -> a -> b
$ MultipartData tag -> Text -> Text -> Text
forall tag. MultipartData tag -> Text -> Text -> Text
fromForm MultipartData tag
multipartData Text
"" Text
"role") :: UserRole