ApiSetup.hs

{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoFieldSelectors #-}

module WikiMusic.Servant.ApiSetup
  ( mkApp,
    WikiMusicPrivateAPI,
    WikiMusicPublicAPI,
    WikiMusicAPIServer,
    wiredUpPrivateServer,
    wiredUpPublicServer,
  )
where

import Data.ByteString.Char8 qualified as C8
import Data.OpenApi qualified
import Data.Proxy
import Data.Text (unpack)
import Database.Redis qualified as Redis
import Hasql.Pool qualified
import Network.Wai
import Network.Wai.Middleware.Cors
import Network.Wai.RateLimit
import Network.Wai.RateLimit.Redis
import Network.Wai.RateLimit.Strategy
import Relude
import Servant
import Servant.OpenApi
import WikiMusic.Model.Config
import WikiMusic.Model.Env
import WikiMusic.Protolude
import WikiMusic.Servant.ApiSpec
import WikiMusic.Servant.ArtistRoutes
import WikiMusic.Servant.AuthRoutes
import WikiMusic.Servant.GenreRoutes
import WikiMusic.Servant.SongRoutes
import WikiMusic.Servant.UserRoutes
import WikiMusic.Servant.Utilities

swagger :: Servant.Handler Data.OpenApi.OpenApi
swagger = pure $ toOpenApi docsProxy

apiProxy :: Proxy WikiMusicAPIServer
apiProxy = Proxy

docsProxy :: Proxy WikiMusicAPIDocsServer
docsProxy = Proxy

myCors :: CorsConfig -> Middleware
myCors cfg = cors (const $ Just policy)
  where
    policy =
      CorsResourcePolicy
        { corsOrigins = Just (map (fromString . unpack) (cfg ^. #origins), True),
          corsMethods = map (fromString . unpack) (cfg ^. #methods),
          corsRequestHeaders = map (fromString . unpack) (cfg ^. #requestHeaders),
          corsExposedHeaders =
            Just
              [ "x-wikimusic-auth",
                "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
        }

-- cookieSettings :: CookieConfig -> CookieSettings
-- cookieSettings cfg =
--   CookieSettings
--     { cookieIsSecure = fromMaybe NotSecure $ readMaybe (unpack $ cfg ^. #secure),
--       cookieMaxAge = Just $ secondsToDiffTime (fromIntegral $ cfg ^. #maxAge),
--       cookieExpires = Nothing,
--       cookiePath = Just (fromString . unpack $ cfg ^. #path),
--       cookieDomain = Just (fromString . unpack $ cfg ^. #domain),
--       cookieSameSite = fromMaybe AnySite $ readMaybe (unpack $ cfg ^. #sameSite),
--       sessionCookieName = fromString . unpack $ cfg ^. #sessionCookieName,
--       cookieXsrfSetting = Nothing
--     }

mkApp :: AppConfig -> Hasql.Pool.Pool -> Redis.Connection -> IO Application
mkApp cfg pool redisConn = do
  now <- getCurrentTime

  let env = Env {pool = pool, cfg = cfg, processStartedAt = now}
      authCfg = authCheckIO env
      apiCfg = authCfg :. EmptyContext
      apiItself =
        wiredUpPrivateServer env
          :<|> ( swagger
                   :<|> wiredUpPublicServer env
               )

  pure
    . myCors (cfg ^. #cors)
    . rateLimitingMiddleware redisConn
    $ serveWithContext apiProxy apiCfg apiItself

wiredUpPrivateServer :: Env -> Server WikiMusicPrivateAPI
wiredUpPrivateServer env =
  artistHandlers env :<|> genreHandlers env :<|> songHandlers env :<|> authHandlers env

artistHandlers :: Env -> Server WikiMusicPrivateArtistsAPI
artistHandlers env =
  fetchArtistsRoute env
    :<|> searchArtistsRoute env
    :<|> fetchArtistRoute env
    :<|> insertArtistsRoute env
    :<|> insertArtistCommentsRoute env
    :<|> upsertArtistOpinionsRoute env
    :<|> insertArtistArtworksRoute env
    :<|> deleteArtistsByIdentifierRoute env
    :<|> deleteArtistCommentsByIdentifierRoute env
    :<|> deleteArtistOpinionsByIdentifierRoute env
    :<|> deleteArtistArtworksByIdentifierRoute env
    :<|> updateArtistArtworksOrderRoute env
    :<|> updateArtistRoute env

genreHandlers :: Env -> Server WikiMusicPrivateGenresAPI
genreHandlers env =
  fetchGenresRoute env
    :<|> searchGenresRoute env
    :<|> fetchGenreRoute env
    :<|> insertGenresRoute env
    :<|> insertGenreCommentsRoute env
    :<|> upsertGenreOpinionsRoute env
    :<|> insertGenreArtworksRoute env
    :<|> deleteGenresByIdentifierRoute env
    :<|> deleteGenreCommentsByIdentifierRoute env
    :<|> deleteGenreOpinionsByIdentifierRoute env
    :<|> deleteGenreArtworksByIdentifierRoute env
    :<|> updateGenreArtworksOrderRoute env
    :<|> updateGenreRoute env

songHandlers :: Env -> Server WikiMusicPrivateSongsAPI
songHandlers env =
  fetchSongsRoute env
    :<|> searchSongsRoute env
    :<|> fetchSongRoute env
    :<|> insertSongsRoute env
    :<|> insertSongCommentsRoute env
    :<|> upsertSongOpinionsRoute env
    :<|> insertSongArtworksRoute env
    :<|> insertArtistOfSongRoute env
    :<|> deleteArtistOfSongRoute env
    :<|> deleteSongsByIdentifierRoute env
    :<|> deleteSongCommentsByIdentifierRoute env
    :<|> deleteSongOpinionsByIdentifierRoute env
    :<|> deleteSongArtworksByIdentifierRoute env
    :<|> updateSongArtworksOrderRoute env
    :<|> updateSongRoute env
    :<|> insertSongContentsRoute env
    :<|> deleteSongContentsByIdentifierRoute env
    :<|> updateSongContentsRoute env

authHandlers :: Env -> Server WikiMusicPrivateAuthAPI
authHandlers env =
  fetchMeRoute env
    :<|> inviteUserRoute env
    :<|> deleteUserRoute env

wiredUpPublicServer :: Env -> Server WikiMusicPublicAPI
wiredUpPublicServer env =
  loginRoute env
    :<|> makeResetPasswordLinkRoute env
    :<|> doPasswordResetRoute env
    :<|> systemInformationRoute env

rateLimitingMiddleware :: Redis.Connection -> Middleware
rateLimitingMiddleware conn = rateLimiting strategy {strategyOnRequest = customController}
  where
    backend = redisBackend conn
    getKey = pure . C8.pack . Relude.show . remoteHost
    strategy = slidingWindow backend 30 15 getKey
    customController req =
      if rawPathInfo req == "/login"
        then strategyOnRequest strategy req
        else pure True