{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE QuasiQuotes #-}

module WikiMusic.SSR.Servant.Utilities
  ( fromForm,
    setCookieRoute,
    encodeToken,
    mkCookieData,
    mkCookieMap,
    decodeToken,
    eitherView,
    viewVarsFromCookies,
    maybeFromForm,
  )
where

import Control.Monad.Error.Class
import Data.ByteString.Base16.Lazy qualified as B16
import Data.Map qualified as Map
import Data.Text qualified as T
import Free.AlaCarte
import NeatInterpolation
import Optics
import Relude
import Servant
import Servant.Multipart
import Text.Blaze.Html
import WikiMusic.SSR.Backend.Rest ()
import WikiMusic.SSR.Free.View
import WikiMusic.SSR.Model.Api
import WikiMusic.SSR.Model.Config
import WikiMusic.SSR.Model.Env
import WikiMusic.SSR.View.Html ()

fromForm :: MultipartData tag -> Text -> Text -> Text
fromForm :: forall tag. MultipartData tag -> Text -> Text -> Text
fromForm MultipartData tag
multipart Text
fallback Text
name =
  Text -> (NonEmpty Text -> Text) -> Maybe (NonEmpty Text) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
fallback NonEmpty Text -> Text
forall (f :: * -> *) a. IsNonEmpty f a a "head" => f a -> a
head
    (Maybe (NonEmpty Text) -> Text)
-> ([Input] -> Maybe (NonEmpty Text)) -> [Input] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty
    ([Text] -> Maybe (NonEmpty Text))
-> ([Input] -> [Text]) -> [Input] -> Maybe (NonEmpty Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Input -> Text) -> [Input] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Input -> Text
iValue
    ([Input] -> [Text]) -> ([Input] -> [Input]) -> [Input] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Input -> Bool) -> [Input] -> [Input]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Input
i -> Input -> Text
iName Input
i Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name)
    ([Input] -> Text) -> [Input] -> Text
forall a b. (a -> b) -> a -> b
$ MultipartData tag -> [Input]
forall tag. MultipartData tag -> [Input]
inputs MultipartData tag
multipart

maybeFromForm :: MultipartData tag -> Text -> Maybe Text
maybeFromForm :: forall tag. MultipartData tag -> Text -> Maybe Text
maybeFromForm MultipartData tag
multipart Text
name = case Maybe Text
rawVal of
  (Just Text
"") -> Maybe Text
forall a. Maybe a
Nothing
  (Just Text
x) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
x
  Maybe Text
Nothing -> Maybe Text
forall a. Maybe a
Nothing
  where
    rawVal :: Maybe Text
rawVal =
      (NonEmpty Text -> Text) -> Maybe (NonEmpty Text) -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty Text -> Text
forall (f :: * -> *) a. IsNonEmpty f a a "head" => f a -> a
head
        (Maybe (NonEmpty Text) -> Maybe Text)
-> ([Input] -> Maybe (NonEmpty Text)) -> [Input] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty
        ([Text] -> Maybe (NonEmpty Text))
-> ([Input] -> [Text]) -> [Input] -> Maybe (NonEmpty Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Input -> Text) -> [Input] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Input -> Text
iValue
        ([Input] -> [Text]) -> ([Input] -> [Input]) -> [Input] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Input -> Bool) -> [Input] -> [Input]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Input
i -> Input -> Text
iName Input
i Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name)
        ([Input] -> Maybe Text) -> [Input] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ MultipartData tag -> [Input]
forall tag. MultipartData tag -> [Input]
inputs MultipartData tag
multipart

setCookieRoute :: (MonadError ServerError m) => CookieConfig -> Text -> Map Text Text -> m a
setCookieRoute :: forall (m :: * -> *) a.
MonadError ServerError m =>
CookieConfig -> Text -> Map Text Text -> m a
setCookieRoute CookieConfig
cookieConfig Text
newLocation Map Text Text
cookieMap =
  ServerError -> m a
forall a. ServerError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
    (ServerError -> m a) -> ServerError -> m a
forall a b. (a -> b) -> a -> b
$ ServerError
      { errHTTPCode :: Int
errHTTPCode = Int
302,
        errReasonPhrase :: String
errReasonPhrase = String
"Found",
        errBody :: ByteString
errBody = ByteString
"",
        errHeaders :: [Header]
errHeaders =
          (HeaderName
"Location", Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
newLocation) Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header]
cookieHeaders
      }
  where
    mkCookieHeaders :: (Text, Text) -> Header
mkCookieHeaders (Text
cookieName, Text
cookieValue) =
      ( HeaderName
"Set-Cookie",
        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 -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CookieConfig -> Text -> Text
mkCookieData CookieConfig
cookieConfig
          (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ [trimming|$cookieName=$cookieValue|]
      )
    cookieHeaders :: [Header]
cookieHeaders = ((Text, Text) -> Header) -> [(Text, Text)] -> [Header]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Header
mkCookieHeaders (Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map Text Text
cookieMap)

mkCookieData :: CookieConfig -> Text -> Text
mkCookieData :: CookieConfig -> Text -> Text
mkCookieData CookieConfig
cookieConfig Text
dyn = [trimming|$dyn; HttpOnly; $sameSite; Domain=$domain; Path=/; Max-Age=$maxAge $secureSuffix |]
  where
    maxAge :: Text
maxAge = Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ CookieConfig
cookieConfig CookieConfig -> Optic' A_Lens NoIx CookieConfig Int -> Int
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CookieConfig Int
#maxAge
    domain :: Text
domain = CookieConfig
cookieConfig CookieConfig -> Optic' A_Lens NoIx CookieConfig Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CookieConfig Text
#domain
    sameSite :: Text
sameSite = CookieConfig
cookieConfig CookieConfig -> Optic' A_Lens NoIx CookieConfig Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CookieConfig Text
#sameSite
    secureSuffix :: Text
secureSuffix = if CookieConfig
cookieConfig CookieConfig -> Optic' A_Lens NoIx CookieConfig Bool -> Bool
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CookieConfig Bool
#secure then Text
"; Secure" else Text
""

mkCookieMap :: Maybe Text -> Map Text Text
mkCookieMap :: Maybe Text -> Map Text Text
mkCookieMap Maybe Text
cookie = do
  let diffCookies :: [Text]
diffCookies = [Text] -> (Text -> [Text]) -> Maybe Text -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"; ") Maybe Text
cookie
      cookieParser :: [b] -> Maybe (b, b)
cookieParser [b
a, b
b] = (b, b) -> Maybe (b, b)
forall a. a -> Maybe a
Just (b
a, b
b)
      cookieParser [b]
_ = Maybe (b, b)
forall a. Maybe a
Nothing
      cookieMap :: Map Text Text
cookieMap = [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, Text)] -> Map Text Text)
-> [(Text, Text)] -> Map Text Text
forall a b. (a -> b) -> a -> b
$ (Text -> Maybe (Text, Text)) -> [Text] -> [(Text, Text)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Text] -> Maybe (Text, Text)
forall {b}. [b] -> Maybe (b, b)
cookieParser ([Text] -> Maybe (Text, Text))
-> (Text -> [Text]) -> Text -> Maybe (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"=") [Text]
diffCookies
  Map Text Text
cookieMap

eitherView :: (MonadIO m) => Env -> UiMode -> Language -> Palette -> Either Text t -> (t -> IO Html) -> m Html
eitherView :: forall (m :: * -> *) t.
MonadIO m =>
Env
-> UiMode
-> Language
-> Palette
-> Either Text t
-> (t -> IO Html)
-> m Html
eitherView Env
env UiMode
mode Language
language Palette
palette Either Text t
x t -> IO Html
eff = case Either Text t
x of
  Left Text
e -> 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 -> Text -> Free View Html
forall (f :: * -> *).
(View :<: f) =>
Env -> UiMode -> Language -> Palette -> Text -> Free f Html
errorPage Env
env UiMode
mode Language
language Palette
palette Text
e)
  Right t
r -> 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
$ t -> IO Html
eff t
r

decodeToken :: Text -> Text
decodeToken :: Text -> Text
decodeToken = ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Text) -> (Text -> ByteString) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B16.decodeLenient (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8

encodeToken :: Text -> Text
encodeToken :: Text -> Text
encodeToken = ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Text) -> (Text -> ByteString) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B16.encode (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8

viewVarsFromCookies :: Maybe Text -> ViewVars
viewVarsFromCookies :: Maybe Text -> ViewVars
viewVarsFromCookies Maybe Text
cookie = ViewVars {SortOrder
AuthToken
UiMode
Language
SongAsciiSize
Palette
locale :: Language
uiMode :: UiMode
authToken :: AuthToken
songAsciiSize :: SongAsciiSize
artistSorting :: SortOrder
songSorting :: SortOrder
genreSorting :: SortOrder
palette :: Palette
$sel:locale:ViewVars :: Language
$sel:uiMode:ViewVars :: UiMode
$sel:authToken:ViewVars :: AuthToken
$sel:songSorting:ViewVars :: SortOrder
$sel:artistSorting:ViewVars :: SortOrder
$sel:genreSorting:ViewVars :: SortOrder
$sel:songAsciiSize:ViewVars :: SongAsciiSize
$sel:palette:ViewVars :: Palette
..}
  where
    cookieMap :: Map Text Text
cookieMap = Maybe Text -> Map Text Text
mkCookieMap Maybe Text
cookie
    locale :: Language
locale = Language {$sel:value:Language :: Text
value = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"en" (Map Text Text
cookieMap Map Text Text -> Text -> Maybe Text
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? Text
localeCookieName)}
    uiMode :: UiMode
uiMode = UiMode {$sel:value:UiMode :: Text
value = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"light" (Map Text Text
cookieMap Map Text Text -> Text -> Maybe Text
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? Text
uiModeCookieName)}
    authToken :: AuthToken
authToken = AuthToken {$sel:value:AuthToken :: Text
value = Text -> Text
decodeToken (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Map Text Text
cookieMap Map Text Text -> Text -> Maybe Text
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? Text
authCookieName)}
    songAsciiSize :: SongAsciiSize
songAsciiSize = SongAsciiSize {$sel:value:SongAsciiSize :: Text
value = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"medium" (Map Text Text
cookieMap Map Text Text -> Text -> Maybe Text
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? Text
songAsciiSizeCookieName)}
    artistSorting :: SortOrder
artistSorting =
      SortOrder
        { $sel:value:SortOrder :: Text
value = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"created-at-desc" (Map Text Text
cookieMap Map Text Text -> Text -> Maybe Text
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? Text
artistSortingCookieName)
        }
    songSorting :: SortOrder
songSorting =
      SortOrder
        { $sel:value:SortOrder :: Text
value = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"created-at-desc" (Map Text Text
cookieMap Map Text Text -> Text -> Maybe Text
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? Text
songSortingCookieName)
        }
    genreSorting :: SortOrder
genreSorting =
      SortOrder
        { $sel:value:SortOrder :: Text
value = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"created-at-desc" (Map Text Text
cookieMap Map Text Text -> Text -> Maybe Text
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? Text
genreSortingCookieName)
        }
    palette :: Palette
palette = Palette {$sel:value:Palette :: Text
value = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"mauve" (Map Text Text
cookieMap Map Text Text -> Text -> Maybe Text
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? Text
paletteCookieName)}