content: {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE TypeOperators #-}
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  
  -- |
  -- SPDX-License-Identifier: BSD-3-Clause
  --
  -- A web service for serving Swarm tournaments.
  module Swarm.Web.Tournament (
    defaultPort,
    AppData (..),
    GitHubCredentials (..),
    DeploymentEnvironment (..),
  
    -- ** Development
    webMain,
    app,
  ) where
  
  import Codec.Picture
  import Commonmark qualified as Mark (commonmark, renderHtml)
  import Control.Lens hiding (Context)
  import Control.Monad.IO.Class (liftIO)
  import Control.Monad.Trans.Except
  import Control.Monad.Trans.Reader (runReaderT)
  import Data.Aeson
  import Data.ByteString qualified as BS
  import Data.ByteString.Lazy qualified as LBS
  import Data.Either.Extra (maybeToEither)
  import Data.Int (Int64)
  import Data.Map (Map)
  import Data.Map qualified as M
  import Data.Maybe (fromMaybe)
  import Data.Text qualified as T
  import Data.Text.Lazy qualified as TL
  import Data.Text.Lazy.Encoding (decodeUtf8, decodeUtf8', encodeUtf8)
  import Data.Yaml (decodeEither', defaultEncodeOptions, encodeWith)
  import Database.SQLite.Simple (withConnection)
  import GHC.Generics (Generic)
  import Network.HTTP.Client qualified as HC
  import Network.HTTP.Client.TLS (tlsManagerSettings)
  import Network.HTTP.Types (hCookie, ok200, renderSimpleQuery)
  import Network.Wai (Request, requestHeaders, responseLBS)
  import Network.Wai.Application.Static (defaultFileServerSettings)
  import Network.Wai.Handler.Warp qualified as Warp
  import Network.Wai.Parse (
    defaultParseRequestBodyOptions,
    setMaxRequestFileSize,
    setMaxRequestKeyLength,
    setMaxRequestNumFiles,
   )
  import Servant
  import Servant.JuicyPixels (PNG)
  import Servant.Multipart
  import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler)
  import Swarm.Game.Scenario (ScenarioMetadata, scenarioMetadata)
  import Swarm.Game.State (Sha1 (..))
  import Swarm.Game.World.Render
  import Swarm.Web.Auth
  import Swarm.Web.Tournament.Database.Query
  import Swarm.Web.Tournament.Type
  import Swarm.Web.Tournament.Validate
  import Swarm.Web.Tournament.Validate.FailureMode
  import Swarm.Web.Tournament.Validate.Upload
  import Web.Cookie
  
  defaultPort :: Warp.Port
  defaultPort = 5500
  
  -- | NOTE: The default Servant server timeout is 30 sec;
  -- see https://hackage.haskell.org/package/http-client-0.7.17/docs/Network-HTTP-Client-Internal.html#t:ResponseTimeout
  defaultSolutionTimeout :: SolutionTimeout
  defaultSolutionTimeout = SolutionTimeout 20
  
  data DeploymentEnvironment
    = LocalDevelopment UserAlias
    | ProdDeployment
  
  data AppData = AppData
    { swarmGameGitVersion :: Sha1
    , gitHubCredentials :: GitHubCredentials
    , persistence :: PersistenceLayer IO
    , developmentMode :: DeploymentEnvironment
    }
  
  type LoginType = Headers '[Header "Location" TL.Text, Header "Set-Cookie" SetCookie] NoContent
  type LoginHandler = Handler LoginType
  
  type TournamentAPI =
    "api" :> "private" :> "upload" :> "scenario" :> Header "Referer" TL.Text :> AuthProtect "cookie-auth" :> MultipartForm Mem (MultipartData Mem) :> Verb 'POST 303 '[JSON] (Headers '[Header "Location" TL.Text] ScenarioCharacterization)
      :<|> "api" :> "private" :> "upload" :> "solution" :> Header "Referer" TL.Text :> AuthProtect "cookie-auth" :> MultipartForm Mem (MultipartData Mem) :> Verb 'POST 303 '[JSON] (Headers '[Header "Location" TL.Text] SolutionFileCharacterization)
      :<|> "scenario" :> Capture "sha1" Sha1 :> "metadata" :> Get '[JSON] ScenarioMetadata
      :<|> "scenario" :> Capture "sha1" Sha1 :> "fetch" :> Get '[PlainText] TL.Text
      :<|> "scenario" :> Capture "sha1" Sha1 :> "thumbnail" :> Get '[PNG] DynamicImage
      :<|> "solution" :> Capture "sha1" Sha1 :> "fetch" :> Get '[PlainText] TL.Text
      :<|> "list" :> "games" :> Get '[JSON] [TournamentGame]
      :<|> "list" :> "game" :> Capture "sha1" Sha1 :> Get '[JSON] GameWithSolutions
      :<|> "api" :> "private" :> "login" :> "status" :> AuthProtect "cookie-auth" :> Get '[JSON] UserAlias
      :<|> "github-auth-callback" :> QueryParam "code" TokenExchangeCode :> Verb 'GET 303 '[JSON] LoginType
      :<|> "api" :> "private" :> "login" :> "local" :> Header "Referer" TL.Text :> Verb 'GET 303 '[JSON] LoginType
      :<|> "api" :> "private" :> "login" :> "logout" :> Header "Referer" TL.Text :> Verb 'GET 303 '[JSON] LoginType
  
  mkApp :: AppData -> Servant.Server TournamentAPI
  mkApp appData =
    uploadScenario appData
      :<|> uploadSolution appData
      :<|> getScenarioMetadata appData
      :<|> downloadRedactedScenario appData
      :<|> renderThumbnail appData
      :<|> downloadSolution appData
      :<|> listScenarios
      :<|> listSolutions
      :<|> echoUsername
      :<|> doGithubCallback (authenticationStorage $ persistence appData) (gitHubCredentials appData)
      :<|> doLocalDevelopmentLogin (authenticationStorage $ persistence appData) (developmentMode appData)
      :<|> doLogout
   where
    echoUsername = return
  
  type ToplevelAPI =
    TournamentAPI
      :<|> "api" :> Raw
      :<|> Raw
  
  tournamentsApiHtml :: LBS.ByteString
  tournamentsApiHtml =
    encodeUtf8
      . either (TL.pack . show) (Mark.renderHtml @())
      . Mark.commonmark ""
      $ T.pack "No documentation at this time."
  
  toServantError :: Describable a => a -> ServerError
  toServantError x = err500 {errBody = encodeUtf8 $ TL.fromStrict $ describeText x}
  
  -- | We need to specify the data returned after authentication
  type instance AuthServerData (AuthProtect "cookie-auth") = UserAlias
  
  myAppCookieName :: BS.ByteString
  myAppCookieName = "servant-auth-cookie"
  
  data LoginProblem = LoginProblem
    { problemMessage :: TL.Text
    , loginLink :: TL.Text
    }
    deriving (Generic, ToJSON)
  
  --- | The auth handler wraps a function from Request -> Handler UserAlias.
  --- We look for a token in the request headers that we expect to be in the cookie.
  --- The token is then passed to our `lookupAccount` function.
  authHandler ::
    AuthenticationStorage IO ->
    GitHubCredentials ->
    DeploymentEnvironment ->
    AuthHandler Request UserAlias
  authHandler authStorage creds deployMode = mkAuthHandler handler
   where
    url = case deployMode of
      LocalDevelopment _ -> "api/private/login/local"
      ProdDeployment -> decodeUtf8 . LBS.fromStrict $ genLoginUrl creds
  
    throw401 msg = throwError $ err401 {errBody = encode $ LoginProblem msg url}
    handler req = either throw401 lookupAccount $ do
      cookie <- maybeToEither "Missing cookie header" $ lookup hCookie $ requestHeaders req
      maybeToEither "Missing token in cookie"
        . fmap (decodeUtf8 . LBS.fromStrict)
        . lookup myAppCookieName
        $ parseCookies cookie
  
    -- A method that, when given a cookie/password, will return a 'UserAlias'.
    lookupAccount :: TL.Text -> Handler UserAlias
    lookupAccount cookieText = do
      maybeUser <- liftIO $ usernameFromCookie authStorage cookieText
      case maybeUser of
        Nothing -> throwError (err403 {errBody = encode $ LoginProblem "Invalid cookie password" url})
        Just usr -> return usr
  
  -- * Handlers
  
  defaultRedirectPage :: TL.Text
  defaultRedirectPage = "/list-games.html"
  
  defaultSolutionSubmissionRedirectPage :: TL.Text
  defaultSolutionSubmissionRedirectPage = "/list-solutions.html"
  
  uploadScenario ::
    AppData ->
    Maybe TL.Text ->
    UserAlias ->
    MultipartData Mem ->
    Handler (Headers '[Header "Location" TL.Text] ScenarioCharacterization)
  uploadScenario (AppData gameVersion _ persistenceLayer _) maybeRefererUrl userName multipartData =
    Handler . fmap addH . withExceptT toServantError . ExceptT $
      validateScenarioUpload
        args
        gameVersion
   where
    addH = addHeader (fromMaybe defaultRedirectPage maybeRefererUrl)
    args =
      CommonValidationArgs
        defaultSolutionTimeout
        $ PersistenceArgs
          userName
          multipartData
          (scenarioStorage persistenceLayer)
  
  uploadSolution ::
    AppData ->
    Maybe TL.Text ->
    UserAlias ->
    MultipartData Mem ->
    Handler (Headers '[Header "Location" TL.Text] SolutionFileCharacterization)
  uploadSolution (AppData _ _ persistenceLayer _) maybeRefererUrl userName multipartData =
    Handler . fmap addH . withExceptT toServantError . ExceptT $
      validateSubmittedSolution
        args
        ((getContent . scenarioStorage) persistenceLayer)
   where
    addH = addHeader (fromMaybe defaultSolutionSubmissionRedirectPage maybeRefererUrl)
    args =
      CommonValidationArgs
        defaultSolutionTimeout
        $ PersistenceArgs
          userName
          multipartData
          (solutionStorage persistenceLayer)
  
  getScenarioMetadata :: AppData -> Sha1 -> Handler ScenarioMetadata
  getScenarioMetadata (AppData _ _ persistenceLayer _) scenarioSha1 =
    Handler . withExceptT toServantError $ do
      doc <-
        ExceptT $
          maybeToEither (DatabaseRetrievalFailure scenarioSha1)
            <$> (getContent . scenarioStorage) persistenceLayer scenarioSha1
  
      s <- withExceptT RetrievedInstantiationFailure $ initScenarioObjectWithEnv doc
      return $ view scenarioMetadata s
  
  genLoginUrl :: GitHubCredentials -> BS.ByteString
  genLoginUrl creds =
    "https://github.com/login/oauth/authorize"
      <> renderSimpleQuery
        True
        [ ("client_id", clientId creds)
        ]
  
  downloadSolution :: AppData -> Sha1 -> Handler TL.Text
  downloadSolution (AppData _ _ persistenceLayer _) solutionSha1 = do
    Handler . withExceptT toServantError $ do
      ExceptT $
        maybeToEither (DatabaseRetrievalFailure solutionSha1)
          <$> (fmap $ fmap decodeUtf8) ((getContent . solutionStorage) persistenceLayer solutionSha1)
  
  downloadRedactedScenario :: AppData -> Sha1 -> Handler TL.Text
  downloadRedactedScenario (AppData _ _ persistenceLayer _) scenarioSha1 = do
    Handler . withExceptT toServantError $ do
      doc <-
        ExceptT $
          maybeToEither (DatabaseRetrievalFailure scenarioSha1)
            <$> (getContent . scenarioStorage) persistenceLayer scenarioSha1
  
      rawYamlDict :: Map Key Value <- withExceptT YamlParseFailure . except . decodeEither' $ LBS.toStrict doc
      let redactedDict = M.delete "solution" rawYamlDict
      withExceptT DecodingFailure . except . decodeUtf8' . LBS.fromStrict $
        encodeWith defaultEncodeOptions redactedDict
  
  renderThumbnail :: AppData -> Sha1 -> Handler DynamicImage
  renderThumbnail (AppData _ _ persistenceLayer _) scenarioSha1 = do
    Handler . withExceptT toServantError $ do
      doc <-
        ExceptT $
          maybeToEither (DatabaseRetrievalFailure scenarioSha1)
            <$> (getContent . scenarioStorage) persistenceLayer scenarioSha1
  
      s <- withExceptT RetrievedInstantiationFailure $ initScenarioObjectWithEnv doc
      g <- getRenderableGrid (RenderComputationContext Nothing Nothing) s
      return $ ImageRGBA8 $ renderImage g
  
  listScenarios :: Handler [TournamentGame]
  listScenarios =
    Handler . liftIO . withConnection databaseFilename $ runReaderT listGames
  
  listSolutions :: Sha1 -> Handler GameWithSolutions
  listSolutions sha1 =
    Handler . liftIO . withConnection databaseFilename . runReaderT $ listSubmissions sha1
  
  doGithubCallback ::
    AuthenticationStorage IO ->
    GitHubCredentials ->
    Maybe TokenExchangeCode ->
    LoginHandler
  doGithubCallback authStorage creds maybeCode = do
    c <- maybe (fail "Missing 'code' parameter") return maybeCode
  
    manager <- liftIO $ HC.newManager tlsManagerSettings
    receivedTokens <- exchangeCode manager creds c
  
    let aToken = token $ accessToken receivedTokens
    userInfo <- fetchAuthenticatedUser manager aToken
    let user = UserAlias $ login userInfo
    x <- doLoginResponse authStorage defaultRedirectPage user
    liftIO . withConnection databaseFilename . runReaderT $ do
      insertGitHubTokens user receivedTokens
    return x
  
  doLocalDevelopmentLogin ::
    AuthenticationStorage IO ->
    DeploymentEnvironment ->
    Maybe TL.Text ->
    LoginHandler
  doLocalDevelopmentLogin authStorage envType maybeRefererUrl =
    case envType of
      ProdDeployment -> error "Login bypass not available in production"
      -- The above call to `error` can cause the tournament server to
      -- crash on startup, but not the game itself.
      LocalDevelopment user ->
        doLoginResponse authStorage refererUrl user
   where
    refererUrl = fromMaybe defaultRedirectPage maybeRefererUrl
  
  makeCookieHeader :: BS.ByteString -> SetCookie
  makeCookieHeader val =
    defaultSetCookie
      { setCookieName = myAppCookieName
      , setCookieValue = val
      , setCookiePath = Just "/api/private"
      }
  
  doLogout :: Maybe TL.Text -> LoginHandler
  doLogout maybeRefererUrl =
    return $
      addHeader (fromMaybe defaultRedirectPage maybeRefererUrl) $
        addHeader ((makeCookieHeader "") {setCookieMaxAge = Just 0}) NoContent
  
  doLoginResponse ::
    AuthenticationStorage IO ->
    TL.Text ->
    UserAlias ->
    LoginHandler
  doLoginResponse authStorage refererUrl userAlias = do
    cookieString <-
      liftIO $ cookieFromUsername authStorage userAlias
    return $
      addHeader refererUrl $
        addHeader (makeCookieHeader $ LBS.toStrict $ encodeUtf8 cookieString) NoContent
  
  -- * Web app declaration
  
  app :: Bool -> AppData -> Application
  app unitTestFileserver appData =
    Servant.serveWithContext (Proxy :: Proxy ToplevelAPI) context $
      server unitTestFileserver
   where
    size100kB = 100_000 :: Int64
  
    multipartOpts :: MultipartOptions Mem
    multipartOpts =
      (defaultMultipartOptions (Proxy :: Proxy Mem))
        { generalOptions =
            setMaxRequestFileSize size100kB
              . setMaxRequestKeyLength 64
              . setMaxRequestNumFiles 1
              $ defaultParseRequestBodyOptions
        }
  
    thisAuthHandler =
      authHandler
        (authenticationStorage $ persistence appData)
        (gitHubCredentials appData)
        (developmentMode appData)
    context = thisAuthHandler :. multipartOpts :. EmptyContext
  
    server :: Bool -> Server ToplevelAPI
    server fakeFileserverForUnitTest =
      mkApp appData
        :<|> Tagged serveDocs
        :<|> fileserver
     where
      fileserver =
        if fakeFileserverForUnitTest
          then -- This is required because the data only files available to
          -- the testing environment are included in the cabal file
          -- in the "data-files" clause.
          -- However, since that clause is global to the package,
          -- we choose not to include the tournament server's web
          -- files there.
          -- Instead, we manually stub the paths that are used as redirects
          -- so that the web API invocation does not 404 when looking for them.
            serveDirectoryEmbedded
              [ (TL.unpack defaultRedirectPage, "Hello World!")
              , (TL.unpack defaultSolutionSubmissionRedirectPage, "Hello World!")
              ]
          else
            serveDirectoryWith
              (defaultFileServerSettings "tournament/web")
  
      serveDocs _ resp =
        resp $ responseLBS ok200 [htmlType] tournamentsApiHtml
      htmlType = ("Content-Type", "text/html")
  
  webMain ::
    AppData ->
    Warp.Port ->
    IO ()
  webMain appData port = Warp.runSettings settings $ app False appData
   where
    settings = Warp.setPort port Warp.defaultSettings
  