Upload and parse scenarios (#1798)

Towards #1797

Hosts an online repository of scenarios, against which solutions may be submitted.  This is the foundational layer that may support more structured "tournaments", scenario ranking, or other social activity.

# Demo

## Live server

http://swarmgame.net/list-games.html

One can use the [`submit.sh`](https://github.com/swarm-game/swarm/pull/1798/files#diff-450877e3442a0ec1c5cbe964808a263d67f1e680d3aa3c3bf9ae6f51eca682fb) script and see valid uploads reflected live on the website.

## Local testing

### Automated tests

These are database-agnostic.

    scripts/run-tests.sh swarm:test:tournament-host

### Manual tests

These test database interactions.  It requires first setting up a local Postgres server.

1. Start `tournament/scripts/demo/server-native.sh` in one console
2. Run `tournament/scripts/demo/client/test-cases/local/good-submit.sh` in another

# Features

* Upload and validates scenarios
* Download scenarios with solution redacted
* Submit, validate, execute, and score solutions

# Key components

* Servant server
* Hosted on AWS in a Docker container
* Stores to a Postgres database in Amazon RDS
* Shares some code with the integration tests for evaluating scenarios and solutions

The production database uses IAM to manage logins.  The web app uses the AWS API to fetch a "token" which can be used to log in instead of a password.  This avoids having to store a password on the server.

# TODO
- [ ] User authentication (GitHub OpenID?)

.hlint.yaml

@@ -26,7 +26,7 @@
 #
 - functions:
   - {name: Data.List.head, within: []}
-  - {name: Prelude.head, within: []}
+  - {name: Prelude.head, within: [Swarm.Web.Tournament.Database.Query]}
   - {name: Data.List.NonEmpty.fromList, within: [Swarm.Util]}
   - {name: Prelude.tail, within: []}
   - {name: Prelude.!!, within: [Swarm.Util.indexWrapNonEmpty, TestEval]}

app/tournament/Main.hs

@@ -0,0 +1,99 @@
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+module Main where
+
+import Control.Monad.Trans.Reader (runReaderT)
+import Data.IORef (newIORef)
+import Data.Maybe (fromMaybe)
+import Network.Wai.Handler.Warp (Port)
+import Options.Applicative
+import Swarm.Game.State (Sha1 (..))
+import Swarm.Web.Tournament
+import Swarm.Web.Tournament.Database.Query
+import System.Environment (lookupEnv)
+import System.Posix.User (getEffectiveUserName)
+
+data AppOpts = AppOpts
+  { userWebPort :: Maybe Port
+  -- ^ Explicit port on which to run the web API
+  , gameGitVersion :: Sha1
+  , isLocalSocketConnection :: Bool
+  }
+
+webPort :: Parser (Maybe Int)
+webPort =
+  optional $
+    option
+      auto
+      ( long "port"
+          <> metavar "PORT"
+          <> help ("Set the web service port (or disable it with 0). Default to " <> show defaultPort <> ".")
+      )
+
+gameVersion :: Parser Sha1
+gameVersion =
+  Sha1
+    <$> option
+      str
+      ( long "version"
+          <> metavar "VERSION"
+          <> help "Set the git version of the game"
+      )
+
+parseNativeDev :: Parser Bool
+parseNativeDev =
+  switch
+    (long "native-dev" <> help "Running locally outside of a Docker container for development")
+
+cliParser :: Parser AppOpts
+cliParser = AppOpts <$> webPort <*> gameVersion <*> parseNativeDev
+
+cliInfo :: ParserInfo AppOpts
+cliInfo =
+  info
+    (cliParser <**> helper)
+    ( header "Swarm tournament"
+        <> progDesc "Hosts a tournament server."
+        <> fullDesc
+    )
+
+deduceConnType :: Bool -> IO DbConnType
+deduceConnType isLocalSocketConn =
+  if isLocalSocketConn
+    then LocalDBOverSocket . Username <$> getEffectiveUserName
+    else do
+      maybeDbPassword <- lookupEnv envarPostgresPasswordKey
+      case maybeDbPassword of
+        Just dbPasswordEnvar -> return $ LocalDBFromDockerOverNetwork $ Password dbPasswordEnvar
+        Nothing -> RemoteDB <$> newIORef Nothing
+
+main :: IO ()
+main = do
+  opts <- execParser cliInfo
+  connType <- deduceConnType $ isLocalSocketConnection opts
+  webMain
+    (AppData (gameGitVersion opts) (persistenceFunctions connType) connType)
+    (fromMaybe defaultPort $ userWebPort opts)
+ where
+  persistenceFunctions connMode =
+    PersistenceLayer
+      { lookupScenarioFileContent = withConnInfo lookupScenarioContent
+      , scenarioStorage =
+          ScenarioPersistence
+            { lookupCache = withConnInfo lookupScenarioSolution
+            , storeCache = withConnInfo insertScenario
+            }
+      , solutionStorage =
+          ScenarioPersistence
+            { lookupCache = withConnInfo lookupSolutionSubmission
+            , storeCache = withConnInfo insertSolutionSubmission
+            }
+      }
+   where
+    withConnInfo f x = do
+      -- This gets deferred and re-executed upon each invocation
+      -- of a DB interaction function.
+      -- We need this behavior because the password fetched via API
+      -- expires after 15 min.
+      connInfo <- mkConnectInfo connMode
+      runReaderT (f x) connInfo

scripts/build-game.sh

@@ -0,0 +1,10 @@
+#!/bin/bash -ex
+
+cd $(git rev-parse --show-toplevel)
+
+# NOTE: There are several executables within the swarm.cabal project.
+# If you only want to play the swarm game, you should specify an explicit
+# target 'swarm:exe:swarm' to the 'stack' command, to avoid building
+# extra dependencies.
+
+stack build --fast swarm:swarm

scripts/play.sh

@@ -1,10 +1,9 @@
 #!/bin/bash -ex
 
-SCRIPT_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd )
-cd $SCRIPT_DIR/..
+cd $(git rev-parse --show-toplevel)
 
 # This compiles without optimizations and then runs the resulting executable.
 # It's been observed in certain versions of GHC that compiling with optimizations
 # results in the swarm UI freezing for a potentially long time upon starting a scenario.
 # See https://github.com/swarm-game/swarm/issues/1000#issuecomment-1378632269
-stack build --fast swarm:swarm && stack exec swarm -- "$@"
+scripts/build-game.sh && stack exec swarm -- "$@"

src/swarm-tournament/Swarm/Web/Tournament.hs

@@ -0,0 +1,274 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# 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 (..),
+
+  -- ** Development
+  webMain,
+  app,
+) where
+
+import Commonmark qualified as Mark (commonmark, renderHtml)
+import Control.Lens
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Except
+import Control.Monad.Trans.Reader (runReaderT)
+import Data.Aeson
+import Data.ByteString.Lazy (ByteString)
+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.Text qualified as T
+import Data.Text.Lazy qualified as TL
+import Data.Text.Lazy.Encoding (decodeUtf8', encodeUtf8)
+import Data.Yaml (decodeEither', defaultEncodeOptions, encodeWith)
+import Network.HTTP.Types (ok200)
+import Network.Wai (responseLBS)
+import Network.Wai.Application.Static (defaultFileServerSettings, ssIndices)
+import Network.Wai.Handler.Warp qualified as Warp
+import Network.Wai.Parse (
+  defaultParseRequestBodyOptions,
+  setMaxRequestFileSize,
+  setMaxRequestKeyLength,
+  setMaxRequestNumFiles,
+ )
+import Servant
+import Servant.Docs qualified as SD
+import Servant.Docs.Internal qualified as SD (renderCurlBasePath)
+import Servant.Multipart
+import Swarm.Game.Scenario (ScenarioMetadata (ScenarioMetadata), scenarioMetadata)
+import Swarm.Game.Scenario.Scoring.CodeSize (ScenarioCodeMetrics (..))
+import Swarm.Game.State (Sha1 (..))
+import Swarm.Game.Tick (TickNumber (..))
+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 WaiAppStatic.Types (unsafeToPiece)
+
+placeholderAlias :: UserAlias
+placeholderAlias = UserAlias "Karl"
+
+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 15
+
+data AppData = AppData
+  { swarmGameGitVersion :: Sha1
+  , persistence :: PersistenceLayer
+  , dbConnType :: DbConnType
+  }
+
+type TournamentAPI =
+  "upload" :> "scenario" :> MultipartForm Mem (MultipartData Mem) :> Post '[JSON] ScenarioCharacterization
+    :<|> "upload" :> "solution" :> MultipartForm Mem (MultipartData Mem) :> Post '[JSON] SolutionFileCharacterization
+    :<|> "scenario" :> Capture "sha1" Sha1 :> "metadata" :> Get '[JSON] ScenarioMetadata
+    :<|> "scenario" :> Capture "sha1" Sha1 :> "fetch" :> Get '[PlainText] TL.Text
+    :<|> "games" :> Get '[JSON] [TournamentGame]
+
+swarmApi :: Proxy TournamentAPI
+swarmApi = Proxy
+
+type ToplevelAPI =
+  TournamentAPI
+    :<|> "api" :> Raw
+    :<|> Raw
+
+api :: Proxy ToplevelAPI
+api = Proxy
+
+swarmApiHtml :: ByteString
+swarmApiHtml =
+  encodeUtf8
+    . either (error . show) (Mark.renderHtml @())
+    . Mark.commonmark ""
+    $ T.pack swarmApiMarkdown
+
+swarmApiMarkdown :: String
+swarmApiMarkdown =
+  SD.markdownWith
+    ( SD.defRenderingOptions
+        & SD.requestExamples .~ SD.FirstContentType
+        & SD.responseExamples .~ SD.FirstContentType
+        & SD.renderCurlBasePath ?~ "http://localhost:" <> show defaultPort
+    )
+    $ SD.docsWithIntros [intro] swarmApi
+ where
+  intro =
+    SD.DocIntro
+      "Swarm tournament hosting API"
+      [ "All of the valid endpoints are documented below."
+      ]
+
+toServantError :: Describable a => a -> ServerError
+toServantError x = err500 {errBody = encodeUtf8 $ TL.fromStrict $ describeText x}
+
+-- * Handlers
+
+mkApp :: AppData -> Servant.Server TournamentAPI
+mkApp appData =
+  uploadScenario appData
+    :<|> uploadSolution appData
+    :<|> getScenarioMetadata appData
+    :<|> downloadRedactedScenario appData
+    :<|> listScenarios appData
+
+uploadScenario :: AppData -> MultipartData Mem -> Handler ScenarioCharacterization
+uploadScenario (AppData gameVersion persistenceLayer _) multipartData =
+  Handler . withExceptT toServantError . ExceptT $
+    validateScenarioUpload
+      args
+      gameVersion
+ where
+  args =
+    CommonValidationArgs
+      defaultSolutionTimeout
+      $ PersistenceArgs
+        placeholderAlias
+        multipartData
+        (scenarioStorage persistenceLayer)
+
+uploadSolution :: AppData -> MultipartData Mem -> Handler SolutionFileCharacterization
+uploadSolution (AppData _ persistenceLayer _) multipartData =
+  Handler . withExceptT toServantError . ExceptT $
+    validateSubmittedSolution
+      args
+      (lookupScenarioFileContent persistenceLayer)
+ where
+  args =
+    CommonValidationArgs
+      defaultSolutionTimeout
+      $ PersistenceArgs
+        placeholderAlias
+        multipartData
+        (solutionStorage persistenceLayer)
+
+getScenarioMetadata :: AppData -> Sha1 -> Handler ScenarioMetadata
+getScenarioMetadata (AppData _ persistenceLayer _) scenarioSha1 =
+  Handler . withExceptT toServantError $ do
+    doc <-
+      ExceptT $
+        maybeToEither (DatabaseRetrievalFailure scenarioSha1)
+          <$> lookupScenarioFileContent persistenceLayer scenarioSha1
+
+    s <- withExceptT RetrievedInstantiationFailure $ initScenarioObjectWithEnv doc
+    return $ view scenarioMetadata s
+
+downloadRedactedScenario :: AppData -> Sha1 -> Handler TL.Text
+downloadRedactedScenario (AppData _ persistenceLayer _) scenarioSha1 = do
+  Handler . withExceptT toServantError $ do
+    doc <-
+      ExceptT $
+        maybeToEither (DatabaseRetrievalFailure scenarioSha1)
+          <$> lookupScenarioFileContent 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
+
+-- NOTE: This is currently the only API endpoint that invokes
+-- 'mkConnectInfo' directly
+listScenarios :: AppData -> Handler [TournamentGame]
+listScenarios (AppData _ _ connMode) =
+  Handler $ liftIO $ do
+    connInfo <- mkConnectInfo connMode
+    runReaderT listGames connInfo
+
+-- * Web app declaration
+
+app :: AppData -> Application
+app appData = Servant.serveWithContext api context server
+ where
+  size100kB = 100_000 :: Int64
+
+  multipartOpts :: MultipartOptions Mem
+  multipartOpts =
+    (defaultMultipartOptions (Proxy :: Proxy Mem))
+      { generalOptions =
+          setMaxRequestFileSize size100kB
+            . setMaxRequestKeyLength 64
+            . setMaxRequestNumFiles 1
+            $ defaultParseRequestBodyOptions
+      }
+
+  context = multipartOpts :. EmptyContext
+
+  server :: Server ToplevelAPI
+  server =
+    mkApp appData
+      :<|> Tagged serveDocs
+      :<|> serveDirectoryWith
+        (defaultFileServerSettings "tournament/web")
+          { ssIndices = [unsafeToPiece "index.html"]
+          }
+   where
+    serveDocs _ resp =
+      resp $ responseLBS ok200 [plain] swarmApiHtml
+    plain = ("Content-Type", "text/html")
+
+webMain ::
+  AppData ->
+  Warp.Port ->
+  IO ()
+webMain appData port = Warp.runSettings settings $ app appData
+ where
+  settings = Warp.setPort port Warp.defaultSettings
+
+-- * Instances for documentation
+
+instance SD.ToSample T.Text where
+  toSamples _ = SD.samples ["foo"]
+
+instance SD.ToSample TL.Text where
+  toSamples _ = SD.samples ["foo"]
+
+instance SD.ToSample TournamentGame where
+  toSamples _ = SD.samples [TournamentGame "foo" "bar" (Sha1 "abc") 10 (Sha1 "def")]
+
+fakeSolnCharacterization :: SolutionCharacterization
+fakeSolnCharacterization =
+  SolutionCharacterization
+    10
+    (TickNumber 100)
+    0
+    (ScenarioCodeMetrics 10 5)
+
+instance SD.ToSample ScenarioMetadata where
+  toSamples _ = SD.samples [ScenarioMetadata 1 "foo" $ Just "bar"]
+
+instance SD.ToSample SolutionFileCharacterization where
+  toSamples _ = SD.samples [SolutionFileCharacterization (Sha1 "abcdef") fakeSolnCharacterization]
+
+instance SD.ToSample ScenarioCharacterization where
+  toSamples _ = SD.samples [ScenarioCharacterization (FileMetadata "foo.yaml" (Sha1 "abcdef")) fakeSolnCharacterization]
+
+instance ToMultipartSample Mem (MultipartData Mem) where
+  toMultipartSamples _proxy =
+    [
+      ( "sample 1"
+      , MultipartData
+          [Input "username" "Elvis Presley"]
+          [ FileData
+              "scenario-file"
+              "my-scenario.yaml"
+              "application/yaml"
+              "tmpservant-multipart000.buf"
+          ]
+      )
+    ]

src/swarm-tournament/Swarm/Web/Tournament/Database/Query.hs

@@ -0,0 +1,317 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+--
+-- SQL Queries for Swarm tournaments.
+module Swarm.Web.Tournament.Database.Query where
+
+import Control.Monad (guard)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
+import Control.Monad.Trans.Reader (ReaderT, ask)
+import Data.ByteString.Lazy qualified as LBS
+import Data.IORef
+import Data.Maybe (listToMaybe)
+import Data.String.Utils (strip)
+import Data.Time.Clock
+import Database.PostgreSQL.Simple
+import Database.PostgreSQL.Simple.FromRow
+import Database.PostgreSQL.Simple.ToField
+import Swarm.Game.Scenario.Scoring.CodeSize
+import Swarm.Game.State (Sha1 (..))
+import Swarm.Game.Tick (TickNumber (..))
+import Swarm.Web.Tournament.Type
+import System.Exit (ExitCode (..))
+import System.Process
+
+-- | Used for local development only
+envarPostgresPasswordKey :: String
+envarPostgresPasswordKey = "LOCAL_PGPASS"
+
+newtype UserId = UserId Int
+
+instance ToField UserId where
+  toField (UserId x) = toField x
+
+data PersistenceLayer = PersistenceLayer
+  { lookupScenarioFileContent :: Sha1 -> IO (Maybe LBS.ByteString)
+  -- ^ Dump scenario file
+  , scenarioStorage :: ScenarioPersistence ScenarioUploadResponsePayload
+  , solutionStorage :: ScenarioPersistence SolutionUploadResponsePayload
+  }
+
+data ScenarioPersistence b = ScenarioPersistence
+  { lookupCache :: Sha1 -> IO (Maybe AssociatedSolutionSolutionCharacterization)
+  -- ^ Looks up by key
+  , storeCache :: CharacterizationResponse b -> IO Sha1
+  -- ^ Stores and returns key
+  }
+
+data UserAttributedUpload = UserAttributedUpload
+  { uploader :: UserAlias
+  , fileUpload :: FileUpload
+  }
+
+data CharacterizationResponse a = CharacterizationResponse
+  { upload :: UserAttributedUpload
+  , associatedCharacterization :: AssociatedSolutionSolutionCharacterization
+  , payload :: a
+  }
+
+newtype ScenarioUploadResponsePayload = ScenarioUploadResponsePayload
+  { swarmGameVersion :: Sha1
+  }
+
+newtype SolutionUploadResponsePayload = SolutionUploadResponsePayload
+  { scenariohash :: Sha1
+  }
+
+instance FromRow AssociatedSolutionSolutionCharacterization where
+  fromRow =
+    AssociatedSolutionSolutionCharacterization
+      <$> (Sha1 <$> field)
+      <*> fromRow
+
+instance FromRow SolutionCharacterization where
+  fromRow =
+    SolutionCharacterization
+      <$> field
+      <*> (TickNumber <$> field)
+      <*> field
+      <*> (ScenarioCodeMetrics <$> field <*> field)
+
+instance FromRow TournamentGame where
+  fromRow =
+    TournamentGame
+      <$> field
+      <*> field
+      <*> (Sha1 <$> field)
+      <*> field
+      <*> (Sha1 <$> field)
+
+data TokenWithExpiration = TokenWithExpiration
+  { expirationTime :: UTCTime
+  , loginToken :: Password
+  }
+
+type TokenRef = IORef (Maybe TokenWithExpiration)
+
+newtype Username = Username String
+newtype Password = Password String
+
+data DbConnType
+  = -- | application running directly on host connects to database running on same host
+    LocalDBOverSocket Username
+  | -- | application running inside docker connects to database running on the docker's host
+    LocalDBFromDockerOverNetwork Password
+  | -- | application deployed to EC2 inside Docker, accessing RDS database
+    RemoteDB TokenRef
+
+-- | Tokens expire after 15 minutes.
+-- We shall refresh after 10 minutes.
+tokenRefreshInterval :: NominalDiffTime
+tokenRefreshInterval = 10 * 60
+
+genNewToken :: ConnectInfo -> IO (Either String String)
+genNewToken ci = do
+  (exitCode, stdoutString, stderrString) <-
+    readProcessWithExitCode
+      "aws"
+      [ "rds"
+      , "generate-db-auth-token"
+      , "--hostname"
+      , connectHost ci
+      , "--port"
+      , show $ connectPort ci
+      , "--region"
+      , region
+      , "--username"
+      , connectUser ci
+      ]
+      ""
+  return $ case exitCode of
+    ExitSuccess -> Right $ strip stdoutString
+    ExitFailure _ -> Left stderrString
+ where
+  region = "us-east-1"
+
+getAwsCredentials :: TokenRef -> ConnectInfo -> IO ConnectInfo
+getAwsCredentials tokRef ci = do
+  currTime <- getCurrentTime
+  maybePreviousTok <- readIORef tokRef
+  let maybeStillValidTok = case maybePreviousTok of
+        Nothing -> Nothing
+        Just (TokenWithExpiration exprTime tok) ->
+          guard (currTime < exprTime) >> Just tok
+
+  case maybeStillValidTok of
+    Just (Password tok) ->
+      return $
+        ci
+          { connectPassword = tok
+          }
+    Nothing -> do
+      eitherNewTok <- genNewToken ci
+      case eitherNewTok of
+        Right newTok -> do
+          let nextExpirationTime = addUTCTime tokenRefreshInterval currTime
+          atomicWriteIORef tokRef
+            . Just
+            . TokenWithExpiration nextExpirationTime
+            $ Password newTok
+          return $
+            ci
+              { connectPassword = newTok
+              }
+        -- NOTE: This is not exactly valid behavior:
+        Left _errMsg -> return ci
+
+mkConnectInfo :: DbConnType -> IO ConnectInfo
+mkConnectInfo connType = do
+  let swarmDbConnect =
+        defaultConnectInfo
+          { connectDatabase = "swarm"
+          }
+
+  case connType of
+    LocalDBFromDockerOverNetwork (Password dbPasswd) ->
+      return $
+        swarmDbConnect
+          { connectHost = "host.docker.internal"
+          , connectUser = "swarm-app"
+          , connectPassword = dbPasswd
+          }
+    LocalDBOverSocket (Username username) ->
+      return
+        swarmDbConnect
+          { connectHost = "/var/run/postgresql"
+          , connectUser = username
+          }
+    RemoteDB tokRef -> getAwsCredentials tokRef rdsConnectionInfo
+ where
+  rdsConnectionInfo =
+    defaultConnectInfo
+      { connectHost = "swarm-tournaments.cv6iymakujnb.us-east-1.rds.amazonaws.com"
+      , connectUser = "swarm-app"
+      , connectDatabase = "swarm"
+      }
+
+-- * Authentication
+
+getUserId :: Connection -> UserAlias -> IO UserId
+getUserId conn userAlias = do
+  maybeId <-
+    listToMaybe . fmap (UserId . fromOnly)
+      <$> query conn "SELECT id FROM users WHERE alias = ?;" (Only userAlias)
+  maybe insertNew return maybeId
+ where
+  insertNew =
+    fmap (UserId . fromOnly . head)
+      $ query
+        conn
+        "INSERT INTO users (alias) VALUES (?) RETURNING id;"
+      $ Only userAlias
+
+-- * Retrieval
+
+lookupScenarioContent :: Sha1 -> ReaderT ConnectInfo IO (Maybe LBS.ByteString)
+lookupScenarioContent sha1 = do
+  connInfo <- ask
+  liftIO . fmap (fmap fromOnly . listToMaybe) . withConnect connInfo $ \conn ->
+    query conn "SELECT content FROM scenarios WHERE content_sha1 = ?;" (Only sha1)
+
+lookupSolutionSubmission :: Sha1 -> ReaderT ConnectInfo IO (Maybe AssociatedSolutionSolutionCharacterization)
+lookupSolutionSubmission contentSha1 = do
+  connInfo <- ask
+  liftIO $ withConnect connInfo $ \conn -> runMaybeT $ do
+    evaluationId :: Int <-
+      MaybeT $
+        fmap fromOnly . listToMaybe
+          <$> query conn "SELECT solution_evaluation FROM solution_submission WHERE content_sha1 = ?;" (Only contentSha1)
+
+    MaybeT $
+      listToMaybe
+        <$> query conn "SELECT scenario, wall_time_seconds, ticks, seed, char_count, ast_size FROM evaluated_solution WHERE id = ?;" (Only evaluationId)
+
+-- | There should only be one builtin solution for the scenario.
+lookupScenarioSolution :: Sha1 -> ReaderT ConnectInfo IO (Maybe AssociatedSolutionSolutionCharacterization)
+lookupScenarioSolution scenarioSha1 = do
+  connInfo <- ask
+  solnChar <- liftIO . fmap listToMaybe . withConnect connInfo $ \conn ->
+    query conn "SELECT wall_time_seconds, ticks, seed, char_count, ast_size FROM evaluated_solution WHERE builtin AND scenario = ? LIMIT 1;" (Only scenarioSha1)
+  return $ AssociatedSolutionSolutionCharacterization scenarioSha1 <$> solnChar
+
+listGames :: ReaderT ConnectInfo IO [TournamentGame]
+listGames = do
+  connInfo <- ask
+  liftIO $ withConnect connInfo $ \conn ->
+    query_ conn "SELECT original_filename, scenario_uploader, scenario, submission_count, swarm_git_sha1 FROM submissions;"
+
+-- * Insertion
+
+insertScenario ::
+  CharacterizationResponse ScenarioUploadResponsePayload ->
+  ReaderT ConnectInfo IO Sha1
+insertScenario s = do
+  connInfo <- ask
+  h <- liftIO $ withConnect connInfo $ \conn -> do
+    uid <- getUserId conn $ uploader $ upload s
+    [Only resultList] <-
+      query
+        conn
+        "INSERT INTO scenarios (content_sha1, content, original_filename, uploader, swarm_git_sha1) VALUES (?, ?, ?, ?, ?) RETURNING content_sha1;"
+        ( scenarioSha
+        , fileContent $ fileUpload $ upload s
+        , filename . fileMetadata . fileUpload $ upload s
+        , uid
+        , swarmGameVersion $ payload s
+        )
+    _ <- insertSolution conn True scenarioSha $ characterization $ associatedCharacterization s
+
+    return resultList
+  return $ Sha1 h
+ where
+  scenarioSha = fileHash . fileMetadata . fileUpload $ upload s
+
+insertSolutionSubmission ::
+  CharacterizationResponse SolutionUploadResponsePayload ->
+  ReaderT ConnectInfo IO Sha1
+insertSolutionSubmission (CharacterizationResponse solutionUpload s (SolutionUploadResponsePayload scenarioSha)) = do
+  connInfo <- ask
+  liftIO $ withConnect connInfo $ \conn -> do
+    uid <- getUserId conn $ uploader solutionUpload
+
+    solutionEvalId <- insertSolution conn False scenarioSha $ characterization s
+
+    [Only echoedSha1] <-
+      query
+        conn
+        "INSERT INTO solution_submission (uploader, content_sha1, solution_evaluation) VALUES (?, ?, ?) RETURNING content_sha1;"
+        (uid, fileHash $ fileMetadata $ fileUpload solutionUpload, solutionEvalId)
+    return $ Sha1 echoedSha1
+
+insertSolution ::
+  Connection ->
+  Bool ->
+  Sha1 ->
+  SolutionCharacterization ->
+  IO Int
+insertSolution conn isBuiltin scenarioSha s = do
+  [Only evaluationId] <-
+    query
+      conn
+      "INSERT INTO evaluated_solution (scenario, builtin, wall_time_seconds, ticks, seed, char_count, ast_size) VALUES (?, ?, ?, ?, ?, ?, ?) RETURNING id;"
+      insertion_items
+  return evaluationId
+ where
+  insertion_items =
+    ( scenarioSha
+    , isBuiltin
+    , solutionWallTime s
+    , getTickNumber $ solutionTicks s
+    , scenarioSeed s
+    , sourceTextLength $ solutionCodeMetrics s
+    , astSize $ solutionCodeMetrics s
+    )

src/swarm-tournament/Swarm/Web/Tournament/Type.hs

@@ -0,0 +1,84 @@
+{-# LANGUAGE DataKinds #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+--
+-- Types for Swarm tournaments.
+module Swarm.Web.Tournament.Type where
+
+import Data.Aeson
+import Data.ByteString.Lazy qualified as LBS
+import Data.Text qualified as T
+import Database.PostgreSQL.Simple.ToField
+import GHC.Generics (Generic)
+import Servant
+import Servant.Docs (ToCapture)
+import Servant.Docs qualified as SD
+import Swarm.Game.Scenario.Scoring.CodeSize
+import Swarm.Game.State (Sha1 (..))
+import Swarm.Game.Tick (TickNumber (..))
+import Swarm.Game.World.Gen (Seed)
+import System.Time.Extra
+
+newtype UserAlias = UserAlias T.Text
+
+instance ToField UserAlias where
+  toField (UserAlias x) = toField x
+
+instance ToField Sha1 where
+  toField (Sha1 x) = toField x
+
+data FileMetadata = FileMetadata
+  { filename :: T.Text
+  , fileHash :: Sha1
+  }
+  deriving (Generic, ToJSON)
+
+data FileUpload = FileUpload
+  { fileContent :: LBS.ByteString
+  , fileMetadata :: FileMetadata
+  }
+
+data TournamentGame = TournamentGame
+  { originalFilename :: T.Text
+  , scenarioUploader :: T.Text
+  , scenarioHash :: Sha1
+  , submissionCount :: Int
+  , swarmGitSha1 :: Sha1
+  }
+  deriving (Generic, ToJSON)
+
+data AssociatedSolutionSolutionCharacterization = AssociatedSolutionSolutionCharacterization
+  { forScenario :: Sha1
+  , characterization :: SolutionCharacterization
+  }
+
+data SolutionCharacterization = SolutionCharacterization
+  { solutionWallTime :: Seconds
+  , solutionTicks :: TickNumber
+  , scenarioSeed :: Seed
+  , solutionCodeMetrics :: ScenarioCodeMetrics
+  }
+  deriving (Generic, ToJSON)
+
+data SolutionFileCharacterization = SolutionFileCharacterization
+  { solutionHash :: Sha1
+  , solutionCharacterization :: SolutionCharacterization
+  }
+  deriving (Generic, ToJSON)
+
+data ScenarioCharacterization = ScenarioCharacterization
+  { scenarioFileMetadata :: FileMetadata
+  , builtinSolution :: SolutionCharacterization
+  }
+  deriving (Generic, ToJSON)
+
+instance FromHttpApiData Sha1 where
+  parseUrlPiece = return . Sha1 . T.unpack
+
+instance ToCapture (Capture "sha1" Sha1) where
+  toCapture _ =
+    SD.DocCapture
+      "sha1" -- name
+      "(text) scenario sha1" -- description

src/swarm-tournament/Swarm/Web/Tournament/Validate.hs

@@ -0,0 +1,257 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+--
+-- Validates an uploaded scenario
+module Swarm.Web.Tournament.Validate where
+
+import Control.Arrow (left)
+import Control.Carrier.Accum.FixedStrict (evalAccum)
+import Control.Carrier.Throw.Either (runThrow)
+import Control.Lens
+import Control.Monad (unless)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.State (StateT, evalStateT, gets)
+import Control.Monad.Trans.Except
+import Data.ByteString.Lazy qualified as LBS
+import Data.Either.Extra (maybeToEither)
+import Data.Foldable (Foldable (toList))
+import Data.List.NonEmpty qualified as NE
+import Data.Sequence (Seq)
+import Data.Text qualified as T
+import Data.Text.Encoding (decodeUtf8')
+import Data.Yaml (decodeEither', parseEither)
+import Servant.Multipart
+import Swarm.Effect (runTimeIO)
+import Swarm.Game.CESK (emptyStore, initMachine)
+import Swarm.Game.Failure (SystemFailure)
+import Swarm.Game.Robot.Concrete (machine, robotContext, robotLog)
+import Swarm.Game.Robot.Context (defReqs)
+import Swarm.Game.Scenario
+import Swarm.Game.Scenario.Scoring.CodeSize (codeMetricsFromSyntax)
+import Swarm.Game.Scenario.Status (emptyLaunchParams)
+import Swarm.Game.State
+import Swarm.Game.State.Robot (robotMap)
+import Swarm.Game.State.Runtime (initGameStateConfig, initScenarioInputs)
+import Swarm.Game.State.Substate (
+  WinCondition (WinConditions),
+  WinStatus (Won),
+  initState,
+  messageQueue,
+  seed,
+ )
+import Swarm.Game.Step (gameTick)
+import Swarm.Game.Tick (TickNumber)
+import Swarm.Language.Context qualified as Ctx
+import Swarm.Language.Module (Module (..))
+import Swarm.Language.Pipeline (ProcessedTerm (..), processTermEither)
+import Swarm.Log
+import Swarm.Util.Yaml
+import Swarm.Web.Tournament.Database.Query
+import Swarm.Web.Tournament.Type
+import Swarm.Web.Tournament.Validate.FailureMode
+import Swarm.Web.Tournament.Validate.Upload
+import System.Time.Extra
+
+newtype SolutionTimeout = SolutionTimeout Seconds
+
+data CommonValidationArgs a
+  = CommonValidationArgs
+      SolutionTimeout
+      (PersistenceArgs a)
+
+validateScenarioUpload ::
+  CommonValidationArgs ScenarioUploadResponsePayload ->
+  -- | Game version
+  Sha1 ->
+  IO (Either ScenarioUploadValidationFailure ScenarioCharacterization)
+validateScenarioUpload (CommonValidationArgs solnTimeout persistenceArgs) gameVersion =
+  runExceptT $ do
+    (fileMeta, solnMetrics) <-
+      withFileCache
+        persistenceArgs
+        ScenarioUploadFailure
+        computeMetrics
+
+    pure $
+      ScenarioCharacterization
+        fileMeta
+        (characterization solnMetrics)
+ where
+  computeMetrics file = do
+    gs <-
+      withExceptT ScenarioUploadInstantiationFailure $
+        gamestateFromScenarioText $
+          fileContent file
+
+    soln <- except $ maybeToEither NoSolutionProvided $ gs ^. winSolution
+
+    solnMetrics <-
+      withExceptT ScenarioSolutionEvaluationFailure $
+        verifySolution solnTimeout soln gs
+
+    return
+      ( AssociatedSolutionSolutionCharacterization (fileHash $ fileMetadata file) solnMetrics
+      , ScenarioUploadResponsePayload gameVersion
+      )
+
+validateSubmittedSolution ::
+  CommonValidationArgs SolutionUploadResponsePayload ->
+  -- | Scenario lookup function
+  (Sha1 -> IO (Maybe LBS.ByteString)) ->
+  IO (Either SolutionSubmissionFailure SolutionFileCharacterization)
+validateSubmittedSolution (CommonValidationArgs solnTimeout persistenceArgs) scenarioLookupFunc =
+  runExceptT $ do
+    userSuppliedScenarioSha1 <-
+      withExceptT MissingScenarioParameter
+        . except
+        . fmap (Sha1 . T.unpack)
+        $ lookupInput "scenario" multipartData
+
+    (fileMeta, solnMetrics) <-
+      withFileCache
+        persistenceArgs
+        SolutionUploadFailure
+        (computeMetrics userSuppliedScenarioSha1)
+
+    let retrievedScenarioHash = forScenario solnMetrics
+
+    -- We validate that the uploaded solution, if retrieved from the
+    -- cache, actually is for the scenario with the hash they
+    -- supplied in the upload metadata.
+    -- If someone re-uploads a solution file that already happens to be
+    -- stored in the database, but specifies a different scenario hash,
+    -- we should alert about this mistake with an error.
+    unless (userSuppliedScenarioSha1 == retrievedScenarioHash)
+      . except
+      . Left
+      $ CachedSolutionScenarioMismatch userSuppliedScenarioSha1 retrievedScenarioHash
+
+    pure $ SolutionFileCharacterization (fileHash fileMeta) $ characterization solnMetrics
+ where
+  PersistenceArgs _ multipartData _ = persistenceArgs
+
+  computeMetrics scenarioSha1 file = do
+    solText <-
+      withExceptT SolutionUnicodeError
+        . except
+        . decodeUtf8'
+        . LBS.toStrict
+        $ fileContent file
+    soln <- withExceptT SolutionParseError . except $ processTermEither solText
+
+    gs <- withExceptT ScenarioRetrievalFailure $ do
+      scenarioContent <-
+        withExceptT DatabaseRetrievalFailure $
+          ExceptT
+            ( maybeToEither scenarioSha1
+                <$> scenarioLookupFunc scenarioSha1
+            )
+
+      withExceptT RetrievedInstantiationFailure $
+        gamestateFromScenarioText scenarioContent
+
+    solnMetrics <-
+      withExceptT SubmittedSolutionEvaluationFailure $
+        verifySolution solnTimeout soln gs
+
+    return
+      ( AssociatedSolutionSolutionCharacterization scenarioSha1 solnMetrics
+      , SolutionUploadResponsePayload scenarioSha1
+      )
+
+-- * Utils
+
+initScenarioObjectWithEnv ::
+  LBS.ByteString ->
+  ExceptT ScenarioInstantiationFailure IO Scenario
+initScenarioObjectWithEnv content = do
+  scenarioInputs <-
+    withExceptT (ScenarioEnvironmentFailure . ContextInitializationFailure)
+      . ExceptT
+      . runThrow
+      $ evalAccum (mempty :: Seq SystemFailure) initScenarioInputs
+
+  initScenarioObject scenarioInputs content
+
+initScenarioObject ::
+  ScenarioInputs ->
+  LBS.ByteString ->
+  ExceptT ScenarioInstantiationFailure IO Scenario
+initScenarioObject scenarioInputs content = do
+  rawYaml <- withExceptT YamlDecodeError . except . decodeEither' $ LBS.toStrict content
+  withExceptT ScenarioParseFailure $
+    except $
+      parseEither (parseJSONE' scenarioInputs) rawYaml
+
+gamestateFromScenarioText ::
+  LBS.ByteString ->
+  ExceptT ScenarioInstantiationFailure IO GameState
+gamestateFromScenarioText content = do
+  gsc <-
+    withExceptT (ScenarioEnvironmentFailure . ContextInitializationFailure)
+      . ExceptT
+      . runThrow
+      $ evalAccum (mempty :: Seq SystemFailure) initGameStateConfig
+
+  let scenarioInputs = gsiScenarioInputs $ initState gsc
+  scenarioObject <- initScenarioObject scenarioInputs content
+  liftIO $ scenarioToGameState scenarioObject emptyLaunchParams gsc
+
+verifySolution ::
+  SolutionTimeout ->
+  ProcessedTerm ->
+  GameState ->
+  ExceptT SolutionEvaluationFailure IO SolutionCharacterization
+verifySolution (SolutionTimeout timeoutSeconds) sol gs = do
+  (actualTime, eitherTickCount) <-
+    ExceptT
+      . fmap (maybeToEither (SolutionExecutionTimeout timeoutSeconds))
+      . timeout timeoutSeconds
+      . duration
+      $ evalStateT playUntilWin gs'
+
+  tickCount <- except $ left ErrorsDuringExecution eitherTickCount
+
+  return $
+    SolutionCharacterization
+      actualTime
+      tickCount
+      (gs ^. randomness . seed)
+      codeMetrics
+ where
+  ProcessedTerm (Module s _) _ reqCtx = sol
+  codeMetrics = codeMetricsFromSyntax s
+  gs' =
+    gs
+      -- See #827 for an explanation of why it's important to add to
+      -- the robotContext defReqs here (and also why this will,
+      -- hopefully, eventually, go away).
+      & baseRobot . robotContext . defReqs <>~ reqCtx
+      & baseRobot . machine .~ initMachine sol Ctx.empty emptyStore
+
+-- ** Utils shared with integration tests
+
+playUntilWin :: StateT GameState IO (Either (NE.NonEmpty T.Text) TickNumber)
+playUntilWin = do
+  w <- use winCondition
+  b <- gets badErrorsInLogs
+  case NE.nonEmpty b of
+    Just badErrs -> return $ Left badErrs
+    Nothing -> case w of
+      WinConditions (Won _ ts) _ -> return $ Right ts
+      _ -> runTimeIO gameTick >> playUntilWin
+
+badErrorsInLogs :: GameState -> [T.Text]
+badErrorsInLogs g =
+  concatMap
+    (\r -> filter isBad (seqToTexts $ r ^. robotLog))
+    (g ^. robotInfo . robotMap)
+    <> filter isBad (seqToTexts $ g ^. messageInfo . messageQueue)
+ where
+  isBad m = "Fatal error:" `T.isInfixOf` m || "swarm/issues" `T.isInfixOf` m
+
+seqToTexts :: Seq LogEntry -> [T.Text]
+seqToTexts = map (view leText) . toList

src/swarm-tournament/Swarm/Web/Tournament/Validate/FailureMode.hs

@@ -0,0 +1,121 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+--
+-- Failure modes for validating an uploaded scenario
+module Swarm.Web.Tournament.Validate.FailureMode where
+
+import Control.Exception.Base (displayException)
+import Data.List.NonEmpty qualified as NE
+import Data.Text qualified as T
+import Data.Text.Encoding.Error (UnicodeException)
+import Data.Yaml (ParseException)
+import Swarm.Game.Failure (SystemFailure)
+import Swarm.Game.State (Sha1 (..))
+import Swarm.Util (parens, showT)
+import System.Time.Extra (Seconds, showDuration)
+
+class Describable a where
+  describeText :: a -> T.Text
+
+newtype GenericUploadFailure = GenericUploadFailure FileUploadFailure
+
+instance Describable GenericUploadFailure where
+  describeText (GenericUploadFailure x) = describeText x
+
+data FileUploadFailure
+  = NoFileSupplied
+  | MultipleFiles Int
+
+instance Describable FileUploadFailure where
+  describeText NoFileSupplied = "Must supply a file!"
+  describeText (MultipleFiles count) =
+    T.unwords
+      [ "Only one file is allowed! Provided"
+      , showT count
+      ]
+
+newtype ContextInitializationFailure = ContextInitializationFailure SystemFailure
+
+instance Describable ContextInitializationFailure where
+  describeText (ContextInitializationFailure x) = showT x
+
+data SolutionEvaluationFailure
+  = SolutionGameStateInitializationFailure ContextInitializationFailure
+  | SolutionExecutionTimeout Seconds
+  | ErrorsDuringExecution (NE.NonEmpty T.Text)
+
+instance Describable SolutionEvaluationFailure where
+  describeText (SolutionGameStateInitializationFailure x) = describeText x
+  describeText (SolutionExecutionTimeout s) =
+    T.unwords
+      [ "Timed out - this likely means that the solution did not work."
+      , "Limit is"
+      , T.pack $ showDuration s
+      ]
+  describeText (ErrorsDuringExecution x) = T.unlines $ NE.toList x
+
+data ScenarioInstantiationFailure
+  = ScenarioEnvironmentFailure ContextInitializationFailure
+  | YamlDecodeError ParseException
+  | ScenarioParseFailure String
+
+instance Describable ScenarioInstantiationFailure where
+  describeText (ScenarioEnvironmentFailure x) = describeText x
+  describeText (YamlDecodeError x) = T.pack $ displayException x
+  describeText (ScenarioParseFailure x) = T.pack x
+
+data ScenarioUploadValidationFailure
+  = ScenarioUploadFailure GenericUploadFailure
+  | NoSolutionProvided
+  | ScenarioUploadInstantiationFailure ScenarioInstantiationFailure
+  | ScenarioSolutionEvaluationFailure SolutionEvaluationFailure
+
+instance Describable ScenarioUploadValidationFailure where
+  describeText (ScenarioUploadFailure x) = describeText x
+  describeText NoSolutionProvided = "No solution to test!"
+  describeText (ScenarioUploadInstantiationFailure x) = describeText x
+  describeText (ScenarioSolutionEvaluationFailure x) = describeText x
+
+data ScenarioRetrievalFailure
+  = DatabaseRetrievalFailure Sha1
+  | RetrievedInstantiationFailure ScenarioInstantiationFailure
+  | DecodingFailure UnicodeException
+  | YamlParseFailure ParseException
+
+instance Describable ScenarioRetrievalFailure where
+  describeText (DatabaseRetrievalFailure (Sha1 h)) =
+    T.unwords
+      [ "Scenario with hash"
+      , T.pack h
+      , "not found"
+      ]
+  describeText (RetrievedInstantiationFailure x) = describeText x
+  describeText (DecodingFailure x) = T.pack $ displayException x
+  describeText (YamlParseFailure x) = T.pack $ displayException x
+
+data SolutionSubmissionFailure
+  = SolutionUploadFailure GenericUploadFailure
+  | MissingScenarioParameter String
+  | SubmittedSolutionEvaluationFailure SolutionEvaluationFailure
+  | SolutionUnicodeError UnicodeException
+  | SolutionParseError T.Text
+  | ScenarioRetrievalFailure ScenarioRetrievalFailure
+  | CachedSolutionScenarioMismatch Sha1 Sha1
+
+instance Describable SolutionSubmissionFailure where
+  describeText (SolutionUploadFailure x) = describeText x
+  describeText (MissingScenarioParameter x) = T.pack x
+  describeText (SubmittedSolutionEvaluationFailure x) = describeText x
+  describeText (SolutionUnicodeError x) = T.pack $ displayException x
+  describeText (SolutionParseError x) = x
+  describeText (ScenarioRetrievalFailure x) = describeText x
+  describeText (CachedSolutionScenarioMismatch (Sha1 userSuppliedScenarioSha1) (Sha1 retrievedScenarioHash)) =
+    T.unwords
+      [ "User-supplied scenario hash"
+      , parens $ T.pack userSuppliedScenarioSha1
+      , "did not match scenario hash for previously computed solution"
+      , parens $ T.pack retrievedScenarioHash
+      ]

src/swarm-tournament/Swarm/Web/Tournament/Validate/Upload.hs

@@ -0,0 +1,73 @@
+{-# LANGUAGE DataKinds #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+--
+-- Validates an uploaded scenario
+module Swarm.Web.Tournament.Validate.Upload where
+
+import Control.Monad (void, when)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Except
+import Data.Digest.Pure.SHA (sha1, showDigest)
+import Data.Either.Extra (maybeToEither)
+import Data.List.NonEmpty qualified as NE
+import Servant.Multipart
+import Swarm.Game.State
+import Swarm.Web.Tournament.Database.Query
+import Swarm.Web.Tournament.Type
+import Swarm.Web.Tournament.Validate.FailureMode
+
+data PersistenceArgs a
+  = PersistenceArgs
+      UserAlias
+      (MultipartData Mem)
+      (ScenarioPersistence a)
+
+obtainFileUpload ::
+  MultipartData Mem ->
+  ExceptT GenericUploadFailure IO FileUpload
+obtainFileUpload multipartData =
+  withExceptT GenericUploadFailure $ do
+    nonemptyFiles <-
+      except $
+        maybeToEither NoFileSupplied maybeNonemptyFiles
+
+    let suppliedCount = NE.length nonemptyFiles
+    when (suppliedCount > 1) . except . Left $ MultipleFiles suppliedCount
+
+    let file = NE.head nonemptyFiles
+        content = fdPayload file
+        theSha1Hash = Sha1 $ showDigest $ sha1 content
+
+    return $ FileUpload content $ FileMetadata (fdFileName file) theSha1Hash
+ where
+  maybeNonemptyFiles = NE.nonEmpty $ files multipartData
+
+withFileCache ::
+  PersistenceArgs a ->
+  (GenericUploadFailure -> e) ->
+  (FileUpload -> ExceptT e IO (AssociatedSolutionSolutionCharacterization, a)) ->
+  ExceptT e IO (FileMetadata, AssociatedSolutionSolutionCharacterization)
+withFileCache (PersistenceArgs userAlias multipartData persistenceFunctions) errorWrapper cacheStoreFunction = do
+  file <- withExceptT errorWrapper $ obtainFileUpload multipartData
+  maybePreexisting <-
+    liftIO
+      . lookupCache persistenceFunctions
+      . fileHash
+      $ fileMetadata file
+  solnMetrics <- maybe (doStore file) return maybePreexisting
+  return (fileMetadata file, solnMetrics)
+ where
+  doStore file = do
+    (result, a) <- cacheStoreFunction file
+
+    liftIO
+      . void
+      . storeCache persistenceFunctions
+      $ CharacterizationResponse
+        (UserAttributedUpload userAlias file)
+        result
+        a
+
+    return result

swarm.cabal

@@ -431,6 +431,56 @@ library swarm-web
     -- See discussion in #415
     StrictData
 
+library swarm-tournament
+  import: stan-config, common, ghc2021-extensions
+  visibility: public
+  -- cabal-gild: discover src/swarm-tournament
+  exposed-modules:
+    Swarm.Web.Tournament
+    Swarm.Web.Tournament.Database.Query
+    Swarm.Web.Tournament.Type
+    Swarm.Web.Tournament.Validate
+    Swarm.Web.Tournament.Validate.FailureMode
+    Swarm.Web.Tournament.Validate.Upload
+
+  other-modules: Paths_swarm
+  autogen-modules: Paths_swarm
+  build-depends:
+    MissingH,
+    SHA,
+    aeson,
+    base,
+    bytestring,
+    commonmark,
+    containers,
+    extra,
+    fused-effects,
+    http-types,
+    lens,
+    mtl,
+    postgresql-simple >=0.7 && <0.7.1,
+    process,
+    servant-docs,
+    servant-multipart,
+    servant-server >=0.19 && <0.21,
+    text,
+    time,
+    transformers,
+    wai >=3.2 && <3.3,
+    wai-app-static >=3.1.8 && <3.1.9,
+    wai-extra,
+    warp,
+    yaml,
+
+  build-depends:
+    swarm:swarm-engine,
+    swarm:swarm-lang,
+    swarm:swarm-scenario,
+    swarm:swarm-util,
+
+  hs-source-dirs: src/swarm-tournament
+  default-language: Haskell2010
+
 library swarm-util
   import: stan-config, common, ghc2021-extensions
   visibility: public
@@ -793,6 +843,25 @@ executable swarm-docs
   ghc-options: -threaded
   default-extensions: ImportQualifiedPost
 
+executable swarm-host-tournament
+  import: stan-config, common, ghc2021-extensions
+  main-is: Main.hs
+  build-depends:
+    base,
+    optparse-applicative >=0.16 && <0.19,
+    transformers,
+    unix,
+    warp,
+
+  build-depends:
+    swarm:swarm-engine,
+    swarm:swarm-tournament,
+
+  hs-source-dirs: app/tournament
+  default-language: Haskell2010
+  ghc-options: -threaded
+  default-extensions: ImportQualifiedPost
+
 test-suite swarm-unit
   import: stan-config, common, ghc2021-extensions
   main-is: Main.hs
@@ -856,7 +925,6 @@ test-suite swarm-integration
     fused-effects,
     lens,
     mtl,
-    swarm,
     tasty >=0.10 && <1.6,
     tasty-expected-failure >=0.12 && <0.13,
     tasty-hunit >=0.10 && <0.11,
@@ -864,10 +932,37 @@ test-suite swarm-integration
     witch,
     yaml,
 
+  build-depends:
+    swarm,
+    swarm:swarm-tournament,
+
   hs-source-dirs: test/integration
   default-language: Haskell2010
   ghc-options: -threaded
 
+test-suite tournament-host
+  import: stan-config, common, ghc2021-extensions
+  main-is: Main.hs
+  type: exitcode-stdio-1.0
+  build-depends:
+    SHA,
+    base,
+    bytestring,
+    http-client,
+    http-types,
+    nonempty-containers,
+    tasty,
+    tasty-hunit,
+    warp,
+
+  build-depends:
+    swarm:swarm-engine,
+    swarm:swarm-tournament,
+
+  hs-source-dirs: test/tournament-host
+  default-language: Haskell2010
+  ghc-options: -threaded
+
 benchmark benchmark
   import: stan-config, common, ghc2021-extensions
   main-is: Benchmark.hs

test/integration/Main.hs

@@ -11,9 +11,9 @@ module Main where
 
 import Control.Carrier.Lift (runM)
 import Control.Carrier.Throw.Either (runThrow)
-import Control.Lens (Ixed (ix), at, to, use, view, (&), (.~), (<>~), (^.), (^..), (^?), (^?!))
+import Control.Lens (Ixed (ix), at, to, view, (&), (.~), (<>~), (^.), (^..), (^?), (^?!))
 import Control.Monad (forM_, unless, when)
-import Control.Monad.State (StateT, execStateT, gets)
+import Control.Monad.State (execStateT)
 import Data.Char (isSpace)
 import Data.Containers.ListUtils (nubOrd)
 import Data.Foldable (Foldable (toList), find)
@@ -21,14 +21,12 @@ import Data.IntSet qualified as IS
 import Data.List (partition)
 import Data.Map qualified as M
 import Data.Maybe (isJust)
-import Data.Sequence (Seq)
 import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Text.IO qualified as T
 import Data.Yaml (ParseException, prettyPrintParseException)
 import Swarm.Doc.Keyword (EditorType (..))
 import Swarm.Doc.Keyword qualified as Keyword
-import Swarm.Effect (runTimeIO)
 import Swarm.Game.Achievement.Definitions (GameplayAchievement (..))
 import Swarm.Game.CESK (emptyStore, initMachine)
 import Swarm.Game.Entity (lookupByName)
@@ -46,7 +44,6 @@ import Swarm.Game.State (
   pathCaching,
   robotInfo,
   temporal,
-  winCondition,
   winSolution,
  )
 import Swarm.Game.State.Robot (
@@ -60,15 +57,12 @@ import Swarm.Game.State.Runtime (
   stdGameConfigInputs,
  )
 import Swarm.Game.State.Substate (
-  WinCondition (WinConditions),
-  WinStatus (Won),
   gameAchievements,
   initState,
   messageQueue,
   notificationsContent,
   ticks,
  )
-import Swarm.Game.Step (gameTick)
 import Swarm.Game.Step.Path.Type
 import Swarm.Game.Tick (getTickNumber)
 import Swarm.Language.Context qualified as Ctx
@@ -86,6 +80,7 @@ import Swarm.TUI.Model.UI (UIState)
 import Swarm.Util (acquireAllWithExt)
 import Swarm.Util.RingBuffer qualified as RB
 import Swarm.Util.Yaml (decodeFileEitherE)
+import Swarm.Web.Tournament.Validate
 import System.FilePath.Posix (splitDirectories)
 import System.Timeout (timeout)
 import Test.Tasty (TestTree, defaultMain, testGroup)
@@ -502,7 +497,9 @@ testScenarioSolutions rs ui =
             Just g -> do
               -- When debugging, try logging all robot messages.
               -- printAllLogs
-              when (shouldCheckBadErrors == CheckForBadErrors) $ noBadErrors g
+              when (shouldCheckBadErrors == CheckForBadErrors) $ case noBadErrors g of
+                Left x -> assertFailure $ T.unpack x
+                _ -> return ()
               verify g
 
   tutorialHasLog :: GameState -> Assertion
@@ -513,30 +510,11 @@ testScenarioSolutions rs ui =
   testTutorialSolution t f = testSolution' t f CheckForBadErrors tutorialHasLog
   testTutorialSolution' t f s v = testSolution' t f s $ \g -> tutorialHasLog g >> v g
 
-  playUntilWin :: StateT GameState IO ()
-  playUntilWin = do
-    w <- use winCondition
-    b <- gets badErrorsInLogs
-    when (null b) $ case w of
-      WinConditions (Won _ _) _ -> return ()
-      _ -> runTimeIO gameTick >> playUntilWin
-
-noBadErrors :: GameState -> Assertion
-noBadErrors g = do
-  let bad = badErrorsInLogs g
-  unless (null bad) (assertFailure . T.unpack . T.unlines . take 5 $ nubOrd bad)
-
-badErrorsInLogs :: GameState -> [Text]
-badErrorsInLogs g =
-  concatMap
-    (\r -> filter isBad (seqToTexts $ r ^. robotLog))
-    (g ^. robotInfo . robotMap)
-    <> filter isBad (seqToTexts $ g ^. messageInfo . messageQueue)
+noBadErrors :: GameState -> Either T.Text ()
+noBadErrors g =
+  unless (null bad) (Left . T.unlines . take 5 $ nubOrd bad)
  where
-  isBad m = "Fatal error:" `T.isInfixOf` m || "swarm/issues" `T.isInfixOf` m
-
-seqToTexts :: Seq LogEntry -> [Text]
-seqToTexts = map (view leText) . toList
+  bad = badErrorsInLogs g
 
 printAllLogs :: GameState -> IO ()
 printAllLogs g =

test/tournament-host/Main.hs

@@ -0,0 +1,103 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+--
+-- Tournament hosting
+module Main where
+
+import Data.ByteString.Lazy qualified as LBS
+import Data.Digest.Pure.SHA (sha1, showDigest)
+import Data.List.NonEmpty qualified as NE
+import Data.Map.NonEmpty (NEMap)
+import Data.Map.NonEmpty qualified as NEM
+import Data.String (fromString)
+import Network.HTTP.Client hiding (Proxy)
+import Network.HTTP.Client.MultipartFormData
+import Network.HTTP.Types (ok200)
+import Network.Wai.Handler.Warp (testWithApplication)
+import Swarm.Game.State (Sha1 (..))
+import Swarm.Web.Tournament qualified as Tournament
+import Swarm.Web.Tournament.Database.Query
+import Test.Tasty (defaultMain, testGroup)
+import Test.Tasty.HUnit (Assertion, assertEqual, testCase)
+
+main :: IO ()
+main = do
+  scenariosMap <- buildScenariosMap $ pure "data/scenarios/Challenges/arbitrage.yaml"
+  let appData = mkAppData scenariosMap
+  defaultMain $
+    testGroup
+      "Test database-agnostic server interactions"
+      [ testCase "Test scenario upload" $ testScenarioUpload scenariosMap appData
+      , testCase "Test solution upload" $ testSolutionUpload scenariosMap appData
+      ]
+ where
+  noPersistence =
+    ScenarioPersistence
+      { lookupCache = const $ return Nothing
+      , storeCache = const $ return $ Sha1 "bogus"
+      }
+
+  mkPersistenceLayer scenariosMap =
+    PersistenceLayer
+      { lookupScenarioFileContent = \x -> return $ content <$> NEM.lookup x scenariosMap
+      , scenarioStorage = noPersistence
+      , solutionStorage = noPersistence
+      }
+
+  mkAppData scenariosMap =
+    Tournament.AppData
+      { Tournament.swarmGameGitVersion = Sha1 "abcdef"
+      , Tournament.persistence = mkPersistenceLayer scenariosMap
+      , -- NOTE: This is not actually used/exercised by the tests:
+        Tournament.dbConnType = LocalDBOverSocket $ Username ""
+      }
+
+type LocalFileLookup = NEMap Sha1 FilePathAndContent
+
+data FilePathAndContent = FilePathAndContent
+  { filePath :: FilePath
+  , content :: LBS.ByteString
+  }
+
+buildScenariosMap :: NE.NonEmpty FilePath -> IO LocalFileLookup
+buildScenariosMap pathList =
+  NEM.fromList <$> traverse getWithHash pathList
+ where
+  getWithHash fp = do
+    fileContent <- LBS.readFile fp
+    let h = Sha1 $ showDigest $ sha1 fileContent
+    return (h, FilePathAndContent fp fileContent)
+
+testScenarioUpload :: LocalFileLookup -> Tournament.AppData -> Assertion
+testScenarioUpload fileLookup appData =
+  mapM_ f testScenarioPaths
+ where
+  f x = uploadForm appData "/upload/scenario" [partFileSource "file" x]
+  testScenarioPaths = map filePath $ NE.toList $ NEM.elems fileLookup
+
+testSolutionUpload :: LocalFileLookup -> Tournament.AppData -> Assertion
+testSolutionUpload fileLookup appData =
+  uploadForm appData "/upload/solution" form
+ where
+  solutionFilePath = "data/scenarios/Challenges/_arbitrage/solution.sw"
+  Sha1 scenarioSha1 = NE.head $ NEM.keys fileLookup
+  form =
+    [ partBS "scenario" $ fromString scenarioSha1
+    , partFileSource "file" solutionFilePath
+    ]
+
+-- * Utils
+
+uploadForm :: Tournament.AppData -> String -> [PartM IO] -> Assertion
+uploadForm appData urlPath form =
+  testWithApplication (pure tournamentApp) $ \p -> do
+    manager <- newManager defaultManagerSettings
+    req <- parseRequest $ "http://localhost:" ++ show p ++ urlPath
+    resp <- flip httpLbs manager =<< formDataBody form req
+
+    print $ responseBody resp
+    assertEqual "Server response should be 200" ok200 $ responseStatus resp
+ where
+  tournamentApp = Tournament.app appData

tournament/schema/schema-local.sql

@@ -0,0 +1,267 @@
+--
+-- PostgreSQL database dump
+--
+
+-- Dumped from database version 14.11 (Ubuntu 14.11-0ubuntu0.22.04.1)
+-- Dumped by pg_dump version 14.11 (Ubuntu 14.11-0ubuntu0.22.04.1)
+
+SET statement_timeout = 0;
+SET lock_timeout = 0;
+SET idle_in_transaction_session_timeout = 0;
+SET client_encoding = 'UTF8';
+SET standard_conforming_strings = on;
+SELECT pg_catalog.set_config('search_path', '', false);
+SET check_function_bodies = false;
+SET xmloption = content;
+SET client_min_messages = warning;
+SET row_security = off;
+
+--
+-- Name: swarm; Type: DATABASE; Schema: -; Owner: postgres
+--
+
+CREATE DATABASE swarm WITH TEMPLATE = template0 ENCODING = 'UTF8' LOCALE = 'en_US.UTF-8';
+
+
+ALTER DATABASE swarm OWNER TO postgres;
+
+\connect swarm
+
+SET statement_timeout = 0;
+SET lock_timeout = 0;
+SET idle_in_transaction_session_timeout = 0;
+SET client_encoding = 'UTF8';
+SET standard_conforming_strings = on;
+SELECT pg_catalog.set_config('search_path', '', false);
+SET check_function_bodies = false;
+SET xmloption = content;
+SET client_min_messages = warning;
+SET row_security = off;
+
+SET default_tablespace = '';
+
+SET default_table_access_method = heap;
+
+--
+-- Name: evaluated_solution; Type: TABLE; Schema: public; Owner: kostmo
+--
+
+CREATE TABLE public.evaluated_solution (
+    id integer NOT NULL,
+    evaluated_at timestamp with time zone DEFAULT now() NOT NULL,
+    scenario character varying(40) NOT NULL,
+    seed bigint NOT NULL,
+    wall_time_seconds double precision NOT NULL,
+    ticks bigint,
+    char_count integer,
+    ast_size integer,
+    builtin boolean NOT NULL
+);
+
+
+ALTER TABLE public.evaluated_solution OWNER TO kostmo;
+
+--
+-- Name: scenarios; Type: TABLE; Schema: public; Owner: kostmo
+--
+
+CREATE TABLE public.scenarios (
+    content_sha1 character varying(40) NOT NULL,
+    uploader integer NOT NULL,
+    original_filename text,
+    swarm_git_sha1 character varying(40),
+    uploaded_at timestamp with time zone DEFAULT now() NOT NULL,
+    content text NOT NULL
+);
+
+
+ALTER TABLE public.scenarios OWNER TO kostmo;
+
+--
+-- Name: solution_id_seq; Type: SEQUENCE; Schema: public; Owner: kostmo
+--
+
+CREATE SEQUENCE public.solution_id_seq
+    AS integer
+    START WITH 1
+    INCREMENT BY 1
+    NO MINVALUE
+    NO MAXVALUE
+    CACHE 1;
+
+
+ALTER TABLE public.solution_id_seq OWNER TO kostmo;
+
+--
+-- Name: solution_id_seq; Type: SEQUENCE OWNED BY; Schema: public; Owner: kostmo
+--
+
+ALTER SEQUENCE public.solution_id_seq OWNED BY public.evaluated_solution.id;
+
+
+--
+-- Name: solution_submission; Type: TABLE; Schema: public; Owner: kostmo
+--
+
+CREATE TABLE public.solution_submission (
+    content_sha1 character varying(40) NOT NULL,
+    uploader integer NOT NULL,
+    uploaded_at timestamp with time zone DEFAULT now() NOT NULL,
+    solution_evaluation integer
+);
+
+
+ALTER TABLE public.solution_submission OWNER TO kostmo;
+
+--
+-- Name: users; Type: TABLE; Schema: public; Owner: kostmo
+--
+
+CREATE TABLE public.users (
+    id integer NOT NULL,
+    alias text NOT NULL,
+    created_at timestamp with time zone DEFAULT now() NOT NULL
+);
+
+
+ALTER TABLE public.users OWNER TO kostmo;
+
+--
+-- Name: submissions; Type: VIEW; Schema: public; Owner: kostmo
+--
+
+CREATE VIEW public.submissions AS
+ SELECT scenarios.original_filename,
+    scenarios.content_sha1 AS scenario,
+    scenarios.uploaded_at AS scenario_uploaded_at,
+    COALESCE(foo.submission_count, (0)::bigint) AS submission_count,
+    users.alias AS scenario_uploader,
+    scenarios.swarm_git_sha1
+   FROM ((public.scenarios
+     LEFT JOIN ( SELECT evaluated_solution.scenario,
+            count(*) AS submission_count
+           FROM public.evaluated_solution
+          WHERE (NOT evaluated_solution.builtin)
+          GROUP BY evaluated_solution.scenario) foo ON (((scenarios.content_sha1)::text = (foo.scenario)::text)))
+     JOIN public.users ON ((scenarios.uploader = users.id)));
+
+
+ALTER TABLE public.submissions OWNER TO kostmo;
+
+--
+-- Name: users_id_seq; Type: SEQUENCE; Schema: public; Owner: kostmo
+--
+
+CREATE SEQUENCE public.users_id_seq
+    AS integer
+    START WITH 1
+    INCREMENT BY 1
+    NO MINVALUE
+    NO MAXVALUE
+    CACHE 1;
+
+
+ALTER TABLE public.users_id_seq OWNER TO kostmo;
+
+--
+-- Name: users_id_seq; Type: SEQUENCE OWNED BY; Schema: public; Owner: kostmo
+--
+
+ALTER SEQUENCE public.users_id_seq OWNED BY public.users.id;
+
+
+--
+-- Name: evaluated_solution id; Type: DEFAULT; Schema: public; Owner: kostmo
+--
+
+ALTER TABLE ONLY public.evaluated_solution ALTER COLUMN id SET DEFAULT nextval('public.solution_id_seq'::regclass);
+
+
+--
+-- Name: users id; Type: DEFAULT; Schema: public; Owner: kostmo
+--
+
+ALTER TABLE ONLY public.users ALTER COLUMN id SET DEFAULT nextval('public.users_id_seq'::regclass);
+
+
+--
+-- Name: scenarios scenarios_pkey; Type: CONSTRAINT; Schema: public; Owner: kostmo
+--
+
+ALTER TABLE ONLY public.scenarios
+    ADD CONSTRAINT scenarios_pkey PRIMARY KEY (content_sha1);
+
+
+--
+-- Name: solution_submission solution_file_pkey; Type: CONSTRAINT; Schema: public; Owner: kostmo
+--
+
+ALTER TABLE ONLY public.solution_submission
+    ADD CONSTRAINT solution_file_pkey PRIMARY KEY (content_sha1);
+
+
+--
+-- Name: evaluated_solution solution_pkey; Type: CONSTRAINT; Schema: public; Owner: kostmo
+--
+
+ALTER TABLE ONLY public.evaluated_solution
+    ADD CONSTRAINT solution_pkey PRIMARY KEY (id);
+
+
+--
+-- Name: users users_pkey; Type: CONSTRAINT; Schema: public; Owner: kostmo
+--
+
+ALTER TABLE ONLY public.users
+    ADD CONSTRAINT users_pkey PRIMARY KEY (id);
+
+
+--
+-- Name: fki_solution_file_solution; Type: INDEX; Schema: public; Owner: kostmo
+--
+
+CREATE INDEX fki_solution_file_solution ON public.solution_submission USING btree (solution_evaluation);
+
+
+--
+-- Name: fki_solution_scenario; Type: INDEX; Schema: public; Owner: kostmo
+--
+
+CREATE INDEX fki_solution_scenario ON public.evaluated_solution USING btree (scenario);
+
+
+--
+-- Name: scenario_uploader; Type: INDEX; Schema: public; Owner: kostmo
+--
+
+CREATE INDEX scenario_uploader ON public.scenarios USING btree (uploader);
+
+
+--
+-- Name: scenarios scenarios_uploader_fkey; Type: FK CONSTRAINT; Schema: public; Owner: kostmo
+--
+
+ALTER TABLE ONLY public.scenarios
+    ADD CONSTRAINT scenarios_uploader_fkey FOREIGN KEY (uploader) REFERENCES public.users(id) NOT VALID;
+
+
+--
+-- Name: solution_submission solution_file_solution; Type: FK CONSTRAINT; Schema: public; Owner: kostmo
+--
+
+ALTER TABLE ONLY public.solution_submission
+    ADD CONSTRAINT solution_file_solution FOREIGN KEY (solution_evaluation) REFERENCES public.evaluated_solution(id) NOT VALID;
+
+
+--
+-- Name: evaluated_solution solution_scenario; Type: FK CONSTRAINT; Schema: public; Owner: kostmo
+--
+
+ALTER TABLE ONLY public.evaluated_solution
+    ADD CONSTRAINT solution_scenario FOREIGN KEY (scenario) REFERENCES public.scenarios(content_sha1) NOT VALID;
+
+
+--
+-- PostgreSQL database dump complete
+--
+

tournament/scripts/database/dump-local-schema.sh

@@ -0,0 +1,5 @@
+#!/bin/bash -ex
+
+GIT_ROOT_DIR=$(git rev-parse --show-toplevel)
+
+pg_dump --create -s -d swarm > $GIT_ROOT_DIR/tournament/schema/schema-local.sql

tournament/scripts/database/recreate-local-database.sh

@@ -0,0 +1,8 @@
+#!/bin/bash -ex
+
+GIT_ROOT_DIR=$(git rev-parse --show-toplevel)
+
+sudo service postgresql restart
+dropdb swarm
+
+sudo -u postgres psql < $GIT_ROOT_DIR/tournament/schema/schema-local.sql

tournament/scripts/demo/README.md

@@ -0,0 +1,27 @@
+# Running in local development environment
+
+The `client.sh` script can be run with either the `server-docker.sh` or the `server-native.sh` script as the host.
+
+Running the server application natively is the simplest option and connects to the local Postgres database via a socket.
+
+Running the server inside a local Docker image requires supplying the Postgres password as an environment variable.
+
+## Database setup
+
+One first needs to install a local Postgres server.
+
+After configuring logins and users, one may populate the database using the stored `schema-local.sql` schema with a script:
+
+    tournament/scripts/database/recreate-local-database.sh
+
+### Configuring database access from Docker
+
+See this answer: https://stackoverflow.com/a/58015643/105137
+
+To summarize:
+
+* Edit `postgresql.conf`, uncomment and set `listen_addresses = '*'`
+* Edit `pg_hba.conf`, add the line:
+    ```
+    host   all              all             172.17.0.0/16           password
+    ```

tournament/scripts/demo/client/fetch.sh

@@ -0,0 +1,27 @@
+#!/bin/bash -ex
+
+# This exercises the tournament API by:
+#
+# 1. Uploading a scenario file
+# 2. Uploading a solution file for that scenario
+#
+# This script is idempotent. Repeated invocations
+# fetch from the database cache rather than re-evaluating.
+
+cd $(git rev-parse --show-toplevel)
+
+SCENARIO_DATA_DIR=data/scenarios
+PORT=8080
+BASE_API_URL=http://localhost:$PORT
+
+SCENARIO_UPLOAD_URL=$BASE_API_URL/upload/scenario
+SCENARIO_FILEPATH=$SCENARIO_DATA_DIR/Challenges/arbitrage.yaml
+SCENARIO_HASH=$(curl --silent -F "my_file=@$SCENARIO_FILEPATH" $SCENARIO_UPLOAD_URL | jq -r .scenarioFileMetadata.fileHash)
+
+echo "Scenario hash: $SCENARIO_HASH"
+
+SCENARIO_DOWNLOAD_URL=$BASE_API_URL/scenario/$SCENARIO_HASH/metadata
+curl --silent $SCENARIO_DOWNLOAD_URL | jq .
+
+# SCENARIO_DOWNLOAD_URL=$BASE_API_URL/scenario/$SCENARIO_HASH/fetch
+#curl --silent $SCENARIO_DOWNLOAD_URL

tournament/scripts/demo/client/submit.sh

@@ -0,0 +1,35 @@
+#!/bin/bash -ex
+
+# Parameters:
+# $1 = hostname (and optional port)
+# $2 = path to scenario file*
+# $3 = path to solution file*
+#
+# *Paths are relative to the git repository root.
+
+HOST=$1
+SCENARIO_FILEPATH=$2
+SOLUTION_FILEPATH=$3
+
+# Example:
+#   tournament/scripts/demo/client/submit.sh localhost:8008 data/scenarios/Challenges/dimsum.yaml data/scenarios/Challenges/_dimsum/solution.sw
+# or
+#   tournament/scripts/demo/client/submit.sh swarmgame.net data/scenarios/Challenges/arbitrage.yaml data/scenarios/Challenges/_arbitrage/solution.sw
+#
+# This exercises the tournament API by:
+#
+# 1. Uploading a scenario file
+# 2. Uploading a solution file for that scenario
+#
+# This script is idempotent. Repeated invocations
+# fetch from the database cache rather than re-evaluating.
+
+cd $(git rev-parse --show-toplevel)
+
+BASE_UPLOAD_URL=http://$HOST/upload
+
+SCENARIO_UPLOAD_URL=$BASE_UPLOAD_URL/scenario
+SCENARIO_HASH=$(curl --silent -F "my_file=@$SCENARIO_FILEPATH" $SCENARIO_UPLOAD_URL | jq -r .scenarioFileMetadata.fileHash)
+
+SOLUTION_UPLOAD_URL=$BASE_UPLOAD_URL/solution
+curl --silent -F "scenario=$SCENARIO_HASH" -F "my_file=@$SOLUTION_FILEPATH" $SOLUTION_UPLOAD_URL

tournament/scripts/demo/client/test-cases/local/good-submit.sh

@@ -0,0 +1,8 @@
+#!/bin/bash -ex
+
+cd $(git rev-parse --show-toplevel)
+
+tournament/scripts/demo/client/submit.sh \
+    localhost:8008 \
+    data/scenarios/Challenges/arbitrage.yaml \
+    data/scenarios/Challenges/_arbitrage/solution.sw

tournament/scripts/demo/client/test-cases/local/wrong-scenario-cached-solution.sh

@@ -0,0 +1,13 @@
+#!/bin/bash -ex
+
+# This test cases demonstrates the failure whether or
+# not the solutions to both scenarios have already been submitted.
+
+cd $(git rev-parse --show-toplevel)
+
+tournament/scripts/demo/client/test-cases/local/good-submit.sh
+
+tournament/scripts/demo/client/submit.sh \
+    localhost:8008 \
+    data/scenarios/Challenges/dimsum.yaml \
+    data/scenarios/Challenges/_arbitrage/solution.sw

tournament/scripts/demo/server-docker.sh

@@ -0,0 +1,14 @@
+#!/bin/bash -ex
+
+GIT_ROOT_DIR=$(git rev-parse --show-toplevel)
+cd $GIT_ROOT_DIR
+
+# NOTE: First, you may need to build the Docker image
+tournament/scripts/docker/build-image.sh
+
+docker run \
+    --add-host=host.docker.internal:host-gateway \
+    --env-file $GIT_ROOT_DIR/tournament/scripts/docker/local-pg-credentials.env \
+    -it \
+    -p 8080:8080 \
+    --rm swarm

tournament/scripts/demo/server-native.sh

@@ -0,0 +1,14 @@
+#!/bin/bash -ex
+
+# Runs the tournament server natively on the host.
+
+cd $(git rev-parse --show-toplevel)
+
+GIT_HASH=$(git rev-parse HEAD)
+
+stack build --fast swarm:swarm-host-tournament && \
+  stack exec swarm-host-tournament -- \
+    --native-dev \
+    --port 8080 \
+    --version $GIT_HASH \
+    "$@"

tournament/scripts/docker/Dockerfile

@@ -0,0 +1,101 @@
+# This is meant to be invoked while
+# the CWD is the swarm repository root.
+
+FROM amazonlinux:latest as amz
+LABEL org.opencontainers.image.authors="Karl Ostmo <kostmo@gmail.com>"
+
+ENV TZ=America/Los_Angeles
+
+# OS dependencies
+RUN yum -y update && yum -y install \
+    postgresql-devel
+
+# The 'python' executable is required to run the AWS CLI installer
+#RUN yum -y install python
+RUN ln -s /usr/bin/python3 /usr/bin/python
+
+RUN curl https://s3.amazonaws.com/aws-cli/awscli-bundle.zip -o awscli-bundle.zip
+RUN unzip awscli-bundle.zip
+RUN ./awscli-bundle/install -i /usr/local/aws -b /usr/local/bin/aws
+
+RUN mkdir -p /opt/swarm
+
+FROM amz as system-build-deps
+
+# These packages are only needed at build time, not at runtime.
+RUN yum -y install \
+    ncurses-compat-libs \
+    gmp \
+    gmp-devel \
+    zlib-devel \
+    fftw3-devel \
+    xz-devel \
+    nss \
+    nss-devel \
+    openssl-devel \
+    gcc \
+    gcc-c++ \
+    make \
+    tar
+
+FROM system-build-deps as haskell-compilation-layer
+
+# install ghcup
+RUN \
+    curl https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup > /usr/bin/ghcup && \
+    chmod +x /usr/bin/ghcup
+
+ARG GHC=9.6.4
+
+# install GHC and cabal
+RUN \
+    ghcup -v install ghc --isolate /usr/local --force ${GHC} && \
+    ghcup -v install cabal --isolate /usr/local/bin
+
+
+WORKDIR /opt/swarm
+
+COPY ./swarm.cabal /opt/swarm/swarm.cabal
+RUN cabal update
+
+# Must manually list the transitive closure of "internal" dependencies (sublibraries)
+# of our executable.
+# Note that we avoid simply listing all sublibraries here
+# (i.e. scripts/gen/list-sublibraries.sh) because that
+# includes 'swarm:swarm-web' and will build pandoc.
+RUN cabal build --only-dependencies \
+  swarm:swarm-host-tournament \
+  swarm:swarm-tournament \
+  swarm:swarm-engine \
+  swarm:swarm-lang \
+  swarm:swarm-scenario \
+  swarm:swarm-util
+
+COPY ./src /opt/swarm/src
+COPY ./app /opt/swarm/app
+
+# The following are not strictly needed for compiling the
+# selected dependencies, but 'cabal build' spews warnings
+# when they are absent
+COPY ./test /opt/swarm/test
+COPY ./CHANGELOG.md /opt/swarm/CHANGELOG.md
+COPY ./LICENSE /opt/swarm/LICENSE
+
+COPY tournament/scripts/docker/build-server-executable.sh /opt/swarm/build-server-executable.sh
+RUN /opt/swarm/build-server-executable.sh /opt/swarm/tournament-bin
+
+FROM amz
+
+COPY --from=haskell-compilation-layer /opt/swarm/tournament-bin /opt/swarm/tournament-bin
+COPY ./data /root/.local/share/swarm/data
+COPY ./tournament/web /root/tournament/web
+
+# This was produced by the parent script, 'build-image.sh'.
+COPY ./git-hash.txt /root/git-hash.txt
+
+EXPOSE 8080
+
+# We begin initially with CWD as the filesystem root, "/".
+# We first 'cd' into the home directory, which is "/root", so we
+# have access to the static web files.
+CMD cd && /opt/swarm/tournament-bin --port 8080 --version $(cat git-hash.txt)

tournament/scripts/docker/aws-login.sh

@@ -0,0 +1,5 @@
+#!/bin/bash -ex
+
+cd $(git rev-parse --show-toplevel)
+
+aws ecr get-login-password --region us-east-1 | docker login --username AWS --password-stdin 254464607561.dkr.ecr.us-east-1.amazonaws.com/swarm-game

tournament/scripts/docker/build-image.sh

@@ -0,0 +1,11 @@
+#!/bin/bash -ex
+
+cd $(git rev-parse --show-toplevel)
+
+CURRENT_GIT_HASH_FILEPATH=git-hash.txt
+
+git rev-parse HEAD > $CURRENT_GIT_HASH_FILEPATH
+
+docker build --tag swarm --file tournament/scripts/docker/Dockerfile .
+
+rm $CURRENT_GIT_HASH_FILEPATH

tournament/scripts/docker/build-server-executable.sh

@@ -0,0 +1,16 @@
+#!/bin/bash -ex
+
+# Usage:
+# Intended to be invoked in Dockerfile.
+#
+#    build-server-executable.sh <output binary location>
+#
+# Note that we use 'cabal' instead of 'stack' becuase
+# 'stack' fails to compile the 'vty' package within the Amazon Linux docker image.
+
+# For faster development iteration, disable optimizations:
+CABAL_ARGS="--disable-optimization swarm:swarm-host-tournament"
+#CABAL_ARGS="swarm:swarm-host-tournament"
+
+cabal build -j $CABAL_ARGS
+cp $(cabal list-bin $CABAL_ARGS) $1

tournament/scripts/docker/docker-prereqs.sh

@@ -0,0 +1,6 @@
+#!/bin/bash
+
+# Run this script on your host machine to prepare
+# for development with Docker
+
+sudo apt install docker.io

tournament/scripts/docker/local-docker-shell.sh

@@ -0,0 +1,6 @@
+#!/bin/bash -ex
+
+cd $(git rev-parse --show-toplevel)
+
+#$NAME_ARG="--name swarm-container"
+docker run -it $NAME_ARG -p 8080:8080 --entrypoint /bin/bash swarm

tournament/scripts/docker/local-pg-credentials.env

@@ -0,0 +1 @@
+LOCAL_PGPASS=irrelevantpassword

tournament/scripts/docker/redeploy-image.sh

@@ -0,0 +1,16 @@
+#!/bin/bash -ex
+
+cd $(git rev-parse --show-toplevel)
+
+tournament/scripts/docker/build-image.sh
+
+AWS_DOCKER_IMAGE=254464607561.dkr.ecr.us-east-1.amazonaws.com/swarm-game:latest
+
+docker tag swarm:latest $AWS_DOCKER_IMAGE
+
+# Optionally log in again
+tournament/scripts/docker/aws-login.sh
+docker push $AWS_DOCKER_IMAGE
+
+# Next, run:
+#   eb deploy swarm-tournament-server-env

tournament/web/index.html

@@ -0,0 +1,11 @@
+<!doctype html>
+<html>
+  <head>
+    <title>Swarm tournament</title>
+  </head>
+  <body>
+    <h1>Hello Swarm player!</h1>
+    <p>This site hosts tournaments. <a href="list-games.html">List all games</a></p>
+    <p>Looking for the <a href="api">Web API docs</a>?</p>
+  </body>
+</html>

tournament/web/list-games.html

@@ -0,0 +1,46 @@
+<!doctype html>
+<html>
+  <head>
+    <title>Swarm tournament games</title>
+
+    <link rel="stylesheet" href="style/tablesort.css"/>
+    <link rel="stylesheet" href="style/list-games.css"/>
+    <link rel="stylesheet" href="style/spinner.css"/>
+
+    <style type="text/css">
+      #spinner-container {
+        display: flex;
+        justify-content: center;
+        align-items: center;
+      }
+    </style>
+
+    <script src="https://cdnjs.cloudflare.com/ajax/libs/tablesort/5.1.0/tablesort.min.js"></script>
+    <script src="script/list-games.js"></script>
+
+    <script>
+      window.onload=()=>{
+        const tableElement = document.querySelector("table");
+        doFetch(tableElement);
+      }
+    </script>
+  </head>
+  <body>
+    <table id="my-table">
+        <thead>
+          <tr data-sort-method="none">
+            <th>Filename</th>
+            <th>Uploader</th>
+            <th>Soln. submissions</th>
+            <th>Swarm version</th>
+          </tr>
+        </thead>
+        <tbody id="my-table-body">
+        </tbody>
+      </table>
+
+      <div id="spinner-container">
+        <span id="spinner" class="lds-dual-ring"></span>
+      </div>
+  </body>
+</html>

tournament/web/script/list-games.js

@@ -0,0 +1,62 @@
+
+function mkLink(text, url) {
+    const anchor = document.createElement("a");
+    anchor.href = url
+    anchor.textContent = text;
+    return anchor;
+}
+
+function insertTableRows(myTableBody, entries) {
+    for (const entry of entries) {
+        const rowItem = document.createElement("tr");
+
+        const fieldVals = [
+            entry.scenarioUploader,
+            entry.submissionCount,
+            entry.swarmGitSha1,
+        ];
+
+        const cellVals = [
+            mkLink(entry.originalFilename, "scenario/" + entry.scenarioHash + "/fetch"),
+        ];
+
+        for (const val of fieldVals) {
+            const span = document.createElement("span");
+            span.appendChild(document.createTextNode(val));
+            cellVals.push(span);
+        }
+
+        for (const val of cellVals) {
+            const cellElement = document.createElement("td");
+            cellElement.appendChild(val);
+            rowItem.append(cellElement);
+        }
+
+        myTableBody.appendChild(rowItem);
+    }
+}
+
+function doFetch(myTable) {
+    document.getElementById("spinner-container").style.display = 'flex';
+    
+    fetch("games")
+    .then((response) => {
+        if (!response.ok) {
+            throw new Error(`HTTP error, status = ${response.status}`);
+        }
+        return response.json();
+    })
+    .then((data) => {
+        const myTableBody = myTable.querySelector("tbody");
+        insertTableRows(myTableBody, data);
+        // Documentation: http://tristen.ca/tablesort/demo/
+        new Tablesort(document.getElementById('my-table'));
+        document.getElementById("spinner-container").style.display = 'none';
+    })
+    .catch((error) => {
+        const p = document.createElement("p");
+        p.appendChild(document.createTextNode(`Error: ${error.message}`));
+        document.body.insertBefore(p, myTable);
+        document.getElementById("spinner-container").style.display = 'none';
+    });
+}

tournament/web/style/list-games.css

@@ -0,0 +1,34 @@
+body {
+  font-family: sans-serif;
+}
+
+.trueValue {
+  color: #00a000;
+}
+
+.falseValue {
+  color: #a00000;
+}
+
+a:link {
+  color: lavender;
+  text-decoration: none;
+}
+
+/* visited link */
+a:visited {
+  color: lightblue;
+  text-decoration: none;
+}
+
+/* mouse over link */
+a:hover {
+  color: hotpink;
+  text-decoration: underline;
+}
+
+/* selected link */
+a:active {
+  color: blue;
+  text-decoration: underline;
+}

tournament/web/style/spinner.css

@@ -0,0 +1,29 @@
+
+.lds-dual-ring,
+.lds-dual-ring:after {
+  box-sizing: border-box;
+}
+.lds-dual-ring {
+  display: inline-block;
+  width: 80px;
+  height: 80px;
+}
+.lds-dual-ring:after {
+  content: " ";
+  display: block;
+  width: 64px;
+  height: 64px;
+  margin: 8px;
+  border-radius: 50%;
+  border: 6.4px solid currentColor;
+  border-color: currentColor transparent currentColor transparent;
+  animation: lds-dual-ring 1.2s linear infinite;
+}
+@keyframes lds-dual-ring {
+  0% {
+    transform: rotate(0deg);
+  }
+  100% {
+    transform: rotate(360deg);
+  }
+}

tournament/web/style/tablesort.css

@@ -0,0 +1,48 @@
+body {
+    color: white;
+    background-color: #212121;
+}
+
+table {
+  margin-left: auto;
+  margin-right: auto;
+}
+
+th, td {
+  padding: 0.25em;
+}
+
+th[role=columnheader]:not(.no-sort) {
+    cursor: pointer;
+}
+
+th[role=columnheader]:not(.no-sort):after {
+    content: '';
+    float: right;
+    margin-top: 7px;
+  margin-left: 5px;
+    border-width: 0 4px 4px;
+    border-style: solid;
+    border-color: white transparent;
+    visibility: hidden;
+    opacity: 0;
+    -ms-user-select: none;
+    -webkit-user-select: none;
+    -moz-user-select: none;
+    user-select: none;
+}
+
+th[aria-sort=ascending]:not(.no-sort):after {
+    border-bottom: none;
+    border-width: 4px 4px 0;
+}
+
+th[aria-sort]:not(.no-sort):after {
+    visibility: visible;
+    opacity: 0.4;
+}
+
+th[role=columnheader]:not(.no-sort):hover:after {
+    visibility: visible;
+    opacity: 1;
+}