{-# 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