Utilities.hs

{-# 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 multipart fallback name =
  maybe fallback head
    . nonEmpty
    . map iValue
    . filter (\i -> iName i == name)
    $ inputs multipart

maybeFromForm :: MultipartData tag -> Text -> Maybe Text
maybeFromForm multipart name = case rawVal of
  (Just "") -> Nothing
  (Just x) -> Just x
  Nothing -> Nothing
  where
    rawVal =
      fmap head
        . nonEmpty
        . map iValue
        . filter (\i -> iName i == name)
        $ inputs multipart

setCookieRoute :: (MonadError ServerError m) => CookieConfig -> Text -> Map Text Text -> m a
setCookieRoute cookieConfig newLocation cookieMap =
  throwError
    $ ServerError
      { errHTTPCode = 302,
        errReasonPhrase = "Found",
        errBody = "",
        errHeaders =
          ("Location", encodeUtf8 newLocation) : cookieHeaders
      }
  where
    mkCookieHeaders (cookieName, cookieValue) =
      ( "Set-Cookie",
        fromString
          . T.unpack
          . mkCookieData cookieConfig
          $ [trimming|$cookieName=$cookieValue|]
      )
    cookieHeaders = map mkCookieHeaders (Map.assocs cookieMap)

mkCookieData :: CookieConfig -> Text -> Text
mkCookieData cookieConfig dyn = [trimming|$dyn; HttpOnly; $sameSite; Domain=$domain; Path=/; Max-Age=$maxAge $secureSuffix |]
  where
    maxAge = show $ cookieConfig ^. #maxAge
    domain = cookieConfig ^. #domain
    sameSite = cookieConfig ^. #sameSite
    secureSuffix = if cookieConfig ^. #secure then "; Secure" else ""

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

eitherView :: (MonadIO m) => Env -> UiMode -> Language -> Palette -> Either Text t -> (t -> IO Html) -> m Html
eitherView env mode language palette x eff = case x of
  Left e -> liftIO $ exec @View (errorPage env mode language palette e)
  Right r -> liftIO $ eff r

decodeToken :: Text -> Text
decodeToken = decodeUtf8 . B16.decodeLenient . encodeUtf8

encodeToken :: Text -> Text
encodeToken = decodeUtf8 . B16.encode . encodeUtf8

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