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

server :: Env -> Server WikiMusicSSRServant
server env =
  fallbackRoute
    :<|> artistsRoute env
    :<|> artistRoute env
    :<|> artistCreateRoute env
    :<|> artistCreateFormRoute env
    :<|> artistLikeRoute env
    :<|> artistDislikeRoute env
    :<|> genresRoute env
    :<|> genreRoute env
    :<|> genreCreateRoute env
    :<|> songsRoute env
    :<|> songRoute env
    :<|> songCreateRoute env
    :<|> setLanguageRoute env
    :<|> setArtistSortingRoute env
    :<|> setGenreSortingRoute env
    :<|> setSongSortingRoute env
    :<|> setDarkModeRoute env
    :<|> setSongAsciiSizeRoute env
    :<|> setPaletteRoute env
    :<|> loginFormRoute env
    :<|> submitLoginRoute 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
        }