{-# 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 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.Multipart
import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler)
import Swarm.Game.Scenario (ScenarioMetadata, scenarioMetadata)
import Swarm.Game.State (Sha1 (..))
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 :: Port
defaultPort = Port
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
defaultSolutionTimeout = Seconds -> SolutionTimeout
SolutionTimeout Seconds
20

data DeploymentEnvironment
  = LocalDevelopment UserAlias
  | ProdDeployment

data AppData = AppData
  { AppData -> Sha1
swarmGameGitVersion :: Sha1
  , AppData -> GitHubCredentials
gitHubCredentials :: GitHubCredentials
  , AppData -> PersistenceLayer IO
persistence :: PersistenceLayer IO
  , AppData -> DeploymentEnvironment
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
    :<|> "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
-> Server
     (("api"
       :> ("private"
           :> ("upload"
               :> ("scenario"
                   :> (Header "Referer" Text
                       :> (AuthProtect "cookie-auth"
                           :> (MultipartForm Mem (MultipartData Mem)
                               :> Verb
                                    'POST
                                    303
                                    '[JSON]
                                    (Headers
                                       '[Header "Location" Text] ScenarioCharacterization))))))))
      :<|> (("api"
             :> ("private"
                 :> ("upload"
                     :> ("solution"
                         :> (Header "Referer" Text
                             :> (AuthProtect "cookie-auth"
                                 :> (MultipartForm Mem (MultipartData Mem)
                                     :> Verb
                                          'POST
                                          303
                                          '[JSON]
                                          (Headers
                                             '[Header "Location" Text]
                                             SolutionFileCharacterization))))))))
            :<|> (("scenario"
                   :> (Capture "sha1" Sha1
                       :> ("metadata" :> Get '[JSON] ScenarioMetadata)))
                  :<|> (("scenario"
                         :> (Capture "sha1" Sha1 :> ("fetch" :> Get '[PlainText] Text)))
                        :<|> (("solution"
                               :> (Capture "sha1" Sha1 :> ("fetch" :> Get '[PlainText] 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" Text
                                                                             :> Verb
                                                                                  'GET
                                                                                  303
                                                                                  '[JSON]
                                                                                  LoginType)))))
                                                            :<|> ("api"
                                                                  :> ("private"
                                                                      :> ("login"
                                                                          :> ("logout"
                                                                              :> (Header
                                                                                    "Referer" Text
                                                                                  :> Verb
                                                                                       'GET
                                                                                       303
                                                                                       '[JSON]
                                                                                       LoginType)))))))))))))))
mkApp AppData
appData =
  AppData
-> Maybe Text
-> UserAlias
-> MultipartData Mem
-> Handler
     (Headers '[Header "Location" Text] ScenarioCharacterization)
uploadScenario AppData
appData
    (Maybe Text
 -> UserAlias
 -> MultipartData Mem
 -> Handler
      (Headers '[Header "Location" Text] ScenarioCharacterization))
-> ((Maybe Text
     -> UserAlias
     -> MultipartData Mem
     -> Handler
          (Headers '[Header "Location" Text] SolutionFileCharacterization))
    :<|> ((Sha1 -> Handler ScenarioMetadata)
          :<|> ((Sha1 -> Handler Text)
                :<|> ((Sha1 -> Handler Text)
                      :<|> (Handler [TournamentGame]
                            :<|> ((Sha1 -> Handler GameWithSolutions)
                                  :<|> ((UserAlias -> Handler UserAlias)
                                        :<|> ((Maybe TokenExchangeCode -> LoginHandler)
                                              :<|> ((Maybe Text -> LoginHandler)
                                                    :<|> (Maybe Text -> LoginHandler))))))))))
-> (Maybe Text
    -> UserAlias
    -> MultipartData Mem
    -> Handler
         (Headers '[Header "Location" Text] ScenarioCharacterization))
   :<|> ((Maybe Text
          -> UserAlias
          -> MultipartData Mem
          -> Handler
               (Headers '[Header "Location" Text] SolutionFileCharacterization))
         :<|> ((Sha1 -> Handler ScenarioMetadata)
               :<|> ((Sha1 -> Handler Text)
                     :<|> ((Sha1 -> Handler Text)
                           :<|> (Handler [TournamentGame]
                                 :<|> ((Sha1 -> Handler GameWithSolutions)
                                       :<|> ((UserAlias -> Handler UserAlias)
                                             :<|> ((Maybe TokenExchangeCode -> LoginHandler)
                                                   :<|> ((Maybe Text -> LoginHandler)
                                                         :<|> (Maybe Text -> LoginHandler))))))))))
forall a b. a -> b -> a :<|> b
:<|> AppData
-> Maybe Text
-> UserAlias
-> MultipartData Mem
-> Handler
     (Headers '[Header "Location" Text] SolutionFileCharacterization)
uploadSolution AppData
appData
    (Maybe Text
 -> UserAlias
 -> MultipartData Mem
 -> Handler
      (Headers '[Header "Location" Text] SolutionFileCharacterization))
-> ((Sha1 -> Handler ScenarioMetadata)
    :<|> ((Sha1 -> Handler Text)
          :<|> ((Sha1 -> Handler Text)
                :<|> (Handler [TournamentGame]
                      :<|> ((Sha1 -> Handler GameWithSolutions)
                            :<|> ((UserAlias -> Handler UserAlias)
                                  :<|> ((Maybe TokenExchangeCode -> LoginHandler)
                                        :<|> ((Maybe Text -> LoginHandler)
                                              :<|> (Maybe Text -> LoginHandler)))))))))
-> (Maybe Text
    -> UserAlias
    -> MultipartData Mem
    -> Handler
         (Headers '[Header "Location" Text] SolutionFileCharacterization))
   :<|> ((Sha1 -> Handler ScenarioMetadata)
         :<|> ((Sha1 -> Handler Text)
               :<|> ((Sha1 -> Handler Text)
                     :<|> (Handler [TournamentGame]
                           :<|> ((Sha1 -> Handler GameWithSolutions)
                                 :<|> ((UserAlias -> Handler UserAlias)
                                       :<|> ((Maybe TokenExchangeCode -> LoginHandler)
                                             :<|> ((Maybe Text -> LoginHandler)
                                                   :<|> (Maybe Text -> LoginHandler)))))))))
forall a b. a -> b -> a :<|> b
:<|> AppData -> Sha1 -> Handler ScenarioMetadata
getScenarioMetadata AppData
appData
    (Sha1 -> Handler ScenarioMetadata)
-> ((Sha1 -> Handler Text)
    :<|> ((Sha1 -> Handler Text)
          :<|> (Handler [TournamentGame]
                :<|> ((Sha1 -> Handler GameWithSolutions)
                      :<|> ((UserAlias -> Handler UserAlias)
                            :<|> ((Maybe TokenExchangeCode -> LoginHandler)
                                  :<|> ((Maybe Text -> LoginHandler)
                                        :<|> (Maybe Text -> LoginHandler))))))))
-> (Sha1 -> Handler ScenarioMetadata)
   :<|> ((Sha1 -> Handler Text)
         :<|> ((Sha1 -> Handler Text)
               :<|> (Handler [TournamentGame]
                     :<|> ((Sha1 -> Handler GameWithSolutions)
                           :<|> ((UserAlias -> Handler UserAlias)
                                 :<|> ((Maybe TokenExchangeCode -> LoginHandler)
                                       :<|> ((Maybe Text -> LoginHandler)
                                             :<|> (Maybe Text -> LoginHandler))))))))
forall a b. a -> b -> a :<|> b
:<|> AppData -> Sha1 -> Handler Text
downloadRedactedScenario AppData
appData
    (Sha1 -> Handler Text)
-> ((Sha1 -> Handler Text)
    :<|> (Handler [TournamentGame]
          :<|> ((Sha1 -> Handler GameWithSolutions)
                :<|> ((UserAlias -> Handler UserAlias)
                      :<|> ((Maybe TokenExchangeCode -> LoginHandler)
                            :<|> ((Maybe Text -> LoginHandler)
                                  :<|> (Maybe Text -> LoginHandler)))))))
-> (Sha1 -> Handler Text)
   :<|> ((Sha1 -> Handler Text)
         :<|> (Handler [TournamentGame]
               :<|> ((Sha1 -> Handler GameWithSolutions)
                     :<|> ((UserAlias -> Handler UserAlias)
                           :<|> ((Maybe TokenExchangeCode -> LoginHandler)
                                 :<|> ((Maybe Text -> LoginHandler)
                                       :<|> (Maybe Text -> LoginHandler)))))))
forall a b. a -> b -> a :<|> b
:<|> AppData -> Sha1 -> Handler Text
downloadSolution AppData
appData
    (Sha1 -> Handler Text)
-> (Handler [TournamentGame]
    :<|> ((Sha1 -> Handler GameWithSolutions)
          :<|> ((UserAlias -> Handler UserAlias)
                :<|> ((Maybe TokenExchangeCode -> LoginHandler)
                      :<|> ((Maybe Text -> LoginHandler)
                            :<|> (Maybe Text -> LoginHandler))))))
-> (Sha1 -> Handler Text)
   :<|> (Handler [TournamentGame]
         :<|> ((Sha1 -> Handler GameWithSolutions)
               :<|> ((UserAlias -> Handler UserAlias)
                     :<|> ((Maybe TokenExchangeCode -> LoginHandler)
                           :<|> ((Maybe Text -> LoginHandler)
                                 :<|> (Maybe Text -> LoginHandler))))))
forall a b. a -> b -> a :<|> b
:<|> Handler [TournamentGame]
listScenarios
    Handler [TournamentGame]
-> ((Sha1 -> Handler GameWithSolutions)
    :<|> ((UserAlias -> Handler UserAlias)
          :<|> ((Maybe TokenExchangeCode -> LoginHandler)
                :<|> ((Maybe Text -> LoginHandler)
                      :<|> (Maybe Text -> LoginHandler)))))
-> Handler [TournamentGame]
   :<|> ((Sha1 -> Handler GameWithSolutions)
         :<|> ((UserAlias -> Handler UserAlias)
               :<|> ((Maybe TokenExchangeCode -> LoginHandler)
                     :<|> ((Maybe Text -> LoginHandler)
                           :<|> (Maybe Text -> LoginHandler)))))
forall a b. a -> b -> a :<|> b
:<|> Sha1 -> Handler GameWithSolutions
listSolutions
    (Sha1 -> Handler GameWithSolutions)
-> ((UserAlias -> Handler UserAlias)
    :<|> ((Maybe TokenExchangeCode -> LoginHandler)
          :<|> ((Maybe Text -> LoginHandler)
                :<|> (Maybe Text -> LoginHandler))))
-> (Sha1 -> Handler GameWithSolutions)
   :<|> ((UserAlias -> Handler UserAlias)
         :<|> ((Maybe TokenExchangeCode -> LoginHandler)
               :<|> ((Maybe Text -> LoginHandler)
                     :<|> (Maybe Text -> LoginHandler))))
forall a b. a -> b -> a :<|> b
:<|> UserAlias -> Handler UserAlias
forall {a}. a -> Handler a
echoUsername
    (UserAlias -> Handler UserAlias)
-> ((Maybe TokenExchangeCode -> LoginHandler)
    :<|> ((Maybe Text -> LoginHandler)
          :<|> (Maybe Text -> LoginHandler)))
-> (UserAlias -> Handler UserAlias)
   :<|> ((Maybe TokenExchangeCode -> LoginHandler)
         :<|> ((Maybe Text -> LoginHandler)
               :<|> (Maybe Text -> LoginHandler)))
forall a b. a -> b -> a :<|> b
:<|> AuthenticationStorage IO
-> GitHubCredentials -> Maybe TokenExchangeCode -> LoginHandler
doGithubCallback (PersistenceLayer IO -> AuthenticationStorage IO
forall (m :: * -> *). PersistenceLayer m -> AuthenticationStorage m
authenticationStorage (PersistenceLayer IO -> AuthenticationStorage IO)
-> PersistenceLayer IO -> AuthenticationStorage IO
forall a b. (a -> b) -> a -> b
$ AppData -> PersistenceLayer IO
persistence AppData
appData) (AppData -> GitHubCredentials
gitHubCredentials AppData
appData)
    (Maybe TokenExchangeCode -> LoginHandler)
-> ((Maybe Text -> LoginHandler) :<|> (Maybe Text -> LoginHandler))
-> (Maybe TokenExchangeCode -> LoginHandler)
   :<|> ((Maybe Text -> LoginHandler)
         :<|> (Maybe Text -> LoginHandler))
forall a b. a -> b -> a :<|> b
:<|> AuthenticationStorage IO
-> DeploymentEnvironment -> Maybe Text -> LoginHandler
doLocalDevelopmentLogin (PersistenceLayer IO -> AuthenticationStorage IO
forall (m :: * -> *). PersistenceLayer m -> AuthenticationStorage m
authenticationStorage (PersistenceLayer IO -> AuthenticationStorage IO)
-> PersistenceLayer IO -> AuthenticationStorage IO
forall a b. (a -> b) -> a -> b
$ AppData -> PersistenceLayer IO
persistence AppData
appData) (AppData -> DeploymentEnvironment
developmentMode AppData
appData)
    (Maybe Text -> LoginHandler)
-> (Maybe Text -> LoginHandler)
-> (Maybe Text -> LoginHandler) :<|> (Maybe Text -> LoginHandler)
forall a b. a -> b -> a :<|> b
:<|> Maybe Text -> LoginHandler
doLogout
 where
  echoUsername :: a -> Handler a
echoUsername = a -> Handler a
forall {a}. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return

type ToplevelAPI =
  TournamentAPI
    :<|> "api" :> Raw
    :<|> Raw

tournamentsApiHtml :: LBS.ByteString
tournamentsApiHtml :: ByteString
tournamentsApiHtml =
  Text -> ByteString
encodeUtf8
    (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParseError -> Text)
-> (Html () -> Text) -> Either ParseError (Html ()) -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> Text
forall a. HasCallStack => [Char] -> a
error ([Char] -> Text) -> (ParseError -> [Char]) -> ParseError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> [Char]
forall a. Show a => a -> [Char]
show) (forall a. Html a -> Text
Mark.renderHtml @())
    (Either ParseError (Html ()) -> Text)
-> (Text -> Either ParseError (Html ())) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text -> Either ParseError (Html ())
forall il bl.
IsBlock il bl =>
[Char] -> Text -> Either ParseError bl
Mark.commonmark [Char]
""
    (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
"No documentation at this time."

toServantError :: Describable a => a -> ServerError
toServantError :: forall a. Describable a => a -> ServerError
toServantError a
x = ServerError
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 :: ByteString
myAppCookieName = ByteString
"servant-auth-cookie"

data LoginProblem = LoginProblem
  { LoginProblem -> Text
problemMessage :: TL.Text
  , LoginProblem -> Text
loginLink :: TL.Text
  }
  deriving ((forall x. LoginProblem -> Rep LoginProblem x)
-> (forall x. Rep LoginProblem x -> LoginProblem)
-> Generic LoginProblem
forall x. Rep LoginProblem x -> LoginProblem
forall x. LoginProblem -> Rep LoginProblem x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LoginProblem -> Rep LoginProblem x
from :: forall x. LoginProblem -> Rep LoginProblem x
$cto :: forall x. Rep LoginProblem x -> LoginProblem
to :: forall x. Rep LoginProblem x -> LoginProblem
Generic, [LoginProblem] -> Value
[LoginProblem] -> Encoding
LoginProblem -> Bool
LoginProblem -> Value
LoginProblem -> Encoding
(LoginProblem -> Value)
-> (LoginProblem -> Encoding)
-> ([LoginProblem] -> Value)
-> ([LoginProblem] -> Encoding)
-> (LoginProblem -> Bool)
-> ToJSON LoginProblem
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: LoginProblem -> Value
toJSON :: LoginProblem -> Value
$ctoEncoding :: LoginProblem -> Encoding
toEncoding :: LoginProblem -> Encoding
$ctoJSONList :: [LoginProblem] -> Value
toJSONList :: [LoginProblem] -> Value
$ctoEncodingList :: [LoginProblem] -> Encoding
toEncodingList :: [LoginProblem] -> Encoding
$comitField :: LoginProblem -> Bool
omitField :: LoginProblem -> Bool
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 :: AuthenticationStorage IO
-> GitHubCredentials
-> DeploymentEnvironment
-> AuthHandler Request UserAlias
authHandler AuthenticationStorage IO
authStorage GitHubCredentials
creds DeploymentEnvironment
deployMode = (Request -> Handler UserAlias) -> AuthHandler Request UserAlias
forall r usr. (r -> Handler usr) -> AuthHandler r usr
mkAuthHandler Request -> Handler UserAlias
handler
 where
  url :: Text
url = case DeploymentEnvironment
deployMode of
    LocalDevelopment UserAlias
_ -> Text
"api/private/login/local"
    DeploymentEnvironment
ProdDeployment -> ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.fromStrict (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ GitHubCredentials -> ByteString
genLoginUrl GitHubCredentials
creds

  throw401 :: Text -> Handler UserAlias
throw401 Text
msg = ServerError -> Handler UserAlias
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ServerError -> Handler UserAlias)
-> ServerError -> Handler UserAlias
forall a b. (a -> b) -> a -> b
$ ServerError
err401 {errBody = encode $ LoginProblem msg url}
  handler :: Request -> Handler UserAlias
handler Request
req = (Text -> Handler UserAlias)
-> (Text -> Handler UserAlias)
-> Either Text Text
-> Handler UserAlias
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Handler UserAlias
throw401 Text -> Handler UserAlias
lookupAccount (Either Text Text -> Handler UserAlias)
-> Either Text Text -> Handler UserAlias
forall a b. (a -> b) -> a -> b
$ do
    ByteString
cookie <- Text -> Maybe ByteString -> Either Text ByteString
forall a b. a -> Maybe b -> Either a b
maybeToEither Text
"Missing cookie header" (Maybe ByteString -> Either Text ByteString)
-> Maybe ByteString -> Either Text ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hCookie ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
requestHeaders Request
req
    Text -> Maybe Text -> Either Text Text
forall a b. a -> Maybe b -> Either a b
maybeToEither Text
"Missing token in cookie"
      (Maybe Text -> Either Text Text)
-> (Cookies -> Maybe Text) -> Cookies -> Either Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.fromStrict)
      (Maybe ByteString -> Maybe Text)
-> (Cookies -> Maybe ByteString) -> Cookies -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Cookies -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
myAppCookieName
      (Cookies -> Either Text Text) -> Cookies -> Either Text Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Cookies
parseCookies ByteString
cookie

  -- A method that, when given a cookie/password, will return a 'UserAlias'.
  lookupAccount :: TL.Text -> Handler UserAlias
  lookupAccount :: Text -> Handler UserAlias
lookupAccount Text
cookieText = do
    Maybe UserAlias
maybeUser <- IO (Maybe UserAlias) -> Handler (Maybe UserAlias)
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe UserAlias) -> Handler (Maybe UserAlias))
-> IO (Maybe UserAlias) -> Handler (Maybe UserAlias)
forall a b. (a -> b) -> a -> b
$ AuthenticationStorage IO -> Text -> IO (Maybe UserAlias)
forall (m :: * -> *).
AuthenticationStorage m -> Text -> m (Maybe UserAlias)
usernameFromCookie AuthenticationStorage IO
authStorage Text
cookieText
    case Maybe UserAlias
maybeUser of
      Maybe UserAlias
Nothing -> ServerError -> Handler UserAlias
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ServerError
err403 {errBody = encode $ LoginProblem "Invalid cookie password" url})
      Just UserAlias
usr -> UserAlias -> Handler UserAlias
forall {a}. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return UserAlias
usr

-- * Handlers

defaultRedirectPage :: TL.Text
defaultRedirectPage :: Text
defaultRedirectPage = Text
"/list-games.html"

defaultSolutionSubmissionRedirectPage :: TL.Text
defaultSolutionSubmissionRedirectPage :: Text
defaultSolutionSubmissionRedirectPage = Text
"/list-solutions.html"

uploadScenario ::
  AppData ->
  Maybe TL.Text ->
  UserAlias ->
  MultipartData Mem ->
  Handler (Headers '[Header "Location" TL.Text] ScenarioCharacterization)
uploadScenario :: AppData
-> Maybe Text
-> UserAlias
-> MultipartData Mem
-> Handler
     (Headers '[Header "Location" Text] ScenarioCharacterization)
uploadScenario (AppData Sha1
gameVersion GitHubCredentials
_ PersistenceLayer IO
persistenceLayer DeploymentEnvironment
_) Maybe Text
maybeRefererUrl UserAlias
userName MultipartData Mem
multipartData =
  ExceptT
  ServerError
  IO
  (Headers '[Header "Location" Text] ScenarioCharacterization)
-> Handler
     (Headers '[Header "Location" Text] ScenarioCharacterization)
forall a. ExceptT ServerError IO a -> Handler a
Handler (ExceptT
   ServerError
   IO
   (Headers '[Header "Location" Text] ScenarioCharacterization)
 -> Handler
      (Headers '[Header "Location" Text] ScenarioCharacterization))
-> (IO
      (Either ScenarioUploadValidationFailure ScenarioCharacterization)
    -> ExceptT
         ServerError
         IO
         (Headers '[Header "Location" Text] ScenarioCharacterization))
-> IO
     (Either ScenarioUploadValidationFailure ScenarioCharacterization)
-> Handler
     (Headers '[Header "Location" Text] ScenarioCharacterization)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScenarioCharacterization
 -> Headers '[Header "Location" Text] ScenarioCharacterization)
-> ExceptT ServerError IO ScenarioCharacterization
-> ExceptT
     ServerError
     IO
     (Headers '[Header "Location" Text] ScenarioCharacterization)
forall a b.
(a -> b) -> ExceptT ServerError IO a -> ExceptT ServerError IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ScenarioCharacterization
-> Headers '[Header "Location" Text] ScenarioCharacterization
addH (ExceptT ServerError IO ScenarioCharacterization
 -> ExceptT
      ServerError
      IO
      (Headers '[Header "Location" Text] ScenarioCharacterization))
-> (IO
      (Either ScenarioUploadValidationFailure ScenarioCharacterization)
    -> ExceptT ServerError IO ScenarioCharacterization)
-> IO
     (Either ScenarioUploadValidationFailure ScenarioCharacterization)
-> ExceptT
     ServerError
     IO
     (Headers '[Header "Location" Text] ScenarioCharacterization)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScenarioUploadValidationFailure -> ServerError)
-> ExceptT
     ScenarioUploadValidationFailure IO ScenarioCharacterization
-> ExceptT ServerError IO ScenarioCharacterization
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ScenarioUploadValidationFailure -> ServerError
forall a. Describable a => a -> ServerError
toServantError (ExceptT
   ScenarioUploadValidationFailure IO ScenarioCharacterization
 -> ExceptT ServerError IO ScenarioCharacterization)
-> (IO
      (Either ScenarioUploadValidationFailure ScenarioCharacterization)
    -> ExceptT
         ScenarioUploadValidationFailure IO ScenarioCharacterization)
-> IO
     (Either ScenarioUploadValidationFailure ScenarioCharacterization)
-> ExceptT ServerError IO ScenarioCharacterization
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO
  (Either ScenarioUploadValidationFailure ScenarioCharacterization)
-> ExceptT
     ScenarioUploadValidationFailure IO ScenarioCharacterization
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO
   (Either ScenarioUploadValidationFailure ScenarioCharacterization)
 -> Handler
      (Headers '[Header "Location" Text] ScenarioCharacterization))
-> IO
     (Either ScenarioUploadValidationFailure ScenarioCharacterization)
-> Handler
     (Headers '[Header "Location" Text] ScenarioCharacterization)
forall a b. (a -> b) -> a -> b
$
    CommonValidationArgs IO ScenarioUploadResponsePayload
-> Sha1
-> IO
     (Either ScenarioUploadValidationFailure ScenarioCharacterization)
validateScenarioUpload
      CommonValidationArgs IO ScenarioUploadResponsePayload
args
      Sha1
gameVersion
 where
  addH :: ScenarioCharacterization
-> Headers '[Header "Location" Text] ScenarioCharacterization
addH = Text
-> ScenarioCharacterization
-> Headers '[Header "Location" Text] ScenarioCharacterization
forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
defaultRedirectPage Maybe Text
maybeRefererUrl)
  args :: CommonValidationArgs IO ScenarioUploadResponsePayload
args =
    SolutionTimeout
-> PersistenceArgs IO ScenarioUploadResponsePayload
-> CommonValidationArgs IO ScenarioUploadResponsePayload
forall (m :: * -> *) a.
SolutionTimeout -> PersistenceArgs m a -> CommonValidationArgs m a
CommonValidationArgs
      SolutionTimeout
defaultSolutionTimeout
      (PersistenceArgs IO ScenarioUploadResponsePayload
 -> CommonValidationArgs IO ScenarioUploadResponsePayload)
-> PersistenceArgs IO ScenarioUploadResponsePayload
-> CommonValidationArgs IO ScenarioUploadResponsePayload
forall a b. (a -> b) -> a -> b
$ UserAlias
-> MultipartData Mem
-> ScenarioPersistence IO ScenarioUploadResponsePayload
-> PersistenceArgs IO ScenarioUploadResponsePayload
forall (m :: * -> *) a.
UserAlias
-> MultipartData Mem
-> ScenarioPersistence m a
-> PersistenceArgs m a
PersistenceArgs
        UserAlias
userName
        MultipartData Mem
multipartData
        (PersistenceLayer IO
-> ScenarioPersistence IO ScenarioUploadResponsePayload
forall (m :: * -> *).
PersistenceLayer m
-> ScenarioPersistence m ScenarioUploadResponsePayload
scenarioStorage PersistenceLayer IO
persistenceLayer)

uploadSolution ::
  AppData ->
  Maybe TL.Text ->
  UserAlias ->
  MultipartData Mem ->
  Handler (Headers '[Header "Location" TL.Text] SolutionFileCharacterization)
uploadSolution :: AppData
-> Maybe Text
-> UserAlias
-> MultipartData Mem
-> Handler
     (Headers '[Header "Location" Text] SolutionFileCharacterization)
uploadSolution (AppData Sha1
_ GitHubCredentials
_ PersistenceLayer IO
persistenceLayer DeploymentEnvironment
_) Maybe Text
maybeRefererUrl UserAlias
userName MultipartData Mem
multipartData =
  ExceptT
  ServerError
  IO
  (Headers '[Header "Location" Text] SolutionFileCharacterization)
-> Handler
     (Headers '[Header "Location" Text] SolutionFileCharacterization)
forall a. ExceptT ServerError IO a -> Handler a
Handler (ExceptT
   ServerError
   IO
   (Headers '[Header "Location" Text] SolutionFileCharacterization)
 -> Handler
      (Headers '[Header "Location" Text] SolutionFileCharacterization))
-> (IO
      (Either SolutionSubmissionFailure SolutionFileCharacterization)
    -> ExceptT
         ServerError
         IO
         (Headers '[Header "Location" Text] SolutionFileCharacterization))
-> IO
     (Either SolutionSubmissionFailure SolutionFileCharacterization)
-> Handler
     (Headers '[Header "Location" Text] SolutionFileCharacterization)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SolutionFileCharacterization
 -> Headers '[Header "Location" Text] SolutionFileCharacterization)
-> ExceptT ServerError IO SolutionFileCharacterization
-> ExceptT
     ServerError
     IO
     (Headers '[Header "Location" Text] SolutionFileCharacterization)
forall a b.
(a -> b) -> ExceptT ServerError IO a -> ExceptT ServerError IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SolutionFileCharacterization
-> Headers '[Header "Location" Text] SolutionFileCharacterization
addH (ExceptT ServerError IO SolutionFileCharacterization
 -> ExceptT
      ServerError
      IO
      (Headers '[Header "Location" Text] SolutionFileCharacterization))
-> (IO
      (Either SolutionSubmissionFailure SolutionFileCharacterization)
    -> ExceptT ServerError IO SolutionFileCharacterization)
-> IO
     (Either SolutionSubmissionFailure SolutionFileCharacterization)
-> ExceptT
     ServerError
     IO
     (Headers '[Header "Location" Text] SolutionFileCharacterization)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SolutionSubmissionFailure -> ServerError)
-> ExceptT
     SolutionSubmissionFailure IO SolutionFileCharacterization
-> ExceptT ServerError IO SolutionFileCharacterization
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT SolutionSubmissionFailure -> ServerError
forall a. Describable a => a -> ServerError
toServantError (ExceptT SolutionSubmissionFailure IO SolutionFileCharacterization
 -> ExceptT ServerError IO SolutionFileCharacterization)
-> (IO
      (Either SolutionSubmissionFailure SolutionFileCharacterization)
    -> ExceptT
         SolutionSubmissionFailure IO SolutionFileCharacterization)
-> IO
     (Either SolutionSubmissionFailure SolutionFileCharacterization)
-> ExceptT ServerError IO SolutionFileCharacterization
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either SolutionSubmissionFailure SolutionFileCharacterization)
-> ExceptT
     SolutionSubmissionFailure IO SolutionFileCharacterization
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either SolutionSubmissionFailure SolutionFileCharacterization)
 -> Handler
      (Headers '[Header "Location" Text] SolutionFileCharacterization))
-> IO
     (Either SolutionSubmissionFailure SolutionFileCharacterization)
-> Handler
     (Headers '[Header "Location" Text] SolutionFileCharacterization)
forall a b. (a -> b) -> a -> b
$
    CommonValidationArgs IO SolutionUploadResponsePayload
-> (Sha1 -> IO (Maybe ByteString))
-> IO
     (Either SolutionSubmissionFailure SolutionFileCharacterization)
validateSubmittedSolution
      CommonValidationArgs IO SolutionUploadResponsePayload
args
      ((ScenarioPersistence IO ScenarioUploadResponsePayload
-> Sha1 -> IO (Maybe ByteString)
forall (m :: * -> *) a.
ScenarioPersistence m a -> Sha1 -> m (Maybe ByteString)
getContent (ScenarioPersistence IO ScenarioUploadResponsePayload
 -> Sha1 -> IO (Maybe ByteString))
-> (PersistenceLayer IO
    -> ScenarioPersistence IO ScenarioUploadResponsePayload)
-> PersistenceLayer IO
-> Sha1
-> IO (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistenceLayer IO
-> ScenarioPersistence IO ScenarioUploadResponsePayload
forall (m :: * -> *).
PersistenceLayer m
-> ScenarioPersistence m ScenarioUploadResponsePayload
scenarioStorage) PersistenceLayer IO
persistenceLayer)
 where
  addH :: SolutionFileCharacterization
-> Headers '[Header "Location" Text] SolutionFileCharacterization
addH = Text
-> SolutionFileCharacterization
-> Headers '[Header "Location" Text] SolutionFileCharacterization
forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
defaultSolutionSubmissionRedirectPage Maybe Text
maybeRefererUrl)
  args :: CommonValidationArgs IO SolutionUploadResponsePayload
args =
    SolutionTimeout
-> PersistenceArgs IO SolutionUploadResponsePayload
-> CommonValidationArgs IO SolutionUploadResponsePayload
forall (m :: * -> *) a.
SolutionTimeout -> PersistenceArgs m a -> CommonValidationArgs m a
CommonValidationArgs
      SolutionTimeout
defaultSolutionTimeout
      (PersistenceArgs IO SolutionUploadResponsePayload
 -> CommonValidationArgs IO SolutionUploadResponsePayload)
-> PersistenceArgs IO SolutionUploadResponsePayload
-> CommonValidationArgs IO SolutionUploadResponsePayload
forall a b. (a -> b) -> a -> b
$ UserAlias
-> MultipartData Mem
-> ScenarioPersistence IO SolutionUploadResponsePayload
-> PersistenceArgs IO SolutionUploadResponsePayload
forall (m :: * -> *) a.
UserAlias
-> MultipartData Mem
-> ScenarioPersistence m a
-> PersistenceArgs m a
PersistenceArgs
        UserAlias
userName
        MultipartData Mem
multipartData
        (PersistenceLayer IO
-> ScenarioPersistence IO SolutionUploadResponsePayload
forall (m :: * -> *).
PersistenceLayer m
-> ScenarioPersistence m SolutionUploadResponsePayload
solutionStorage PersistenceLayer IO
persistenceLayer)

getScenarioMetadata :: AppData -> Sha1 -> Handler ScenarioMetadata
getScenarioMetadata :: AppData -> Sha1 -> Handler ScenarioMetadata
getScenarioMetadata (AppData Sha1
_ GitHubCredentials
_ PersistenceLayer IO
persistenceLayer DeploymentEnvironment
_) Sha1
scenarioSha1 =
  ExceptT ServerError IO ScenarioMetadata -> Handler ScenarioMetadata
forall a. ExceptT ServerError IO a -> Handler a
Handler (ExceptT ServerError IO ScenarioMetadata
 -> Handler ScenarioMetadata)
-> (ExceptT ScenarioRetrievalFailure IO ScenarioMetadata
    -> ExceptT ServerError IO ScenarioMetadata)
-> ExceptT ScenarioRetrievalFailure IO ScenarioMetadata
-> Handler ScenarioMetadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScenarioRetrievalFailure -> ServerError)
-> ExceptT ScenarioRetrievalFailure IO ScenarioMetadata
-> ExceptT ServerError IO ScenarioMetadata
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ScenarioRetrievalFailure -> ServerError
forall a. Describable a => a -> ServerError
toServantError (ExceptT ScenarioRetrievalFailure IO ScenarioMetadata
 -> Handler ScenarioMetadata)
-> ExceptT ScenarioRetrievalFailure IO ScenarioMetadata
-> Handler ScenarioMetadata
forall a b. (a -> b) -> a -> b
$ do
    ByteString
doc <-
      IO (Either ScenarioRetrievalFailure ByteString)
-> ExceptT ScenarioRetrievalFailure IO ByteString
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ScenarioRetrievalFailure ByteString)
 -> ExceptT ScenarioRetrievalFailure IO ByteString)
-> IO (Either ScenarioRetrievalFailure ByteString)
-> ExceptT ScenarioRetrievalFailure IO ByteString
forall a b. (a -> b) -> a -> b
$
        ScenarioRetrievalFailure
-> Maybe ByteString -> Either ScenarioRetrievalFailure ByteString
forall a b. a -> Maybe b -> Either a b
maybeToEither (Sha1 -> ScenarioRetrievalFailure
DatabaseRetrievalFailure Sha1
scenarioSha1)
          (Maybe ByteString -> Either ScenarioRetrievalFailure ByteString)
-> IO (Maybe ByteString)
-> IO (Either ScenarioRetrievalFailure ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ScenarioPersistence IO ScenarioUploadResponsePayload
-> Sha1 -> IO (Maybe ByteString)
forall (m :: * -> *) a.
ScenarioPersistence m a -> Sha1 -> m (Maybe ByteString)
getContent (ScenarioPersistence IO ScenarioUploadResponsePayload
 -> Sha1 -> IO (Maybe ByteString))
-> (PersistenceLayer IO
    -> ScenarioPersistence IO ScenarioUploadResponsePayload)
-> PersistenceLayer IO
-> Sha1
-> IO (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistenceLayer IO
-> ScenarioPersistence IO ScenarioUploadResponsePayload
forall (m :: * -> *).
PersistenceLayer m
-> ScenarioPersistence m ScenarioUploadResponsePayload
scenarioStorage) PersistenceLayer IO
persistenceLayer Sha1
scenarioSha1

    Scenario
s <- (ScenarioInstantiationFailure -> ScenarioRetrievalFailure)
-> ExceptT ScenarioInstantiationFailure IO Scenario
-> ExceptT ScenarioRetrievalFailure IO Scenario
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ScenarioInstantiationFailure -> ScenarioRetrievalFailure
RetrievedInstantiationFailure (ExceptT ScenarioInstantiationFailure IO Scenario
 -> ExceptT ScenarioRetrievalFailure IO Scenario)
-> ExceptT ScenarioInstantiationFailure IO Scenario
-> ExceptT ScenarioRetrievalFailure IO Scenario
forall a b. (a -> b) -> a -> b
$ ByteString -> ExceptT ScenarioInstantiationFailure IO Scenario
initScenarioObjectWithEnv ByteString
doc
    ScenarioMetadata
-> ExceptT ScenarioRetrievalFailure IO ScenarioMetadata
forall a. a -> ExceptT ScenarioRetrievalFailure IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScenarioMetadata
 -> ExceptT ScenarioRetrievalFailure IO ScenarioMetadata)
-> ScenarioMetadata
-> ExceptT ScenarioRetrievalFailure IO ScenarioMetadata
forall a b. (a -> b) -> a -> b
$ Getting ScenarioMetadata Scenario ScenarioMetadata
-> Scenario -> ScenarioMetadata
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ScenarioMetadata Scenario ScenarioMetadata
Lens' Scenario ScenarioMetadata
scenarioMetadata Scenario
s

genLoginUrl :: GitHubCredentials -> BS.ByteString
genLoginUrl :: GitHubCredentials -> ByteString
genLoginUrl GitHubCredentials
creds =
  ByteString
"https://github.com/login/oauth/authorize"
    ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Bool -> Cookies -> ByteString
renderSimpleQuery
      Bool
True
      [ (ByteString
"client_id", GitHubCredentials -> ByteString
clientId GitHubCredentials
creds)
      ]

downloadSolution :: AppData -> Sha1 -> Handler TL.Text
downloadSolution :: AppData -> Sha1 -> Handler Text
downloadSolution (AppData Sha1
_ GitHubCredentials
_ PersistenceLayer IO
persistenceLayer DeploymentEnvironment
_) Sha1
solutionSha1 = do
  ExceptT ServerError IO Text -> Handler Text
forall a. ExceptT ServerError IO a -> Handler a
Handler (ExceptT ServerError IO Text -> Handler Text)
-> (ExceptT ScenarioRetrievalFailure IO Text
    -> ExceptT ServerError IO Text)
-> ExceptT ScenarioRetrievalFailure IO Text
-> Handler Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScenarioRetrievalFailure -> ServerError)
-> ExceptT ScenarioRetrievalFailure IO Text
-> ExceptT ServerError IO Text
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ScenarioRetrievalFailure -> ServerError
forall a. Describable a => a -> ServerError
toServantError (ExceptT ScenarioRetrievalFailure IO Text -> Handler Text)
-> ExceptT ScenarioRetrievalFailure IO Text -> Handler Text
forall a b. (a -> b) -> a -> b
$ do
    IO (Either ScenarioRetrievalFailure Text)
-> ExceptT ScenarioRetrievalFailure IO Text
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ScenarioRetrievalFailure Text)
 -> ExceptT ScenarioRetrievalFailure IO Text)
-> IO (Either ScenarioRetrievalFailure Text)
-> ExceptT ScenarioRetrievalFailure IO Text
forall a b. (a -> b) -> a -> b
$
      ScenarioRetrievalFailure
-> Maybe Text -> Either ScenarioRetrievalFailure Text
forall a b. a -> Maybe b -> Either a b
maybeToEither (Sha1 -> ScenarioRetrievalFailure
DatabaseRetrievalFailure Sha1
solutionSha1)
        (Maybe Text -> Either ScenarioRetrievalFailure Text)
-> IO (Maybe Text) -> IO (Either ScenarioRetrievalFailure Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Maybe ByteString -> Maybe Text)
-> IO (Maybe ByteString) -> IO (Maybe Text)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe ByteString -> Maybe Text)
 -> IO (Maybe ByteString) -> IO (Maybe Text))
-> (Maybe ByteString -> Maybe Text)
-> IO (Maybe ByteString)
-> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
decodeUtf8) ((ScenarioPersistence IO SolutionUploadResponsePayload
-> Sha1 -> IO (Maybe ByteString)
forall (m :: * -> *) a.
ScenarioPersistence m a -> Sha1 -> m (Maybe ByteString)
getContent (ScenarioPersistence IO SolutionUploadResponsePayload
 -> Sha1 -> IO (Maybe ByteString))
-> (PersistenceLayer IO
    -> ScenarioPersistence IO SolutionUploadResponsePayload)
-> PersistenceLayer IO
-> Sha1
-> IO (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistenceLayer IO
-> ScenarioPersistence IO SolutionUploadResponsePayload
forall (m :: * -> *).
PersistenceLayer m
-> ScenarioPersistence m SolutionUploadResponsePayload
solutionStorage) PersistenceLayer IO
persistenceLayer Sha1
solutionSha1)

downloadRedactedScenario :: AppData -> Sha1 -> Handler TL.Text
downloadRedactedScenario :: AppData -> Sha1 -> Handler Text
downloadRedactedScenario (AppData Sha1
_ GitHubCredentials
_ PersistenceLayer IO
persistenceLayer DeploymentEnvironment
_) Sha1
scenarioSha1 = do
  ExceptT ServerError IO Text -> Handler Text
forall a. ExceptT ServerError IO a -> Handler a
Handler (ExceptT ServerError IO Text -> Handler Text)
-> (ExceptT ScenarioRetrievalFailure IO Text
    -> ExceptT ServerError IO Text)
-> ExceptT ScenarioRetrievalFailure IO Text
-> Handler Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScenarioRetrievalFailure -> ServerError)
-> ExceptT ScenarioRetrievalFailure IO Text
-> ExceptT ServerError IO Text
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ScenarioRetrievalFailure -> ServerError
forall a. Describable a => a -> ServerError
toServantError (ExceptT ScenarioRetrievalFailure IO Text -> Handler Text)
-> ExceptT ScenarioRetrievalFailure IO Text -> Handler Text
forall a b. (a -> b) -> a -> b
$ do
    ByteString
doc <-
      IO (Either ScenarioRetrievalFailure ByteString)
-> ExceptT ScenarioRetrievalFailure IO ByteString
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ScenarioRetrievalFailure ByteString)
 -> ExceptT ScenarioRetrievalFailure IO ByteString)
-> IO (Either ScenarioRetrievalFailure ByteString)
-> ExceptT ScenarioRetrievalFailure IO ByteString
forall a b. (a -> b) -> a -> b
$
        ScenarioRetrievalFailure
-> Maybe ByteString -> Either ScenarioRetrievalFailure ByteString
forall a b. a -> Maybe b -> Either a b
maybeToEither (Sha1 -> ScenarioRetrievalFailure
DatabaseRetrievalFailure Sha1
scenarioSha1)
          (Maybe ByteString -> Either ScenarioRetrievalFailure ByteString)
-> IO (Maybe ByteString)
-> IO (Either ScenarioRetrievalFailure ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ScenarioPersistence IO ScenarioUploadResponsePayload
-> Sha1 -> IO (Maybe ByteString)
forall (m :: * -> *) a.
ScenarioPersistence m a -> Sha1 -> m (Maybe ByteString)
getContent (ScenarioPersistence IO ScenarioUploadResponsePayload
 -> Sha1 -> IO (Maybe ByteString))
-> (PersistenceLayer IO
    -> ScenarioPersistence IO ScenarioUploadResponsePayload)
-> PersistenceLayer IO
-> Sha1
-> IO (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistenceLayer IO
-> ScenarioPersistence IO ScenarioUploadResponsePayload
forall (m :: * -> *).
PersistenceLayer m
-> ScenarioPersistence m ScenarioUploadResponsePayload
scenarioStorage) PersistenceLayer IO
persistenceLayer Sha1
scenarioSha1

    Map Key Value
rawYamlDict :: Map Key Value <- (ParseException -> ScenarioRetrievalFailure)
-> ExceptT ParseException IO (Map Key Value)
-> ExceptT ScenarioRetrievalFailure IO (Map Key Value)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ParseException -> ScenarioRetrievalFailure
YamlParseFailure (ExceptT ParseException IO (Map Key Value)
 -> ExceptT ScenarioRetrievalFailure IO (Map Key Value))
-> (ByteString -> ExceptT ParseException IO (Map Key Value))
-> ByteString
-> ExceptT ScenarioRetrievalFailure IO (Map Key Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ParseException (Map Key Value)
-> ExceptT ParseException IO (Map Key Value)
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either ParseException (Map Key Value)
 -> ExceptT ParseException IO (Map Key Value))
-> (ByteString -> Either ParseException (Map Key Value))
-> ByteString
-> ExceptT ParseException IO (Map Key Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either ParseException (Map Key Value)
forall a. FromJSON a => ByteString -> Either ParseException a
decodeEither' (ByteString -> ExceptT ScenarioRetrievalFailure IO (Map Key Value))
-> ByteString
-> ExceptT ScenarioRetrievalFailure IO (Map Key Value)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict ByteString
doc
    let redactedDict :: Map Key Value
redactedDict = Key -> Map Key Value -> Map Key Value
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Key
"solution" Map Key Value
rawYamlDict
    (UnicodeException -> ScenarioRetrievalFailure)
-> ExceptT UnicodeException IO Text
-> ExceptT ScenarioRetrievalFailure IO Text
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT UnicodeException -> ScenarioRetrievalFailure
DecodingFailure (ExceptT UnicodeException IO Text
 -> ExceptT ScenarioRetrievalFailure IO Text)
-> (ByteString -> ExceptT UnicodeException IO Text)
-> ByteString
-> ExceptT ScenarioRetrievalFailure IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either UnicodeException Text -> ExceptT UnicodeException IO Text
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either UnicodeException Text -> ExceptT UnicodeException IO Text)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> ExceptT UnicodeException IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
decodeUtf8' (ByteString -> Either UnicodeException Text)
-> (ByteString -> ByteString)
-> ByteString
-> Either UnicodeException Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.fromStrict (ByteString -> ExceptT ScenarioRetrievalFailure IO Text)
-> ByteString -> ExceptT ScenarioRetrievalFailure IO Text
forall a b. (a -> b) -> a -> b
$
      EncodeOptions -> Map Key Value -> ByteString
forall a. ToJSON a => EncodeOptions -> a -> ByteString
encodeWith EncodeOptions
defaultEncodeOptions Map Key Value
redactedDict

listScenarios :: Handler [TournamentGame]
listScenarios :: Handler [TournamentGame]
listScenarios =
  ExceptT ServerError IO [TournamentGame] -> Handler [TournamentGame]
forall a. ExceptT ServerError IO a -> Handler a
Handler (ExceptT ServerError IO [TournamentGame]
 -> Handler [TournamentGame])
-> ((Connection -> IO [TournamentGame])
    -> ExceptT ServerError IO [TournamentGame])
-> (Connection -> IO [TournamentGame])
-> Handler [TournamentGame]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO [TournamentGame] -> ExceptT ServerError IO [TournamentGame]
forall a. IO a -> ExceptT ServerError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [TournamentGame] -> ExceptT ServerError IO [TournamentGame])
-> ((Connection -> IO [TournamentGame]) -> IO [TournamentGame])
-> (Connection -> IO [TournamentGame])
-> ExceptT ServerError IO [TournamentGame]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char]
-> (Connection -> IO [TournamentGame]) -> IO [TournamentGame]
forall a. [Char] -> (Connection -> IO a) -> IO a
withConnection [Char]
databaseFilename ((Connection -> IO [TournamentGame]) -> Handler [TournamentGame])
-> (Connection -> IO [TournamentGame]) -> Handler [TournamentGame]
forall a b. (a -> b) -> a -> b
$ ReaderT Connection IO [TournamentGame]
-> Connection -> IO [TournamentGame]
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Connection IO [TournamentGame]
listGames

listSolutions :: Sha1 -> Handler GameWithSolutions
listSolutions :: Sha1 -> Handler GameWithSolutions
listSolutions Sha1
sha1 =
  ExceptT ServerError IO GameWithSolutions
-> Handler GameWithSolutions
forall a. ExceptT ServerError IO a -> Handler a
Handler (ExceptT ServerError IO GameWithSolutions
 -> Handler GameWithSolutions)
-> (ReaderT Connection IO GameWithSolutions
    -> ExceptT ServerError IO GameWithSolutions)
-> ReaderT Connection IO GameWithSolutions
-> Handler GameWithSolutions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO GameWithSolutions -> ExceptT ServerError IO GameWithSolutions
forall a. IO a -> ExceptT ServerError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GameWithSolutions -> ExceptT ServerError IO GameWithSolutions)
-> (ReaderT Connection IO GameWithSolutions
    -> IO GameWithSolutions)
-> ReaderT Connection IO GameWithSolutions
-> ExceptT ServerError IO GameWithSolutions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char]
-> (Connection -> IO GameWithSolutions) -> IO GameWithSolutions
forall a. [Char] -> (Connection -> IO a) -> IO a
withConnection [Char]
databaseFilename ((Connection -> IO GameWithSolutions) -> IO GameWithSolutions)
-> (ReaderT Connection IO GameWithSolutions
    -> Connection -> IO GameWithSolutions)
-> ReaderT Connection IO GameWithSolutions
-> IO GameWithSolutions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT Connection IO GameWithSolutions
-> Connection -> IO GameWithSolutions
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ReaderT Connection IO GameWithSolutions
 -> Handler GameWithSolutions)
-> ReaderT Connection IO GameWithSolutions
-> Handler GameWithSolutions
forall a b. (a -> b) -> a -> b
$ Sha1 -> ReaderT Connection IO GameWithSolutions
listSubmissions Sha1
sha1

doGithubCallback ::
  AuthenticationStorage IO ->
  GitHubCredentials ->
  Maybe TokenExchangeCode ->
  LoginHandler
doGithubCallback :: AuthenticationStorage IO
-> GitHubCredentials -> Maybe TokenExchangeCode -> LoginHandler
doGithubCallback AuthenticationStorage IO
authStorage GitHubCredentials
creds Maybe TokenExchangeCode
maybeCode = do
  TokenExchangeCode
c <- Handler TokenExchangeCode
-> (TokenExchangeCode -> Handler TokenExchangeCode)
-> Maybe TokenExchangeCode
-> Handler TokenExchangeCode
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Handler TokenExchangeCode
forall a. [Char] -> Handler a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Missing 'code' parameter") TokenExchangeCode -> Handler TokenExchangeCode
forall {a}. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TokenExchangeCode
maybeCode

  Manager
manager <- IO Manager -> Handler Manager
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> Handler Manager) -> IO Manager -> Handler Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
HC.newManager ManagerSettings
tlsManagerSettings
  ReceivedTokens
receivedTokens <- Manager
-> GitHubCredentials -> TokenExchangeCode -> Handler ReceivedTokens
forall (m :: * -> *).
(MonadIO m, MonadThrow m, MonadFail m) =>
Manager
-> GitHubCredentials -> TokenExchangeCode -> m ReceivedTokens
exchangeCode Manager
manager GitHubCredentials
creds TokenExchangeCode
c

  let aToken :: AccessToken
aToken = Expirable AccessToken -> AccessToken
forall a. Expirable a -> a
token (Expirable AccessToken -> AccessToken)
-> Expirable AccessToken -> AccessToken
forall a b. (a -> b) -> a -> b
$ ReceivedTokens -> Expirable AccessToken
accessToken ReceivedTokens
receivedTokens
  UserApiResponse
userInfo <- Manager -> AccessToken -> Handler UserApiResponse
forall (m :: * -> *).
(MonadIO m, MonadThrow m, MonadFail m) =>
Manager -> AccessToken -> m UserApiResponse
fetchAuthenticatedUser Manager
manager AccessToken
aToken
  let user :: UserAlias
user = Text -> UserAlias
UserAlias (Text -> UserAlias) -> Text -> UserAlias
forall a b. (a -> b) -> a -> b
$ UserApiResponse -> Text
login UserApiResponse
userInfo
  LoginType
x <- AuthenticationStorage IO -> Text -> UserAlias -> LoginHandler
doLoginResponse AuthenticationStorage IO
authStorage Text
defaultRedirectPage UserAlias
user
  IO () -> Handler ()
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Handler ())
-> (ReaderT Connection IO () -> IO ())
-> ReaderT Connection IO ()
-> Handler ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> (Connection -> IO ()) -> IO ()
forall a. [Char] -> (Connection -> IO a) -> IO a
withConnection [Char]
databaseFilename ((Connection -> IO ()) -> IO ())
-> (ReaderT Connection IO () -> Connection -> IO ())
-> ReaderT Connection IO ()
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT Connection IO () -> Connection -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ReaderT Connection IO () -> Handler ())
-> ReaderT Connection IO () -> Handler ()
forall a b. (a -> b) -> a -> b
$ do
    UserAlias -> ReceivedTokens -> ReaderT Connection IO ()
insertGitHubTokens UserAlias
user ReceivedTokens
receivedTokens
  LoginType -> LoginHandler
forall {a}. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return LoginType
x

doLocalDevelopmentLogin ::
  AuthenticationStorage IO ->
  DeploymentEnvironment ->
  Maybe TL.Text ->
  LoginHandler
doLocalDevelopmentLogin :: AuthenticationStorage IO
-> DeploymentEnvironment -> Maybe Text -> LoginHandler
doLocalDevelopmentLogin AuthenticationStorage IO
authStorage DeploymentEnvironment
envType Maybe Text
maybeRefererUrl =
  case DeploymentEnvironment
envType of
    DeploymentEnvironment
ProdDeployment -> [Char] -> LoginHandler
forall a. HasCallStack => [Char] -> a
error [Char]
"Login bypass not available in production"
    LocalDevelopment UserAlias
user ->
      AuthenticationStorage IO -> Text -> UserAlias -> LoginHandler
doLoginResponse AuthenticationStorage IO
authStorage Text
refererUrl UserAlias
user
 where
  refererUrl :: Text
refererUrl = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
defaultRedirectPage Maybe Text
maybeRefererUrl

makeCookieHeader :: BS.ByteString -> SetCookie
makeCookieHeader :: ByteString -> SetCookie
makeCookieHeader ByteString
val =
  SetCookie
defaultSetCookie
    { setCookieName = myAppCookieName
    , setCookieValue = val
    , setCookiePath = Just "/api/private"
    }

doLogout :: Maybe TL.Text -> LoginHandler
doLogout :: Maybe Text -> LoginHandler
doLogout Maybe Text
maybeRefererUrl =
  LoginType -> LoginHandler
forall {a}. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return (LoginType -> LoginHandler) -> LoginType -> LoginHandler
forall a b. (a -> b) -> a -> b
$
    Text
-> Headers
     '[Header' '[Optional, Strict] "Set-Cookie" SetCookie] NoContent
-> LoginType
forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
defaultRedirectPage Maybe Text
maybeRefererUrl) (Headers
   '[Header' '[Optional, Strict] "Set-Cookie" SetCookie] NoContent
 -> LoginType)
-> Headers
     '[Header' '[Optional, Strict] "Set-Cookie" SetCookie] NoContent
-> LoginType
forall a b. (a -> b) -> a -> b
$
      SetCookie
-> NoContent
-> Headers
     '[Header' '[Optional, Strict] "Set-Cookie" SetCookie] NoContent
forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader ((ByteString -> SetCookie
makeCookieHeader ByteString
"") {setCookieMaxAge = Just 0}) NoContent
NoContent

doLoginResponse ::
  AuthenticationStorage IO ->
  TL.Text ->
  UserAlias ->
  LoginHandler
doLoginResponse :: AuthenticationStorage IO -> Text -> UserAlias -> LoginHandler
doLoginResponse AuthenticationStorage IO
authStorage Text
refererUrl UserAlias
userAlias = do
  Text
cookieString <-
    IO Text -> Handler Text
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> Handler Text) -> IO Text -> Handler Text
forall a b. (a -> b) -> a -> b
$ AuthenticationStorage IO -> UserAlias -> IO Text
forall (m :: * -> *).
AuthenticationStorage m -> UserAlias -> m Text
cookieFromUsername AuthenticationStorage IO
authStorage UserAlias
userAlias
  LoginType -> LoginHandler
forall {a}. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return (LoginType -> LoginHandler) -> LoginType -> LoginHandler
forall a b. (a -> b) -> a -> b
$
    Text
-> Headers
     '[Header' '[Optional, Strict] "Set-Cookie" SetCookie] NoContent
-> LoginType
forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader Text
refererUrl (Headers
   '[Header' '[Optional, Strict] "Set-Cookie" SetCookie] NoContent
 -> LoginType)
-> Headers
     '[Header' '[Optional, Strict] "Set-Cookie" SetCookie] NoContent
-> LoginType
forall a b. (a -> b) -> a -> b
$
      SetCookie
-> NoContent
-> Headers
     '[Header' '[Optional, Strict] "Set-Cookie" SetCookie] NoContent
forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader (ByteString -> SetCookie
makeCookieHeader (ByteString -> SetCookie) -> ByteString -> SetCookie
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
cookieString) NoContent
NoContent

-- * Web app declaration

app :: Bool -> AppData -> Application
app :: Bool -> AppData -> Application
app Bool
unitTestFileserver AppData
appData =
  Proxy ToplevelAPI
-> Context '[AuthHandler Request UserAlias, MultipartOptions Mem]
-> Server ToplevelAPI
-> Application
forall api (context :: [*]).
(HasServer api context, ServerContext context) =>
Proxy api -> Context context -> Server api -> Application
Servant.serveWithContext (Proxy ToplevelAPI
forall {k} (t :: k). Proxy t
Proxy :: Proxy ToplevelAPI) Context '[AuthHandler Request UserAlias, MultipartOptions Mem]
context (Server ToplevelAPI -> Application)
-> Server ToplevelAPI -> Application
forall a b. (a -> b) -> a -> b
$
    Bool -> Server ToplevelAPI
server Bool
unitTestFileserver
 where
  size100kB :: Int64
size100kB = Int64
100_000 :: Int64

  multipartOpts :: MultipartOptions Mem
  multipartOpts :: MultipartOptions Mem
multipartOpts =
    (Proxy Mem -> MultipartOptions Mem
forall tag.
MultipartBackend tag =>
Proxy tag -> MultipartOptions tag
defaultMultipartOptions (Proxy Mem
forall {k} (t :: k). Proxy t
Proxy :: Proxy Mem))
      { generalOptions =
          setMaxRequestFileSize size100kB
            . setMaxRequestKeyLength 64
            . setMaxRequestNumFiles 1
            $ defaultParseRequestBodyOptions
      }

  thisAuthHandler :: AuthHandler Request UserAlias
thisAuthHandler =
    AuthenticationStorage IO
-> GitHubCredentials
-> DeploymentEnvironment
-> AuthHandler Request UserAlias
authHandler
      (PersistenceLayer IO -> AuthenticationStorage IO
forall (m :: * -> *). PersistenceLayer m -> AuthenticationStorage m
authenticationStorage (PersistenceLayer IO -> AuthenticationStorage IO)
-> PersistenceLayer IO -> AuthenticationStorage IO
forall a b. (a -> b) -> a -> b
$ AppData -> PersistenceLayer IO
persistence AppData
appData)
      (AppData -> GitHubCredentials
gitHubCredentials AppData
appData)
      (AppData -> DeploymentEnvironment
developmentMode AppData
appData)
  context :: Context '[AuthHandler Request UserAlias, MultipartOptions Mem]
context = AuthHandler Request UserAlias
thisAuthHandler AuthHandler Request UserAlias
-> Context '[MultipartOptions Mem]
-> Context '[AuthHandler Request UserAlias, MultipartOptions Mem]
forall x (xs :: [*]). x -> Context xs -> Context (x : xs)
:. MultipartOptions Mem
multipartOpts MultipartOptions Mem
-> Context '[] -> Context '[MultipartOptions Mem]
forall x (xs :: [*]). x -> Context xs -> Context (x : xs)
:. Context '[]
EmptyContext

  server :: Bool -> Server ToplevelAPI
  server :: Bool -> Server ToplevelAPI
server Bool
fakeFileserverForUnitTest =
    AppData
-> Server
     (("api"
       :> ("private"
           :> ("upload"
               :> ("scenario"
                   :> (Header "Referer" Text
                       :> (AuthProtect "cookie-auth"
                           :> (MultipartForm Mem (MultipartData Mem)
                               :> Verb
                                    'POST
                                    303
                                    '[JSON]
                                    (Headers
                                       '[Header "Location" Text] ScenarioCharacterization))))))))
      :<|> (("api"
             :> ("private"
                 :> ("upload"
                     :> ("solution"
                         :> (Header "Referer" Text
                             :> (AuthProtect "cookie-auth"
                                 :> (MultipartForm Mem (MultipartData Mem)
                                     :> Verb
                                          'POST
                                          303
                                          '[JSON]
                                          (Headers
                                             '[Header "Location" Text]
                                             SolutionFileCharacterization))))))))
            :<|> (("scenario"
                   :> (Capture "sha1" Sha1
                       :> ("metadata" :> Get '[JSON] ScenarioMetadata)))
                  :<|> (("scenario"
                         :> (Capture "sha1" Sha1 :> ("fetch" :> Get '[PlainText] Text)))
                        :<|> (("solution"
                               :> (Capture "sha1" Sha1 :> ("fetch" :> Get '[PlainText] 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" Text
                                                                             :> Verb
                                                                                  'GET
                                                                                  303
                                                                                  '[JSON]
                                                                                  LoginType)))))
                                                            :<|> ("api"
                                                                  :> ("private"
                                                                      :> ("login"
                                                                          :> ("logout"
                                                                              :> (Header
                                                                                    "Referer" Text
                                                                                  :> Verb
                                                                                       'GET
                                                                                       303
                                                                                       '[JSON]
                                                                                       LoginType)))))))))))))))
mkApp AppData
appData
      ((Maybe Text
  -> UserAlias
  -> MultipartData Mem
  -> Handler
       (Headers '[Header "Location" Text] ScenarioCharacterization))
 :<|> ((Maybe Text
        -> UserAlias
        -> MultipartData Mem
        -> Handler
             (Headers '[Header "Location" Text] SolutionFileCharacterization))
       :<|> ((Sha1 -> Handler ScenarioMetadata)
             :<|> ((Sha1 -> Handler Text)
                   :<|> ((Sha1 -> Handler Text)
                         :<|> (Handler [TournamentGame]
                               :<|> ((Sha1 -> Handler GameWithSolutions)
                                     :<|> ((UserAlias -> Handler UserAlias)
                                           :<|> ((Maybe TokenExchangeCode -> LoginHandler)
                                                 :<|> ((Maybe Text -> LoginHandler)
                                                       :<|> (Maybe Text -> LoginHandler)))))))))))
-> (Tagged Handler Application :<|> Tagged Handler Application)
-> ((Maybe Text
     -> UserAlias
     -> MultipartData Mem
     -> Handler
          (Headers '[Header "Location" Text] ScenarioCharacterization))
    :<|> ((Maybe Text
           -> UserAlias
           -> MultipartData Mem
           -> Handler
                (Headers '[Header "Location" Text] SolutionFileCharacterization))
          :<|> ((Sha1 -> Handler ScenarioMetadata)
                :<|> ((Sha1 -> Handler Text)
                      :<|> ((Sha1 -> Handler Text)
                            :<|> (Handler [TournamentGame]
                                  :<|> ((Sha1 -> Handler GameWithSolutions)
                                        :<|> ((UserAlias -> Handler UserAlias)
                                              :<|> ((Maybe TokenExchangeCode -> LoginHandler)
                                                    :<|> ((Maybe Text -> LoginHandler)
                                                          :<|> (Maybe Text
                                                                -> LoginHandler)))))))))))
   :<|> (Tagged Handler Application :<|> Tagged Handler Application)
forall a b. a -> b -> a :<|> b
:<|> Application -> Tagged Handler Application
forall {k} (s :: k) b. b -> Tagged s b
Tagged Application
serveDocs
      Tagged Handler Application
-> Tagged Handler Application
-> Tagged Handler Application :<|> Tagged Handler Application
forall a b. a -> b -> a :<|> b
:<|> Tagged Handler Application
ServerT Raw Handler
fileserver
   where
    fileserver :: ServerT Raw Handler
fileserver =
      if Bool
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.

          [([Char], ByteString)] -> ServerT Raw Handler
forall (m :: * -> *). [([Char], ByteString)] -> ServerT Raw m
serveDirectoryEmbedded
            [ (Text -> [Char]
TL.unpack Text
defaultRedirectPage, ByteString
"Hello World!")
            , (Text -> [Char]
TL.unpack Text
defaultSolutionSubmissionRedirectPage, ByteString
"Hello World!")
            ]
        else
          StaticSettings -> ServerT Raw Handler
forall (m :: * -> *). StaticSettings -> ServerT Raw m
serveDirectoryWith
            ([Char] -> StaticSettings
defaultFileServerSettings [Char]
"tournament/web")

    serveDocs :: Application
serveDocs Request
_ Response -> IO ResponseReceived
resp =
      Response -> IO ResponseReceived
resp (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, ByteString)] -> ByteString -> Response
responseLBS Status
ok200 [(HeaderName, ByteString)
htmlType] ByteString
tournamentsApiHtml
    htmlType :: (HeaderName, ByteString)
htmlType = (HeaderName
"Content-Type", ByteString
"text/html")

webMain ::
  AppData ->
  Warp.Port ->
  IO ()
webMain :: AppData -> Port -> IO ()
webMain AppData
appData Port
port = Settings -> Application -> IO ()
Warp.runSettings Settings
settings (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> AppData -> Application
app Bool
False AppData
appData
 where
  settings :: Settings
settings = Port -> Settings -> Settings
Warp.setPort Port
port Settings
Warp.defaultSettings