Implement GitHub authentication (#1856)

Closes #1847.

## Demo

### Production
https://swarmgame.net/list-games.html

### Local testing
```
tournament/scripts/demo/server-native.sh
```
and

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

## Authentication flow

1. Users are represented by a GitHub username (primary key) and an "authentication cookie" in the SQLite database.
2. Site prompts user to login when the client's cookie is nonexistent or does not match any user in the database.
3. GitHub flow:
    1. Clicking the "Login" link redirects user to the GitHub login page.
    2. GitHub sends a `code` to our callback URL.
    3. use that `code` to get an "access token"
    4. use the "access token" to look up the username of the person who is logging in.
    5. generate and store a new cookie in the database row for that username
    6. set the cookie value on the user's client.
4. As long as the client keeps sending the cookie value known to the server, all uploads/activity will be attributed to their GitHub username.

## New features

* Login/Logout
* All uploaded content is attributed to an authenticated GitHub user
* Separate pages for scenario lists and solution lists
* Download a solution file

app/tournament/Main.hs

@@ -1,20 +1,25 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 -- |
 -- SPDX-License-Identifier: BSD-3-Clause
 module Main where
 
 import Control.Monad.Trans.Reader (runReaderT)
 import Data.Maybe (fromMaybe)
+import Data.Yaml (decodeFileThrow)
+import Database.SQLite.Simple (execute_, withConnection)
 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 Swarm.Web.Tournament.Type (UserAlias (..))
 
 data AppOpts = AppOpts
   { userWebPort :: Maybe Port
   -- ^ Explicit port on which to run the web API
   , gameGitVersion :: Sha1
-  , isLocalSocketConnection :: Bool
+  , deploymentEnv :: DeploymentEnvironment
   }
 
 webPort :: Parser (Maybe Int)
@@ -37,13 +42,15 @@ gameVersion =
           <> help "Set the git version of the game"
       )
 
-parseNativeDev :: Parser Bool
+parseRunningLocally :: Parser DeploymentEnvironment
-parseNativeDev =
+parseRunningLocally =
-  switch
+  flag
-    (long "native-dev" <> help "Running locally outside of a Docker container for development")
+    ProdDeployment
+    (LocalDevelopment $ UserAlias "local-user")
+    (long "local" <> help "Running locally for development")
 
 cliParser :: Parser AppOpts
-cliParser = AppOpts <$> webPort <*> gameVersion <*> parseNativeDev
+cliParser = AppOpts <$> webPort <*> gameVersion <*> parseRunningLocally
 
 cliInfo :: ParserInfo AppOpts
 cliInfo =
@@ -57,24 +64,37 @@ cliInfo =
 main :: IO ()
 main = do
   opts <- execParser cliInfo
+
+  creds <- case deploymentEnv opts of
+    LocalDevelopment _ -> return $ GitHubCredentials "" ""
+    ProdDeployment -> decodeFileThrow "swarm-github-app-credentials.yaml"
+
   webMain
-    (AppData (gameGitVersion opts) persistenceFunctions)
+    (AppData (gameGitVersion opts) creds persistenceFunctions (deploymentEnv opts))
     (fromMaybe defaultPort $ userWebPort opts)
  where
   persistenceFunctions =
     PersistenceLayer
-      { lookupScenarioFileContent = withConnInfo lookupScenarioContent
+      { scenarioStorage =
-      , scenarioStorage =
           ScenarioPersistence
-            { lookupCache = withConnInfo lookupScenarioSolution
+            { lookupCache = withConn lookupScenarioSolution
-            , storeCache = withConnInfo insertScenario
+            , storeCache = withConn insertScenario
+            , getContent = withConn lookupScenarioContent
             }
       , solutionStorage =
           ScenarioPersistence
-            { lookupCache = withConnInfo lookupSolutionSubmission
+            { lookupCache = withConn lookupSolutionSubmission
-            , storeCache = withConnInfo insertSolutionSubmission
+            , storeCache = withConn insertSolutionSubmission
+            , getContent = withConn lookupSolutionContent
+            }
+      , authenticationStorage =
+          AuthenticationStorage
+            { usernameFromCookie = withConn getUsernameFromCookie
+            , cookieFromUsername = withConn insertCookie
             }
       }
    where
-    withConnInfo f x =
+    withConn f x =
-      runReaderT (f x) databaseFilename
+      withConnection databaseFilename $ \conn -> do
+        execute_ conn "PRAGMA foreign_keys = ON;"
+        runReaderT (f x) conn

src/swarm-engine/Swarm/Game/Tick.hs

@@ -7,7 +7,8 @@ module Swarm.Game.Tick (
   addTicks,
 ) where
 
-import Data.Aeson (FromJSON, ToJSON)
+import Data.Aeson (FromJSON, ToJSON (..))
+import Data.Aeson qualified as A
 import Data.Int (Int64)
 import GHC.Generics (Generic)
 import Prettyprinter (Pretty (..))
@@ -16,7 +17,10 @@ import Swarm.Util.WindowedCounter (Offsettable (..))
 -- | A newtype representing a count of ticks (typically since the
 --   start of a game).
 newtype TickNumber = TickNumber {getTickNumber :: Int64}
-  deriving (Eq, Ord, Show, Read, Generic, FromJSON, ToJSON)
+  deriving (Eq, Ord, Show, Read, Generic, FromJSON)
+
+instance ToJSON TickNumber where
+  toJSON = A.genericToJSON (A.defaultOptions {A.unwrapUnaryRecords = True})
 
 -- | Add an offset to a 'TickNumber'.
 addTicks :: Int -> TickNumber -> TickNumber

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

@@ -0,0 +1,130 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+--
+-- Authentication logic for Swarm tournament server.
+module Swarm.Web.Auth where
+
+import Control.Monad.Catch
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Data.Aeson
+import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString.UTF8 as BSU
+import Data.Map qualified as M
+import Data.Text qualified as T
+import Data.Text.Encoding qualified as DTE
+import Data.Text.Lazy qualified as TL
+import Database.SQLite.Simple.ToField
+import GHC.Generics (Generic)
+import Network.HTTP.Client qualified as HC
+import Network.HTTP.Types (hAccept, hUserAgent, parseSimpleQuery, renderSimpleQuery)
+import Servant
+import Text.Read (readMaybe)
+
+data GitHubCredentials = GitHubCredentials
+  { clientId :: BS.ByteString
+  , clientSecret :: BS.ByteString
+  }
+
+instance FromJSON GitHubCredentials where
+  parseJSON = withObject "GitHubCredentials" $ \v ->
+    let theID = BSU.fromString <$> v .: "CLIENT_ID"
+        theSecret = BSU.fromString <$> v .: "CLIENT_SECRET"
+     in GitHubCredentials
+          <$> theID
+          <*> theSecret
+
+newtype TokenExchangeCode = TokenExchangeCode BS.ByteString
+
+instance FromHttpApiData TokenExchangeCode where
+  parseUrlPiece = return . TokenExchangeCode . DTE.encodeUtf8
+
+newtype AccessToken = AccessToken BS.ByteString
+
+instance ToField AccessToken where
+  toField (AccessToken x) = toField x
+
+newtype RefreshToken = RefreshToken BS.ByteString
+
+instance ToField RefreshToken where
+  toField (RefreshToken x) = toField x
+
+data UserApiResponse = UserApiResponse
+  { login :: TL.Text
+  , id :: Int
+  , name :: TL.Text
+  }
+  deriving (Generic, FromJSON)
+
+data Expirable a = Expirable
+  { token :: a
+  , expirationSeconds :: Int
+  }
+
+fetchAuthenticatedUser ::
+  (MonadIO m, MonadThrow m, MonadFail m) =>
+  HC.Manager ->
+  AccessToken ->
+  m UserApiResponse
+fetchAuthenticatedUser manager (AccessToken tok) = do
+  req <- HC.parseUrlThrow "https://api.github.com/user"
+  resp <-
+    liftIO
+      . flip HC.httpLbs manager
+      . HC.applyBearerAuth tok
+      $ req
+        { HC.requestHeaders =
+            [ (hAccept, "application/vnd.github+json")
+            , (hUserAgent, "Swarm Gaming Hub")
+            , ("X-GitHub-Api-Version", "2022-11-28")
+            ]
+        }
+  either fail return $ eitherDecode $ HC.responseBody resp
+
+data ReceivedTokens = ReceivedTokens
+  { accessToken :: Expirable AccessToken
+  , refreshToken :: Expirable RefreshToken
+  }
+
+packExchangeResponse ::
+  M.Map ByteString ByteString ->
+  Maybe ReceivedTokens
+packExchangeResponse valMap =
+  ReceivedTokens
+    <$> (Expirable <$> atVal <*> toInt "expires_in")
+    <*> (Expirable <$> rtVal <*> toInt "refresh_token_expires_in")
+ where
+  toInt k = readMaybe . BSU.toString =<< M.lookup k valMap
+
+  atVal = AccessToken <$> M.lookup "access_token" valMap
+  rtVal = RefreshToken <$> M.lookup "refresh_token" valMap
+
+exchangeCode ::
+  (MonadIO m, MonadThrow m, MonadFail m) =>
+  HC.Manager ->
+  GitHubCredentials ->
+  TokenExchangeCode ->
+  m ReceivedTokens
+exchangeCode manager creds (TokenExchangeCode code) = do
+  let qParms =
+        T.unpack . DTE.decodeUtf8 $
+          renderSimpleQuery
+            True
+            [ ("client_id", clientId creds)
+            , ("client_secret", clientSecret creds)
+            , ("code", code)
+            ]
+  req <- HC.parseUrlThrow $ "https://github.com/login/oauth/access_token" <> qParms
+  resp <- liftIO $ flip HC.httpLbs manager $ req {HC.method = "POST"}
+
+  let parms = parseSimpleQuery $ LBS.toStrict $ HC.responseBody resp
+      valMap = M.fromList parms
+
+  maybe
+    (fail "Response did not include access token")
+    return
+    $ packExchangeResponse valMap

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

@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -10,6 +11,8 @@
 module Swarm.Web.Tournament (
   defaultPort,
   AppData (..),
+  GitHubCredentials (..),
+  DeploymentEnvironment (..),
 
   -- ** Development
   webMain,
@@ -17,24 +20,29 @@ module Swarm.Web.Tournament (
 ) where
 
 import Commonmark qualified as Mark (commonmark, renderHtml)
-import Control.Lens
+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.Lazy (ByteString)
+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', encodeUtf8)
+import Data.Text.Lazy.Encoding (decodeUtf8, decodeUtf8', encodeUtf8)
 import Data.Yaml (decodeEither', defaultEncodeOptions, encodeWith)
-import Network.HTTP.Types (ok200)
+import Database.SQLite.Simple (withConnection)
-import Network.Wai (responseLBS)
+import GHC.Generics (Generic)
-import Network.Wai.Application.Static (defaultFileServerSettings, ssIndices)
+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,
@@ -43,22 +51,17 @@ import Network.Wai.Parse (
   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 Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler)
-import Swarm.Game.Scenario.Scoring.CodeSize (ScenarioCodeMetrics (..))
+import Swarm.Game.Scenario (ScenarioMetadata, scenarioMetadata)
 import Swarm.Game.State (Sha1 (..))
-import Swarm.Game.Tick (TickNumber (..))
+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 WaiAppStatic.Types (unsafeToPiece)
+import Web.Cookie
-
-placeholderAlias :: UserAlias
-placeholderAlias = UserAlias "Karl"
 
 defaultPort :: Warp.Port
 defaultPort = 5500
@@ -66,58 +69,34 @@ 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
+defaultSolutionTimeout = SolutionTimeout 20
+
+data DeploymentEnvironment
+  = LocalDevelopment UserAlias
+  | ProdDeployment
 
 data AppData = AppData
   { swarmGameGitVersion :: Sha1
-  , persistence :: PersistenceLayer
+  , gitHubCredentials :: GitHubCredentials
+  , persistence :: PersistenceLayer IO
+  , developmentMode :: DeploymentEnvironment
   }
 
+type LoginType = Headers '[Header "Location" TL.Text, Header "Set-Cookie" SetCookie] NoContent
+type LoginHandler = Handler LoginType
+
 type TournamentAPI =
-  "upload" :> "scenario" :> MultipartForm Mem (MultipartData Mem) :> Post '[JSON] ScenarioCharacterization
+  "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)
-    :<|> "upload" :> "solution" :> MultipartForm Mem (MultipartData Mem) :> Post '[JSON] SolutionFileCharacterization
+    :<|> "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
-    :<|> "games" :> Get '[JSON] [TournamentGame]
+    :<|> "solution" :> Capture "sha1" Sha1 :> "fetch" :> Get '[PlainText] TL.Text
-
+    :<|> "list" :> "games" :> Get '[JSON] [TournamentGame]
-swarmApi :: Proxy TournamentAPI
+    :<|> "list" :> "game" :> Capture "sha1" Sha1 :> Get '[JSON] GameWithSolutions
-swarmApi = Proxy
+    :<|> "api" :> "private" :> "login" :> "status" :> AuthProtect "cookie-auth" :> Get '[JSON] UserAlias
-
+    :<|> "github-auth-callback" :> QueryParam "code" TokenExchangeCode :> Verb 'GET 303 '[JSON] LoginType
-type ToplevelAPI =
+    :<|> "api" :> "private" :> "login" :> "local" :> Header "Referer" TL.Text :> Verb 'GET 303 '[JSON] LoginType
-  TournamentAPI
+    :<|> "api" :> "private" :> "login" :> "logout" :> Header "Referer" TL.Text :> Verb 'GET 303 '[JSON] LoginType
-    :<|> "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 =
@@ -125,74 +104,234 @@ mkApp appData =
     :<|> uploadSolution appData
     :<|> getScenarioMetadata appData
     :<|> downloadRedactedScenario appData
+    :<|> downloadSolution appData
     :<|> listScenarios
+    :<|> listSolutions
+    :<|> echoUsername
+    :<|> doGithubCallback (authenticationStorage $ persistence appData) (gitHubCredentials appData)
+    :<|> doLocalDevelopmentLogin (authenticationStorage $ persistence appData) (developmentMode appData)
+    :<|> doLogout
+ where
+  echoUsername = return
 
-uploadScenario :: AppData -> MultipartData Mem -> Handler ScenarioCharacterization
+type ToplevelAPI =
-uploadScenario (AppData gameVersion persistenceLayer) multipartData =
+  TournamentAPI
-  Handler . withExceptT toServantError . ExceptT $
+    :<|> "api" :> Raw
+    :<|> Raw
+
+tournamentsApiHtml :: LBS.ByteString
+tournamentsApiHtml =
+  encodeUtf8
+    . either (error . show) (Mark.renderHtml @())
+    . Mark.commonmark ""
+    $ T.pack "No documentation at this time."
+
+toServantError :: Describable a => a -> ServerError
+toServantError x = err500 {errBody = encodeUtf8 $ TL.fromStrict $ describeText x}
+
+-- | We need to specify the data returned after authentication
+type instance AuthServerData (AuthProtect "cookie-auth") = UserAlias
+
+myAppCookieName :: BS.ByteString
+myAppCookieName = "servant-auth-cookie"
+
+data LoginProblem = LoginProblem
+  { problemMessage :: TL.Text
+  , loginLink :: TL.Text
+  }
+  deriving (Generic, ToJSON)
+
+--- | The auth handler wraps a function from Request -> Handler UserAlias.
+--- We look for a token in the request headers that we expect to be in the cookie.
+--- The token is then passed to our `lookupAccount` function.
+authHandler ::
+  AuthenticationStorage IO ->
+  GitHubCredentials ->
+  DeploymentEnvironment ->
+  AuthHandler Request UserAlias
+authHandler authStorage creds deployMode = mkAuthHandler handler
+ where
+  url = case deployMode of
+    LocalDevelopment _ -> "api/private/login/local"
+    ProdDeployment -> decodeUtf8 . LBS.fromStrict $ genLoginUrl creds
+
+  throw401 msg = throwError $ err401 {errBody = encode $ LoginProblem msg url}
+  handler req = either throw401 lookupAccount $ do
+    cookie <- maybeToEither "Missing cookie header" $ lookup hCookie $ requestHeaders req
+    maybeToEither "Missing token in cookie"
+      . fmap (decodeUtf8 . LBS.fromStrict)
+      . lookup myAppCookieName
+      $ parseCookies cookie
+
+  -- A method that, when given a cookie/password, will return a 'UserAlias'.
+  lookupAccount :: TL.Text -> Handler UserAlias
+  lookupAccount cookieText = do
+    maybeUser <- liftIO $ usernameFromCookie authStorage cookieText
+    case maybeUser of
+      Nothing -> throwError (err403 {errBody = encode $ LoginProblem "Invalid cookie password" url})
+      Just usr -> return usr
+
+-- * Handlers
+
+defaultRedirectPage :: TL.Text
+defaultRedirectPage = "/list-games.html"
+
+defaultSolutionSubmissionRedirectPage :: TL.Text
+defaultSolutionSubmissionRedirectPage = "/list-solutions.html"
+
+uploadScenario ::
+  AppData ->
+  Maybe TL.Text ->
+  UserAlias ->
+  MultipartData Mem ->
+  Handler (Headers '[Header "Location" TL.Text] ScenarioCharacterization)
+uploadScenario (AppData gameVersion _ persistenceLayer _) maybeRefererUrl userName multipartData =
+  Handler . fmap addH . withExceptT toServantError . ExceptT $
     validateScenarioUpload
       args
       gameVersion
  where
+  addH = addHeader (fromMaybe defaultRedirectPage maybeRefererUrl)
   args =
     CommonValidationArgs
       defaultSolutionTimeout
       $ PersistenceArgs
-        placeholderAlias
+        userName
         multipartData
         (scenarioStorage persistenceLayer)
 
-uploadSolution :: AppData -> MultipartData Mem -> Handler SolutionFileCharacterization
+uploadSolution ::
-uploadSolution (AppData _ persistenceLayer) multipartData =
+  AppData ->
-  Handler . withExceptT toServantError . ExceptT $
+  Maybe TL.Text ->
+  UserAlias ->
+  MultipartData Mem ->
+  Handler (Headers '[Header "Location" TL.Text] SolutionFileCharacterization)
+uploadSolution (AppData _ _ persistenceLayer _) maybeRefererUrl userName multipartData =
+  Handler . fmap addH . withExceptT toServantError . ExceptT $
     validateSubmittedSolution
       args
-      (lookupScenarioFileContent persistenceLayer)
+      ((getContent . scenarioStorage) persistenceLayer)
  where
+  addH = addHeader (fromMaybe defaultSolutionSubmissionRedirectPage maybeRefererUrl)
   args =
     CommonValidationArgs
       defaultSolutionTimeout
       $ PersistenceArgs
-        placeholderAlias
+        userName
         multipartData
         (solutionStorage persistenceLayer)
 
 getScenarioMetadata :: AppData -> Sha1 -> Handler ScenarioMetadata
-getScenarioMetadata (AppData _ persistenceLayer) scenarioSha1 =
+getScenarioMetadata (AppData _ _ persistenceLayer _) scenarioSha1 =
   Handler . withExceptT toServantError $ do
     doc <-
       ExceptT $
         maybeToEither (DatabaseRetrievalFailure scenarioSha1)
-          <$> lookupScenarioFileContent persistenceLayer scenarioSha1
+          <$> (getContent . scenarioStorage) persistenceLayer scenarioSha1
 
     s <- withExceptT RetrievedInstantiationFailure $ initScenarioObjectWithEnv doc
     return $ view scenarioMetadata s
 
+genLoginUrl :: GitHubCredentials -> BS.ByteString
+genLoginUrl creds =
+  "https://github.com/login/oauth/authorize"
+    <> renderSimpleQuery
+      True
+      [ ("client_id", clientId creds)
+      ]
+
+downloadSolution :: AppData -> Sha1 -> Handler TL.Text
+downloadSolution (AppData _ _ persistenceLayer _) solutionSha1 = do
+  Handler . withExceptT toServantError $ do
+    ExceptT $
+      maybeToEither (DatabaseRetrievalFailure solutionSha1)
+        <$> (fmap $ fmap decodeUtf8) ((getContent . solutionStorage) persistenceLayer solutionSha1)
+
 downloadRedactedScenario :: AppData -> Sha1 -> Handler TL.Text
-downloadRedactedScenario (AppData _ persistenceLayer) scenarioSha1 = do
+downloadRedactedScenario (AppData _ _ persistenceLayer _) scenarioSha1 = do
   Handler . withExceptT toServantError $ do
     doc <-
       ExceptT $
         maybeToEither (DatabaseRetrievalFailure scenarioSha1)
-          <$> lookupScenarioFileContent persistenceLayer scenarioSha1
+          <$> (getContent . scenarioStorage) persistenceLayer scenarioSha1
 
     rawYamlDict :: Map Key Value <- withExceptT YamlParseFailure . except . decodeEither' $ LBS.toStrict doc
     let redactedDict = M.delete "solution" rawYamlDict
     withExceptT DecodingFailure . except . decodeUtf8' . LBS.fromStrict $
       encodeWith defaultEncodeOptions redactedDict
 
--- NOTE: This is currently the only API endpoint that invokes
--- 'runReaderT' directly
 listScenarios :: Handler [TournamentGame]
 listScenarios =
-  Handler $
+  Handler . liftIO . withConnection databaseFilename $ runReaderT listGames
-    liftIO $
+
-      runReaderT listGames databaseFilename
+listSolutions :: Sha1 -> Handler GameWithSolutions
+listSolutions sha1 =
+  Handler . liftIO . withConnection databaseFilename . runReaderT $ listSubmissions sha1
+
+doGithubCallback ::
+  AuthenticationStorage IO ->
+  GitHubCredentials ->
+  Maybe TokenExchangeCode ->
+  LoginHandler
+doGithubCallback authStorage creds maybeCode = do
+  c <- maybe (fail "Missing 'code' parameter") return maybeCode
+
+  manager <- liftIO $ HC.newManager tlsManagerSettings
+  receivedTokens <- exchangeCode manager creds c
+
+  let aToken = token $ accessToken receivedTokens
+  userInfo <- fetchAuthenticatedUser manager aToken
+  let user = UserAlias $ login userInfo
+  x <- doLoginResponse authStorage defaultRedirectPage user
+  liftIO . withConnection databaseFilename . runReaderT $ do
+    insertGitHubTokens user receivedTokens
+  return x
+
+doLocalDevelopmentLogin ::
+  AuthenticationStorage IO ->
+  DeploymentEnvironment ->
+  Maybe TL.Text ->
+  LoginHandler
+doLocalDevelopmentLogin authStorage envType maybeRefererUrl =
+  case envType of
+    ProdDeployment -> error "Login bypass not available in production"
+    LocalDevelopment user ->
+      doLoginResponse authStorage refererUrl user
+ where
+  refererUrl = fromMaybe defaultRedirectPage maybeRefererUrl
+
+makeCookieHeader :: BS.ByteString -> SetCookie
+makeCookieHeader val =
+  defaultSetCookie
+    { setCookieName = myAppCookieName
+    , setCookieValue = val
+    , setCookiePath = Just "/api/private"
+    }
+
+doLogout :: Maybe TL.Text -> LoginHandler
+doLogout maybeRefererUrl =
+  return $
+    addHeader (fromMaybe defaultRedirectPage maybeRefererUrl) $
+      addHeader ((makeCookieHeader "") {setCookieMaxAge = Just 0}) NoContent
+
+doLoginResponse ::
+  AuthenticationStorage IO ->
+  TL.Text ->
+  UserAlias ->
+  LoginHandler
+doLoginResponse authStorage refererUrl userAlias = do
+  cookieString <-
+    liftIO $ cookieFromUsername authStorage userAlias
+  return $
+    addHeader refererUrl $
+      addHeader (makeCookieHeader $ LBS.toStrict $ encodeUtf8 cookieString) NoContent
 
 -- * Web app declaration
 
-app :: AppData -> Application
+app :: Bool -> AppData -> Application
-app appData = Servant.serveWithContext api context server
+app unitTestFileserver appData =
+  Servant.serveWithContext (Proxy :: Proxy ToplevelAPI) context $
+    server unitTestFileserver
  where
   size100kB = 100_000 :: Int64
 
@@ -206,68 +345,46 @@ app appData = Servant.serveWithContext api context server
             $ defaultParseRequestBodyOptions
       }
 
-  context = multipartOpts :. EmptyContext
+  thisAuthHandler =
+    authHandler
+      (authenticationStorage $ persistence appData)
+      (gitHubCredentials appData)
+      (developmentMode appData)
+  context = thisAuthHandler :. multipartOpts :. EmptyContext
 
-  server :: Server ToplevelAPI
+  server :: Bool -> Server ToplevelAPI
-  server =
+  server fakeFileserverForUnitTest =
     mkApp appData
       :<|> Tagged serveDocs
-      :<|> serveDirectoryWith
+      :<|> fileserver
-        (defaultFileServerSettings "tournament/web")
-          { ssIndices = [unsafeToPiece "index.html"]
-          }
    where
+    fileserver =
+      if fakeFileserverForUnitTest
+        then -- This is required because the data only files available to
+        -- the testing environment are included in the cabal file
+        -- in the "data-files" clause.
+        -- However, since that clause is global to the package,
+        -- we choose not to include the tournament server's web
+        -- files there.
+        -- Instead, we manually stub the paths that are used as redirects
+        -- so that the web API invocation does not 404 when looking for them.
+
+          serveDirectoryEmbedded
+            [ (TL.unpack defaultRedirectPage, "Hello World!")
+            , (TL.unpack defaultSolutionSubmissionRedirectPage, "Hello World!")
+            ]
+        else
+          serveDirectoryWith
+            (defaultFileServerSettings "tournament/web")
+
     serveDocs _ resp =
-      resp $ responseLBS ok200 [plain] swarmApiHtml
+      resp $ responseLBS ok200 [htmlType] tournamentsApiHtml
-    plain = ("Content-Type", "text/html")
+    htmlType = ("Content-Type", "text/html")
 
 webMain ::
   AppData ->
   Warp.Port ->
   IO ()
-webMain appData port = Warp.runSettings settings $ app appData
+webMain appData port = Warp.runSettings settings $ app False 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

@@ -14,14 +14,16 @@ 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.Text qualified as T
+import Data.Text.Lazy qualified as TL
 import Data.Time.Clock
 import Database.SQLite.Simple
 import Database.SQLite.Simple.ToField
 import Swarm.Game.Scenario.Scoring.CodeSize
 import Swarm.Game.State (Sha1 (..))
 import Swarm.Game.Tick (TickNumber (..))
+import Swarm.Web.Auth
 import Swarm.Web.Tournament.Type
 
 type ConnectInfo = String
@@ -34,18 +36,24 @@ newtype UserId = UserId Int
 instance ToField UserId where
   toField (UserId x) = toField x
 
-data PersistenceLayer = PersistenceLayer
+data AuthenticationStorage m = AuthenticationStorage
-  { lookupScenarioFileContent :: Sha1 -> IO (Maybe LBS.ByteString)
+  { usernameFromCookie :: TL.Text -> m (Maybe UserAlias)
-  -- ^ Dump scenario file
+  , cookieFromUsername :: UserAlias -> m TL.Text
-  , scenarioStorage :: ScenarioPersistence ScenarioUploadResponsePayload
-  , solutionStorage :: ScenarioPersistence SolutionUploadResponsePayload
   }
 
-data ScenarioPersistence b = ScenarioPersistence
+data PersistenceLayer m = PersistenceLayer
-  { lookupCache :: Sha1 -> IO (Maybe AssociatedSolutionSolutionCharacterization)
+  { scenarioStorage :: ScenarioPersistence m ScenarioUploadResponsePayload
+  , solutionStorage :: ScenarioPersistence m SolutionUploadResponsePayload
+  , authenticationStorage :: AuthenticationStorage m
+  }
+
+data ScenarioPersistence m a = ScenarioPersistence
+  { lookupCache :: Sha1 -> m (Maybe AssociatedSolutionCharacterization)
   -- ^ Looks up by key
-  , storeCache :: CharacterizationResponse b -> IO Sha1
+  , storeCache :: CharacterizationResponse a -> m Sha1
   -- ^ Stores and returns key
+  , getContent :: Sha1 -> m (Maybe LBS.ByteString)
+  -- ^ Dump file contents
   }
 
 data UserAttributedUpload = UserAttributedUpload
@@ -55,21 +63,22 @@ data UserAttributedUpload = UserAttributedUpload
 
 data CharacterizationResponse a = CharacterizationResponse
   { upload :: UserAttributedUpload
-  , associatedCharacterization :: AssociatedSolutionSolutionCharacterization
+  , associatedCharacterization :: AssociatedSolutionCharacterization
   , payload :: a
   }
 
-newtype ScenarioUploadResponsePayload = ScenarioUploadResponsePayload
+data ScenarioUploadResponsePayload = ScenarioUploadResponsePayload
   { swarmGameVersion :: Sha1
+  , sTitle :: T.Text
   }
 
 newtype SolutionUploadResponsePayload = SolutionUploadResponsePayload
   { scenariohash :: Sha1
   }
 
-instance FromRow AssociatedSolutionSolutionCharacterization where
+instance FromRow AssociatedSolutionCharacterization where
   fromRow =
-    AssociatedSolutionSolutionCharacterization
+    AssociatedSolutionCharacterization
       <$> (Sha1 <$> field)
       <*> fromRow
 
@@ -89,62 +98,87 @@ instance FromRow TournamentGame where
       <*> (Sha1 <$> field)
       <*> field
       <*> (Sha1 <$> field)
+      <*> field
 
-data TokenWithExpiration = TokenWithExpiration
+instance FromRow TournamentSolution where
-  { expirationTime :: UTCTime
+  fromRow =
-  , loginToken :: Password
+    TournamentSolution
-  }
+      <$> field
+      <*> field
+      <*> fromRow
 
-type TokenRef = IORef (Maybe TokenWithExpiration)
+instance FromRow SolutionFileCharacterization where
-
+  fromRow =
-newtype Username = Username String
+    SolutionFileCharacterization
-newtype Password = Password String
+      <$> (Sha1 <$> field)
-
+      <*> fromRow
-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
 
 -- * Authentication
 
-getUserId :: Connection -> UserAlias -> IO UserId
+-- | If the username already exists, overwrite the row.
-getUserId conn userAlias = do
+insertCookie ::
-  maybeId <-
+  UserAlias ->
-    listToMaybe . fmap (UserId . fromOnly)
+  ReaderT Connection IO TL.Text
-      <$> query conn "SELECT id FROM users WHERE alias = ?;" (Only userAlias)
+insertCookie gitHubUsername = do
-  maybe insertNew return maybeId
+  conn <- ask
- where
+  liftIO $ do
-  -- Avoid GHC warning re: partiality of head
+    [Only cookieString] <-
-  queryHead = \case
+      query
-    [] -> error "Query result in getUserId should never be empty!"
-    hd : _ -> hd
-  insertNew =
-    fmap (UserId . fromOnly . queryHead)
-      $ query
         conn
-        "INSERT INTO users (alias) VALUES (?) RETURNING id;"
+        "REPLACE INTO users (alias) VALUES (?) RETURNING cookie;"
-      $ Only userAlias
+        (Only gitHubUsername)
+    return cookieString
+
+-- | If the username already exists, overwrite the row.
+insertGitHubTokens ::
+  UserAlias ->
+  ReceivedTokens ->
+  ReaderT Connection IO ()
+insertGitHubTokens gitHubUsername gitHubTokens = do
+  conn <- ask
+  currentTime <- liftIO getCurrentTime
+  let expirationOf = mkExpirationTime currentTime
+  liftIO $ do
+    execute
+      conn
+      "REPLACE INTO github_tokens (alias, github_access_token, github_access_token_expires_at, github_refresh_token, github_refresh_token_expires_at) VALUES (?, ?, ?, ?, ?);"
+      ( gitHubUsername
+      , token $ accessToken gitHubTokens
+      , expirationOf accessToken
+      , token $ refreshToken gitHubTokens
+      , expirationOf refreshToken
+      )
+    return ()
+ where
+  mkExpirationTime currTime accessor =
+    addUTCTime (fromIntegral $ expirationSeconds $ accessor gitHubTokens) currTime
+
+getUsernameFromCookie ::
+  TL.Text ->
+  ReaderT Connection IO (Maybe UserAlias)
+getUsernameFromCookie cookieText = do
+  conn <- ask
+  liftIO . fmap (fmap (UserAlias . fromOnly) . listToMaybe) $
+    query conn "SELECT alias FROM users WHERE cookie = ?;" (Only cookieText)
 
 -- * Retrieval
 
-lookupScenarioContent :: Sha1 -> ReaderT ConnectInfo IO (Maybe LBS.ByteString)
+lookupScenarioContent :: Sha1 -> ReaderT Connection IO (Maybe LBS.ByteString)
 lookupScenarioContent sha1 = do
-  connInfo <- ask
+  conn <- ask
-  liftIO . fmap (fmap fromOnly . listToMaybe) . withConnection connInfo $ \conn ->
+  liftIO . fmap (fmap fromOnly . listToMaybe) $
     query conn "SELECT content FROM scenarios WHERE content_sha1 = ?;" (Only sha1)
 
-lookupSolutionSubmission :: Sha1 -> ReaderT ConnectInfo IO (Maybe AssociatedSolutionSolutionCharacterization)
+lookupSolutionContent :: Sha1 -> ReaderT Connection IO (Maybe LBS.ByteString)
+lookupSolutionContent sha1 = do
+  conn <- ask
+  liftIO . fmap (fmap fromOnly . listToMaybe) $
+    query conn "SELECT content FROM solution_submission WHERE content_sha1 = ?;" (Only sha1)
+
+lookupSolutionSubmission :: Sha1 -> ReaderT Connection IO (Maybe AssociatedSolutionCharacterization)
 lookupSolutionSubmission contentSha1 = do
-  connInfo <- ask
+  conn <- ask
-  liftIO $ withConnection connInfo $ \conn -> runMaybeT $ do
+  liftIO $ runMaybeT $ do
     evaluationId :: Int <-
       MaybeT $
         fmap fromOnly . listToMaybe
@@ -155,36 +189,45 @@ lookupSolutionSubmission contentSha1 = do
         <$> 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 :: Sha1 -> ReaderT Connection IO (Maybe AssociatedSolutionCharacterization)
 lookupScenarioSolution scenarioSha1 = do
-  connInfo <- ask
+  conn <- ask
-  solnChar <- liftIO . fmap listToMaybe . withConnection connInfo $ \conn ->
+  solnChar <-
-    query conn "SELECT wall_time_seconds, ticks, seed, char_count, ast_size FROM evaluated_solution WHERE builtin AND scenario = ? LIMIT 1;" (Only scenarioSha1)
+    liftIO . fmap listToMaybe $
-  return $ AssociatedSolutionSolutionCharacterization scenarioSha1 <$> solnChar
+      query conn "SELECT wall_time_seconds, ticks, seed, char_count, ast_size FROM evaluated_solution WHERE builtin AND scenario = ? LIMIT 1;" (Only scenarioSha1)
+  return $ AssociatedSolutionCharacterization scenarioSha1 <$> solnChar
 
-listGames :: ReaderT ConnectInfo IO [TournamentGame]
+listGames :: ReaderT Connection IO [TournamentGame]
 listGames = do
-  connInfo <- ask
+  conn <- ask
-  liftIO $ withConnection connInfo $ \conn ->
+  liftIO $
-    query_ conn "SELECT original_filename, scenario_uploader, scenario, submission_count, swarm_git_sha1 FROM submissions;"
+    query_ conn "SELECT original_filename, scenario_uploader, scenario, submission_count, swarm_git_sha1, title FROM agg_scenario_submissions;"
+
+listSubmissions :: Sha1 -> ReaderT Connection IO GameWithSolutions
+listSubmissions scenarioSha1 = do
+  conn <- ask
+  liftIO $ do
+    [game] <- query conn "SELECT original_filename, scenario_uploader, scenario, submission_count, swarm_git_sha1, title FROM agg_scenario_submissions WHERE scenario = ?;" (Only scenarioSha1)
+    solns <- query conn "SELECT uploaded_at, solution_submitter, solution_sha1, wall_time_seconds, ticks, seed, char_count, ast_size FROM all_solution_submissions WHERE scenario = ?;" (Only scenarioSha1)
+    return $ GameWithSolutions game solns
 
 -- * Insertion
 
 insertScenario ::
   CharacterizationResponse ScenarioUploadResponsePayload ->
-  ReaderT ConnectInfo IO Sha1
+  ReaderT Connection IO Sha1
 insertScenario s = do
-  connInfo <- ask
+  conn <- ask
-  h <- liftIO $ withConnection connInfo $ \conn -> do
+  h <- liftIO $ 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;"
+        "INSERT INTO scenarios (content_sha1, content, original_filename, title, uploader, swarm_git_sha1) VALUES (?, ?, ?, ?, ?, ?) RETURNING content_sha1;"
         ( scenarioSha
         , fileContent $ fileUpload $ upload s
         , filename . fileMetadata . fileUpload $ upload s
-        , uid
+        , sTitle $ payload s
+        , uploader $ upload s
         , swarmGameVersion $ payload s
         )
     _ <- insertSolution conn True scenarioSha $ characterization $ associatedCharacterization s
@@ -196,19 +239,20 @@ insertScenario s = do
 
 insertSolutionSubmission ::
   CharacterizationResponse SolutionUploadResponsePayload ->
-  ReaderT ConnectInfo IO Sha1
+  ReaderT Connection IO Sha1
 insertSolutionSubmission (CharacterizationResponse solutionUpload s (SolutionUploadResponsePayload scenarioSha)) = do
-  connInfo <- ask
+  conn <- ask
-  liftIO $ withConnection connInfo $ \conn -> do
+  liftIO $ 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;"
+        "INSERT INTO solution_submission (uploader, content_sha1, solution_evaluation, content) VALUES (?, ?, ?, ?) RETURNING content_sha1;"
-        (uid, fileHash $ fileMetadata $ fileUpload solutionUpload, solutionEvalId)
+        ( uploader solutionUpload
+        , fileHash $ fileMetadata $ fileUpload solutionUpload
+        , solutionEvalId
+        , fileContent $ fileUpload solutionUpload
+        )
     return $ Sha1 echoedSha1
 
 insertSolution ::

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

@@ -10,6 +10,8 @@ module Swarm.Web.Tournament.Type where
 import Data.Aeson
 import Data.ByteString.Lazy qualified as LBS
 import Data.Text qualified as T
+import Data.Text.Lazy qualified as TL
+import Data.Time (UTCTime)
 import Database.SQLite.Simple.ToField
 import GHC.Generics (Generic)
 import Servant
@@ -21,7 +23,8 @@ import Swarm.Game.Tick (TickNumber (..))
 import Swarm.Game.World.Gen (Seed)
 import System.Time.Extra
 
-newtype UserAlias = UserAlias T.Text
+newtype UserAlias = UserAlias TL.Text
+  deriving (Generic, ToJSON)
 
 instance ToField UserAlias where
   toField (UserAlias x) = toField x
@@ -46,10 +49,24 @@ data TournamentGame = TournamentGame
   , scenarioHash :: Sha1
   , submissionCount :: Int
   , swarmGitSha1 :: Sha1
+  , scenarioTitle :: T.Text
   }
   deriving (Generic, ToJSON)
 
-data AssociatedSolutionSolutionCharacterization = AssociatedSolutionSolutionCharacterization
+data TournamentSolution = TournamentSolution
+  { submissionTime :: UTCTime
+  , solutionSubmitter :: T.Text
+  , submissionScore :: SolutionFileCharacterization
+  }
+  deriving (Generic, ToJSON)
+
+data GameWithSolutions = GameWithSolutions
+  { theGame :: TournamentGame
+  , theSolutions :: [TournamentSolution]
+  }
+  deriving (Generic, ToJSON)
+
+data AssociatedSolutionCharacterization = AssociatedSolutionCharacterization
   { forScenario :: Sha1
   , characterization :: SolutionCharacterization
   }

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

@@ -45,13 +45,13 @@ import System.Time.Extra
 
 newtype SolutionTimeout = SolutionTimeout Seconds
 
-data CommonValidationArgs a
+data CommonValidationArgs m a
   = CommonValidationArgs
       SolutionTimeout
-      (PersistenceArgs a)
+      (PersistenceArgs m a)
 
 validateScenarioUpload ::
-  CommonValidationArgs ScenarioUploadResponsePayload ->
+  CommonValidationArgs IO ScenarioUploadResponsePayload ->
   -- | Game version
   Sha1 ->
   IO (Either ScenarioUploadValidationFailure ScenarioCharacterization)
@@ -69,7 +69,7 @@ validateScenarioUpload (CommonValidationArgs solnTimeout persistenceArgs) gameVe
         (characterization solnMetrics)
  where
   computeMetrics file = do
-    gs <-
+    (gs, scenarioObject) <-
       withExceptT ScenarioUploadInstantiationFailure $
         gamestateFromScenarioText $
           fileContent file
@@ -81,12 +81,13 @@ validateScenarioUpload (CommonValidationArgs solnTimeout persistenceArgs) gameVe
         verifySolution solnTimeout soln gs
 
     return
-      ( AssociatedSolutionSolutionCharacterization (fileHash $ fileMetadata file) solnMetrics
+      ( AssociatedSolutionCharacterization (fileHash $ fileMetadata file) solnMetrics
-      , ScenarioUploadResponsePayload gameVersion
+      , ScenarioUploadResponsePayload gameVersion $
+          scenarioObject ^. scenarioMetadata . scenarioName
       )
 
 validateSubmittedSolution ::
-  CommonValidationArgs SolutionUploadResponsePayload ->
+  CommonValidationArgs IO SolutionUploadResponsePayload ->
   -- | Scenario lookup function
   (Sha1 -> IO (Maybe LBS.ByteString)) ->
   IO (Either SolutionSubmissionFailure SolutionFileCharacterization)
@@ -138,15 +139,16 @@ validateSubmittedSolution (CommonValidationArgs solnTimeout persistenceArgs) sce
                 <$> scenarioLookupFunc scenarioSha1
             )
 
-      withExceptT RetrievedInstantiationFailure $
+      fmap fst $
-        gamestateFromScenarioText scenarioContent
+        withExceptT RetrievedInstantiationFailure $
+          gamestateFromScenarioText scenarioContent
 
     solnMetrics <-
       withExceptT SubmittedSolutionEvaluationFailure $
         verifySolution solnTimeout soln gs
 
     return
-      ( AssociatedSolutionSolutionCharacterization scenarioSha1 solnMetrics
+      ( AssociatedSolutionCharacterization scenarioSha1 solnMetrics
       , SolutionUploadResponsePayload scenarioSha1
       )
 
@@ -176,7 +178,7 @@ initScenarioObject scenarioInputs content = do
 
 gamestateFromScenarioText ::
   LBS.ByteString ->
-  ExceptT ScenarioInstantiationFailure IO GameState
+  ExceptT ScenarioInstantiationFailure IO (GameState, Scenario)
 gamestateFromScenarioText content = do
   gsc <-
     withExceptT (ScenarioEnvironmentFailure . ContextInitializationFailure)
@@ -186,7 +188,8 @@ gamestateFromScenarioText content = do
 
   let scenarioInputs = gsiScenarioInputs $ initState gsc
   scenarioObject <- initScenarioObject scenarioInputs content
-  liftIO $ scenarioToGameState scenarioObject emptyLaunchParams gsc
+  gs <- liftIO $ scenarioToGameState scenarioObject emptyLaunchParams gsc
+  return (gs, scenarioObject)
 
 verifySolution ::
   SolutionTimeout ->

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

@@ -18,11 +18,11 @@ import Swarm.Web.Tournament.Database.Query
 import Swarm.Web.Tournament.Type
 import Swarm.Web.Tournament.Validate.FailureMode
 
-data PersistenceArgs a
+data PersistenceArgs m a
   = PersistenceArgs
       UserAlias
       (MultipartData Mem)
-      (ScenarioPersistence a)
+      (ScenarioPersistence m a)
 
 obtainFileUpload ::
   MultipartData Mem ->
@@ -45,10 +45,10 @@ obtainFileUpload multipartData =
   maybeNonemptyFiles = NE.nonEmpty $ files multipartData
 
 withFileCache ::
-  PersistenceArgs a ->
+  PersistenceArgs IO a ->
   (GenericUploadFailure -> e) ->
-  (FileUpload -> ExceptT e IO (AssociatedSolutionSolutionCharacterization, a)) ->
+  (FileUpload -> ExceptT e IO (AssociatedSolutionCharacterization, a)) ->
-  ExceptT e IO (FileMetadata, AssociatedSolutionSolutionCharacterization)
+  ExceptT e IO (FileMetadata, AssociatedSolutionCharacterization)
 withFileCache (PersistenceArgs userAlias multipartData persistenceFunctions) errorWrapper cacheStoreFunction = do
   file <- withExceptT errorWrapper $ obtainFileUpload multipartData
   maybePreexisting <-

swarm.cabal

@@ -466,6 +466,7 @@ library swarm-tournament
   visibility: public
   -- cabal-gild: discover src/swarm-tournament
   exposed-modules:
+    Swarm.Web.Auth
     Swarm.Web.Tournament
     Swarm.Web.Tournament.Database.Query
     Swarm.Web.Tournament.Type
@@ -482,8 +483,12 @@ library swarm-tournament
     bytestring,
     commonmark,
     containers,
+    cookie,
+    exceptions,
     extra,
     fused-effects,
+    http-client,
+    http-client-tls >=0.3.6.3 && <0.3.7,
     http-types,
     lens,
     mtl,
@@ -494,6 +499,7 @@ library swarm-tournament
     text,
     time,
     transformers,
+    utf8-string,
     wai >=3.2 && <3.3,
     wai-app-static >=3.1.8 && <3.2,
     wai-extra,
@@ -766,8 +772,10 @@ executable swarm-host-tournament
   build-depends:
     base,
     optparse-applicative >=0.16 && <0.19,
+    sqlite-simple,
     transformers,
     warp,
+    yaml,
 
   build-depends:
     swarm:swarm-engine,

test/tournament-host/Main.hs

@@ -19,6 +19,7 @@ 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 Swarm.Web.Tournament.Type (UserAlias (..))
 import Test.Tasty (defaultMain, testGroup)
 import Test.Tasty.HUnit (Assertion, assertEqual, testCase)
 
@@ -37,19 +38,31 @@ main = do
     ScenarioPersistence
       { lookupCache = const $ return Nothing
       , storeCache = const $ return $ Sha1 "bogus"
+      , getContent = const $ return Nothing
       }
 
   mkPersistenceLayer scenariosMap =
     PersistenceLayer
-      { lookupScenarioFileContent = \x -> return $ content <$> NEM.lookup x scenariosMap
+      { scenarioStorage =
-      , scenarioStorage = noPersistence
+          noPersistence
+            { getContent = return . fmap content . (`NEM.lookup` scenariosMap)
+            }
       , solutionStorage = noPersistence
+      , authenticationStorage =
+          AuthenticationStorage
+            { usernameFromCookie = const $ return $ Just fakeUser
+            , cookieFromUsername = const $ return "fake-cookie-value"
+            }
       }
 
+  fakeUser = UserAlias "test-user"
+
   mkAppData scenariosMap =
     Tournament.AppData
       { Tournament.swarmGameGitVersion = Sha1 "abcdef"
+      , Tournament.gitHubCredentials = Tournament.GitHubCredentials "" ""
       , Tournament.persistence = mkPersistenceLayer scenariosMap
+      , Tournament.developmentMode = Tournament.LocalDevelopment fakeUser
       }
 
 type LocalFileLookup = NEMap Sha1 FilePathAndContent
@@ -72,12 +85,12 @@ testScenarioUpload :: LocalFileLookup -> Tournament.AppData -> Assertion
 testScenarioUpload fileLookup appData =
   mapM_ f testScenarioPaths
  where
-  f x = uploadForm appData "/upload/scenario" [partFileSource "file" x]
+  f x = uploadForm appData "/api/private/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
+  uploadForm appData "/api/private/upload/solution" form
  where
   solutionFilePath = "data/scenarios/Challenges/_arbitrage/solution.sw"
   Sha1 scenarioSha1 = NE.head $ NEM.keys fileLookup
@@ -92,10 +105,27 @@ 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
+    let baseUrl = "http://localhost:" ++ show p
-    assertEqual "Server response should be 200" ok200 $ responseStatus resp
+    reqLogin <- parseRequest $ baseUrl ++ "/api/private/login/local"
+    respLogin <- httpLbs reqLogin manager
+
+    let apiUrl = baseUrl ++ urlPath
+    req <- parseRequest apiUrl
+    resp <-
+      flip httpLbs manager
+        =<< formDataBody form (req {cookieJar = Just $ responseCookieJar respLogin})
+
+    let assertionMsg =
+          unwords
+            [ "Server response from"
+            , apiUrl
+            , "should be 200;"
+            , "'respLogin' was:"
+            , show respLogin
+            , "and 'resp' was:"
+            , show resp
+            ]
+    assertEqual assertionMsg ok200 $ responseStatus resp
  where
-  tournamentApp = Tournament.app appData
+  tournamentApp = Tournament.app True appData

tournament/schema/swarm-sqlite-schema.sql

@@ -1,20 +1,33 @@
 BEGIN TRANSACTION;
+
 CREATE TABLE IF NOT EXISTS "users" (
-	"id"	INTEGER NOT NULL UNIQUE,
 	"alias"	TEXT NOT NULL,
-	"created_at"	DATETIME NOT NULL DEFAULT CURRENT_TIMESTAMP,
+	"cookie" TEXT NOT NULL UNIQUE DEFAULT (lower(hex(randomblob(16)))),
-	PRIMARY KEY("id" AUTOINCREMENT)
+	PRIMARY KEY("alias")
 );
+
+CREATE TABLE IF NOT EXISTS "github_tokens" (
+	"alias"	TEXT NOT NULL,
+	"github_access_token"	TEXT NOT NULL,
+	"github_access_token_expires_at"	DATETIME NOT NULL,
+	"github_refresh_token"	TEXT NOT NULL,
+	"github_refresh_token_expires_at"	DATETIME NOT NULL,
+	PRIMARY KEY("alias"),
+	FOREIGN KEY(alias) REFERENCES users(alias)
+);
+
 CREATE TABLE IF NOT EXISTS "scenarios" (
 	"content_sha1"	TEXT NOT NULL UNIQUE,
-	"uploader"	INTEGER NOT NULL,
+	"uploader"	TEXT NOT NULL,
 	"original_filename"	TEXT,
+	"title"	TEXT,
 	"swarm_git_sha1"	TEXT,
 	"uploaded_at"	DATETIME NOT NULL DEFAULT CURRENT_TIMESTAMP,
 	"content"	TEXT NOT NULL,
 	PRIMARY KEY("content_sha1"),
-	FOREIGN KEY(uploader) REFERENCES users(id)
+	FOREIGN KEY(uploader) REFERENCES users(alias)
 );
+
 CREATE TABLE IF NOT EXISTS "evaluated_solution" (
 	"id"	INTEGER NOT NULL UNIQUE,
 	"evaluated_at"	DATETIME NOT NULL DEFAULT CURRENT_TIMESTAMP,
@@ -28,27 +41,47 @@ CREATE TABLE IF NOT EXISTS "evaluated_solution" (
 	PRIMARY KEY("id" AUTOINCREMENT),
 	FOREIGN KEY(scenario) REFERENCES scenarios(content_sha1)
 );
+
 CREATE TABLE IF NOT EXISTS "solution_submission" (
 	"content_sha1"	TEXT NOT NULL,
-	"uploader"	INTEGER NOT NULL,
+	"uploader"	TEXT NOT NULL,
 	"uploaded_at"	DATETIME NOT NULL DEFAULT CURRENT_TIMESTAMP,
 	"solution_evaluation"	INTEGER,
+	"content"	TEXT NOT NULL,
 	PRIMARY KEY("content_sha1"),
+	FOREIGN KEY(uploader) REFERENCES users(alias),
 	FOREIGN KEY(solution_evaluation) REFERENCES evaluated_solution(id)
 );
 
-CREATE VIEW submissions AS
+CREATE VIEW agg_scenario_submissions AS
  SELECT scenarios.original_filename,
     scenarios.content_sha1 AS scenario,
     scenarios.uploaded_at AS scenario_uploaded_at,
     COALESCE(foo.submission_count, 0) AS submission_count,
-    users.alias AS scenario_uploader,
+    scenarios.uploader AS scenario_uploader,
-    scenarios.swarm_git_sha1
+    scenarios.swarm_git_sha1,
+	scenarios.title
    FROM ((scenarios
      LEFT JOIN ( SELECT evaluated_solution.scenario,
             count(*) AS submission_count
            FROM evaluated_solution
           WHERE (NOT evaluated_solution.builtin)
           GROUP BY evaluated_solution.scenario) foo ON (scenarios.content_sha1 = foo.scenario))
-     JOIN users ON (scenarios.uploader = users.id));
+     );
+
+CREATE VIEW all_solution_submissions AS
+ SELECT
+	evaluated_solution.scenario,
+    solution_submission.uploaded_at,
+	evaluated_solution.seed,
+	evaluated_solution.wall_time_seconds,
+	evaluated_solution.ticks,
+	evaluated_solution.char_count,
+	evaluated_solution.ast_size,
+    solution_submission.uploader AS solution_submitter,
+    solution_submission.content_sha1 AS solution_sha1
+   FROM solution_submission
+	 JOIN evaluated_solution ON evaluated_solution.id = solution_submission.solution_evaluation
+   WHERE NOT evaluated_solution.builtin;
+
 COMMIT;

tournament/scripts/demo/server-native.sh

@@ -7,7 +7,7 @@ cd $(git rev-parse --show-toplevel)
 GIT_HASH=$(git rev-parse HEAD)
 
 cabal run -j -O0 swarm:swarm-host-tournament -- \
-    --native-dev \
     --port 8080 \
     --version $GIT_HASH \
+    --local \
     "$@"

tournament/scripts/deploy/redeploy-web-files.sh

@@ -3,4 +3,4 @@
 cd $(git rev-parse --show-toplevel)
 
 scp -r tournament/web lightsail:tournament
-scp -r data lightsail:.local/share/swarm
+rsync -r data lightsail:.local/share/swarm

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

@@ -12,4 +12,12 @@ BUILD_TARGET=swarm:swarm-host-tournament
 CABAL_ARGS="-j -O0 --enable-executable-static $BUILD_TARGET"
 
 cabal build $CABAL_ARGS
-cp $(cabal list-bin $CABAL_ARGS) $1
+#cp $(cabal list-bin $CABAL_ARGS) $1
+BIN_PATH=$(cabal list-bin $CABAL_ARGS)
+strip $BIN_PATH
+
+BIN_NAME=swarm-host-tournament
+TEMP_UPLOAD_BIN_NAME=$BIN_NAME.new
+
+rsync -P $BIN_PATH lightsail:$TEMP_UPLOAD_BIN_NAME
+ssh lightsail -C "mv $TEMP_UPLOAD_BIN_NAME $BIN_NAME && sudo systemctl restart swarm-tournament"

tournament/web/list-games.html

@@ -1,7 +1,7 @@
 <!doctype html>
 <html>
   <head>
-    <title>Swarm tournament games</title>
+    <title>Uploaded scenarios</title>
 
     <link rel="stylesheet" href="style/tablesort.css"/>
     <link rel="stylesheet" href="style/list-games.css"/>
@@ -16,20 +16,27 @@
     </style>
 
     <script src="https://cdnjs.cloudflare.com/ajax/libs/tablesort/5.1.0/tablesort.min.js"></script>
+    <script src="script/common.js"></script>
     <script src="script/list-games.js"></script>
 
     <script>
       window.onload=()=>{
+
+        getLoginStatus();
+
         const tableElement = document.querySelector("table");
         doFetch(tableElement);
       }
     </script>
   </head>
   <body>
+    <div id="login-info-container"></div>
+    <h1>Uploaded scenarios</h1>
     <table id="my-table">
         <thead>
           <tr data-sort-method="none">
-            <th>Filename</th>
+            <th>Title</th>
+            <th>File</th>
             <th>Uploader</th>
             <th>Soln. submissions</th>
             <th>Swarm version</th>
@@ -42,5 +49,12 @@
       <div id="spinner-container">
         <span id="spinner" class="lds-dual-ring"></span>
       </div>
+
+      <br/>
+      <h2>Upload new scenario</h2>
+      <form action="/api/private/upload/scenario" method="POST" enctype="multipart/form-data">
+        <input type="file" name="scenario-filename"/>
+        <input type="submit"/>
+      </form>
   </body>
-</html>
+</html>

tournament/web/list-solutions.html

@@ -0,0 +1,72 @@
+<!doctype html>
+<html>
+  <head>
+    <title>Solution submissions</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/common.js"></script>
+    <script src="script/list-solutions.js"></script>
+
+    <script>
+      window.onload=()=>{
+
+        getLoginStatus();
+
+        const queryString = window.location.search;
+        const urlParams = new URLSearchParams(queryString);
+        const scenarioHash = urlParams.get('scenario')
+        document.getElementById('scenario-field').value=scenarioHash;
+
+        const tableElement = document.querySelector("table");
+        doFetch(tableElement, scenarioHash);
+      }
+    </script>
+  </head>
+  <body>
+    <div id="login-info-container"></div>
+    [<a href="/list-games.html">Back to scenarios</a>]
+    <h1 id="main-header">Scenario info</h1>
+    
+    <h2>Solution submissions</h2>
+    <table id="my-table">
+        <thead>
+          <tr data-sort-method="none">
+            <th>Uploader</th>
+            <th>Submitted at</th>
+            <th>Seed</th>
+            <th>Source length</th>
+            <th>AST Size</th>
+            <th>Ticks elapsed</th>
+            <th>Evaluation time</th>
+            <th>Download</th>
+          </tr>
+        </thead>
+        <tbody id="my-table-body">
+        </tbody>
+      </table>
+
+      <div id="spinner-container">
+        <span id="spinner" class="lds-dual-ring"></span>
+      </div>
+
+      <br/>
+      <h2>Upload solution</h2>
+      <form action="/api/private/upload/solution" method="POST" enctype="multipart/form-data">
+        <input type="file" name="solution-filename"/>
+        <input type="hidden" name="scenario" id="scenario-field"/>
+        <input type="submit"/>
+      </form>
+  </body>
+</html>

tournament/web/script/common.js

@@ -0,0 +1,68 @@
+function wrapWithElement(elName, content) {
+    const e = document.createElement(elName);
+    e.appendChild(content);
+    return e;
+}
+
+function mkLink(text, url) {
+    const anchor = document.createElement("a");
+    anchor.href = url
+    anchor.textContent = text;
+    return anchor;
+}
+
+function regularSpan(textVal) {
+    const span = document.createElement("span");
+    span.appendChild(document.createTextNode(textVal));
+    return span;
+}
+
+function renderGitHash(hashVal) {
+    const span = document.createElement("code");
+    span.appendChild(document.createTextNode(hashVal.substring(0,7)));
+    span.setAttribute('title', hashVal);
+    return span;
+}
+
+function getLoginStatus(myTable) {
+    
+    const loginInfoBox = document.getElementById('login-info-container');
+    
+    fetch("api/private/login/status")
+    .then((response) => {
+        if (response.ok) {
+            response.json().then(data => {
+                const msg = "Logged in as " + data;
+                loginInfoBox.appendChild(document.createTextNode(msg));
+
+                const a = document.createElement("a");
+                a.setAttribute('href', "api/private/login/logout");
+                a.appendChild(document.createTextNode("Logout"));
+                
+                loginInfoBox.appendChild(document.createElement("br"));
+                loginInfoBox.appendChild(a);
+            });
+        } else {
+            var login_message = "Unknown login problem";
+
+            if (response.status == 401) {
+                login_message = "Please log in";
+            } else if (response.status == 403) {
+                login_message = "Log in again";
+            }
+        
+            response.json().then(data => {
+                
+                const a = document.createElement("a");
+                a.setAttribute('href', data.loginLink);
+
+                a.appendChild(document.createTextNode(login_message));
+                
+                loginInfoBox.appendChild(a);
+                loginInfoBox.appendChild(document.createElement("br"));
+                loginInfoBox.appendChild(document.createTextNode("(" + data.problemMessage + ")"));
+            });
+
+        }
+    });
+}

tournament/web/script/list-games.js

@@ -1,31 +1,15 @@
-
-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 = [
+            regularSpan(entry.scenarioTitle),
             mkLink(entry.originalFilename, "scenario/" + entry.scenarioHash + "/fetch"),
+            mkLink(entry.scenarioUploader, "https://github.com/" + entry.scenarioUploader),
+            mkLink("View (" + entry.submissionCount + ")", "list-solutions.html?scenario=" + entry.scenarioHash),
+            renderGitHash(entry.swarmGitSha1),
         ];
 
-        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);
@@ -39,24 +23,24 @@ function insertTableRows(myTableBody, entries) {
 function doFetch(myTable) {
     document.getElementById("spinner-container").style.display = 'flex';
     
-    fetch("games")
+    fetch("list/games")
     .then((response) => {
-        if (!response.ok) {
+        if (response.ok) {
-            throw new Error(`HTTP error, status = ${response.status}`);
+
+            const data = response.json().then(data => {
+
+                const myTableBody = myTable.querySelector("tbody");
+                insertTableRows(myTableBody, data);
+                // Documentation: http://tristen.ca/tablesort/demo/
+                new Tablesort(document.getElementById('my-table'));
+            });
+
+        } else {
+            const p = document.createElement("p");
+            p.appendChild(document.createTextNode(`Error: HTTP error, status = ${response.status}`));
+            document.body.insertBefore(p, myTable);
         }
-        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/script/list-solutions.js

@@ -0,0 +1,77 @@
+function insertTableRows(myTableBody, entries) {
+    for (const entry of entries) {
+        const rowItem = document.createElement("tr");
+        const cellVals = [
+            mkLink(entry.solutionSubmitter, "https://github.com/" + entry.solutionSubmitter),
+            regularSpan(entry.submissionTime),
+            regularSpan(entry.submissionScore.solutionCharacterization.scenarioSeed),
+            regularSpan(entry.submissionScore.solutionCharacterization.solutionCodeMetrics.sourceTextLength),
+            regularSpan(entry.submissionScore.solutionCharacterization.solutionCodeMetrics.astSize),
+            regularSpan(entry.submissionScore.solutionCharacterization.solutionTicks),
+            regularSpan(entry.submissionScore.solutionCharacterization.solutionWallTime.toFixed(2) + "s"),
+            mkLink("Download", "solution/" + entry.submissionScore.solutionHash + "/fetch"),
+        ];
+
+        for (const val of cellVals) {
+            const cellElement = document.createElement("td");
+            cellElement.appendChild(val);
+            rowItem.append(cellElement);
+        }
+
+        myTableBody.appendChild(rowItem);
+    }
+}
+
+function mkDefinitionEntryElements(title, element) {
+    return [
+        wrapWithElement("dt", document.createTextNode(title)),
+        wrapWithElement("dd", element),
+    ];
+}
+
+function renderGameInfoBox(entry) {
+
+    const dl = document.createElement("dl");
+    const pairs = [
+        mkDefinitionEntryElements("Title:", regularSpan(entry.scenarioTitle)),
+        mkDefinitionEntryElements("File:", mkLink(entry.originalFilename, "scenario/" + entry.scenarioHash + "/fetch")),
+        mkDefinitionEntryElements("Uploader:", regularSpan(entry.scenarioUploader)),
+        mkDefinitionEntryElements("Swarm version:", renderGitHash(entry.swarmGitSha1)),
+    ];
+
+    for (const e of pairs.flat()) {
+        dl.append(e);
+    }
+
+    return dl;
+}
+
+function doFetch(myTable, gameSha1) {
+    document.getElementById("spinner-container").style.display = 'flex';
+    
+    fetch("list/game/" + gameSha1)
+    .then((response) => {
+        if (response.ok) {
+            response.json().then(data => {
+                const infoBox = renderGameInfoBox(data.theGame);
+
+                const mainHeaderElement = document.getElementById('main-header');
+
+                mainHeaderElement.parentNode.insertBefore(infoBox, mainHeaderElement.nextSibling);
+
+                const tableElement = document.getElementById('my-table');
+                const myTableBody = myTable.querySelector("tbody");
+                insertTableRows(myTableBody, data.theSolutions);
+                // Documentation: http://tristen.ca/tablesort/demo/
+                new Tablesort(tableElement);
+            });
+
+        } else {
+            const p = document.createElement("p");
+            p.appendChild(document.createTextNode(`Error: HTTP error, status = ${response.status}`));
+            document.body.insertBefore(p, myTable);
+        }
+
+        document.getElementById("spinner-container").style.display = 'none';
+    });
+}