ApiSetup.hs

{-# LANGUAGE OverloadedLabels #-}

module WikiMusic.SSR.Servant.ApiSetup (mkApp) where

import Data.Text qualified as T
import Data.Time
import Network.HTTP.Client (newManager)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.Wai
import Network.Wai.Middleware.Cors
import Optics
import Relude
import Servant
import Servant.Client
import WikiMusic.SSR.Backend.Rest ()
import WikiMusic.SSR.Model.Config
import WikiMusic.SSR.Model.Env
import WikiMusic.SSR.Servant.ApiSpec
import WikiMusic.SSR.Servant.ArtistRoutes
import WikiMusic.SSR.Servant.GenreRoutes
import WikiMusic.SSR.Servant.LoginRoutes
import WikiMusic.SSR.Servant.PreferenceRoutes
import WikiMusic.SSR.Servant.SongRoutes
import WikiMusic.SSR.View.Html ()

newClientEnv :: (MonadIO m) => m ClientEnv
newClientEnv = do
  manager <- liftIO $ newManager tlsManagerSettings
  pure $ clientEnv manager Nothing
  where
    baseUrl' =
      BaseUrl
        { baseUrlScheme = Https,
          baseUrlHost = "api.wikimusic.jointhefreeworld.org",
          baseUrlPort = 443,
          baseUrlPath = ""
        }
    clientEnv manager cookieJar =
      ClientEnv
        { manager = manager,
          baseUrl = baseUrl',
          cookieJar = cookieJar,
          makeClientRequest = defaultMakeClientRequest
        }

mkApp :: AppConfig -> IO Application
mkApp cfg = do
  let apiCfg = EmptyContext
  now <- getZonedTime
  mainCss <- liftIO (readFileBS "resources/css/main.css")
  lightCss <- liftIO (readFileBS "resources/css/light.css")
  darkCss <- liftIO (readFileBS "resources/css/dark.css")
  greenPaletteCss <- liftIO (readFileBS "resources/css/palettes/green.css")
  mauvePaletteCss <- liftIO (readFileBS "resources/css/palettes/mauve.css")
  clientEnv <- newClientEnv
  let env =
        Env
          { cfg = cfg,
            processStartedAt = now,
            reportedVersion = cfg ^. #dev % #reportedVersion,
            mainCss = prepareCSS mainCss,
            darkCss = prepareCSS darkCss,
            lightCss = prepareCSS lightCss,
            clientEnv = clientEnv,
            palettes =
              PalettesCss
                { green = prepareCSS greenPaletteCss,
                  mauve = prepareCSS mauvePaletteCss
                }
          }
  pure
    . myCors (cfg ^. #cors)
    $ serveWithContext wikimusicSSRServant apiCfg (server env)
  where
    prepareCSS = T.filter (\x -> x /= '\n' && x /= '\t') . decodeUtf8

artistBaseEntityRoutes :: Env -> Server BaseEntityRoutes
artistBaseEntityRoutes env =
  artistsRoute env
    :<|> artistRoute env
    :<|> artistCreateRoute env
    :<|> artistCreateFormRoute env
    :<|> artistLikeRoute env
    :<|> artistDislikeRoute env
    :<|> artistEditRoute env

genreBaseEntityRoutes :: Env -> Server BaseEntityRoutes
genreBaseEntityRoutes env =
  genresRoute env
    :<|> genreRoute env
    :<|> genreCreateRoute env
    :<|> genreCreateFormRoute env
    :<|> genreLikeRoute env
    :<|> genreDislikeRoute env
    :<|> genreEditRoute env

songBaseEntityRoutes :: Env -> Server BaseEntityRoutes
songBaseEntityRoutes env =
  songsRoute env
    :<|> songRoute env
    :<|> songCreateRoute env
    :<|> songCreateFormRoute env
    :<|> songLikeRoute env
    :<|> songDislikeRoute env
    :<|> songEditRoute env

preferenceRoutes :: Env -> Server PreferenceRoutes
preferenceRoutes env =
  setLanguageRoute env
    :<|> setArtistSortingRoute env
    :<|> setGenreSortingRoute env
    :<|> setSongSortingRoute env
    :<|> setDarkModeRoute env
    :<|> setSongAsciiSizeRoute env
    :<|> setPaletteRoute env

loginRoutes :: Env -> Server LoginRoutes
loginRoutes env =
  loginFormRoute env
    :<|> submitLoginRoute env

server :: Env -> Server WikiMusicSSRServant
server env =
  fallbackRoute
    :<|> artistBaseEntityRoutes env
    :<|> genreBaseEntityRoutes env
    :<|> songBaseEntityRoutes env
    :<|> preferenceRoutes env
    :<|> loginRoutes env

fallbackRoute :: Handler a
fallbackRoute =
  do
    throwError
    $ ServerError
      { errHTTPCode = 302,
        errReasonPhrase = "Found",
        errBody = "",
        errHeaders = [("Location", "/songs")]
      }

wikimusicSSRServant :: Proxy WikiMusicSSRServant
wikimusicSSRServant = Proxy

myCors :: CorsConfig -> Middleware
myCors cfg = cors (const $ Just policy)
  where
    policy =
      CorsResourcePolicy
        { corsOrigins = Just (map (fromString . T.unpack) (cfg ^. #origins), True),
          corsMethods = map (fromString . T.unpack) (cfg ^. #methods),
          corsRequestHeaders = map (fromString . T.unpack) (cfg ^. #requestHeaders),
          corsExposedHeaders =
            Just
              [ "content-type",
                "date",
                "content-length",
                "access-control-allow-origin",
                "access-control-allow-methods",
                "access-control-allow-headers",
                "access-control-request-method",
                "access-control-request-headers"
              ],
          corsMaxAge = Nothing,
          corsVaryOrigin = False,
          corsRequireOrigin = False,
          corsIgnoreFailures = False
        }