{-# LANGUAGE OverloadedLabels #-}

module WikiMusic.SSR.Servant.LoginRoutes (submitLoginRoute, loginFormRoute) where

import Control.Monad.Error.Class
import Data.ByteString.Lazy qualified as BL
import Data.Map qualified as Map
import Data.Text qualified as T
import Free.AlaCarte
import Optics
import Relude
import Servant
import Servant.Multipart
import Text.Blaze.Html as Html
import WikiMusic.Model.Auth
import WikiMusic.SSR.Backend.Rest ()
import WikiMusic.SSR.Free.Backend
import WikiMusic.SSR.Free.View
import WikiMusic.SSR.Model.Api
import WikiMusic.SSR.Model.Env
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
      ()
_ <- IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
BL.putStr (ByteString -> IO ()) -> (Text -> ByteString) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> (Text -> String) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
e
      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
Map.empty
    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 k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text
authCookieName, Text -> Text
encodeToken Text
authToken)])
  where
    email :: String
email = Text -> String
T.unpack (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
T.unpack (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 -> UiMode -> Language -> Palette -> Free View Html
forall (f :: * -> *).
(View :<: f) =>
Env -> UiMode -> Language -> Palette -> Free f Html
loginPage Env
env (ViewVars
viewVars ViewVars -> Optic' A_Lens NoIx ViewVars UiMode -> UiMode
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ViewVars UiMode
#uiMode) (ViewVars
viewVars ViewVars -> Optic' A_Lens NoIx ViewVars Language -> Language
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ViewVars Language
#locale) (ViewVars
viewVars ViewVars -> Optic' A_Lens NoIx ViewVars Palette -> Palette
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ViewVars Palette
#palette))
  where
    viewVars :: ViewVars
viewVars = Maybe Text -> ViewVars
viewVarsFromCookies Maybe Text
cookie