mirror of
https://github.com/swarm-game/swarm.git
synced 2024-08-17 02:20:31 +03:00
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?)
This commit is contained in:
parent
f5ecd3fa53
commit
d749c5e473
@ -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]}
|
||||
|
99
app/tournament/Main.hs
Normal file
99
app/tournament/Main.hs
Normal file
@ -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
|
10
scripts/build-game.sh
Executable file
10
scripts/build-game.sh
Executable file
@ -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
|
@ -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 -- "$@"
|
||||
|
274
src/swarm-tournament/Swarm/Web/Tournament.hs
Normal file
274
src/swarm-tournament/Swarm/Web/Tournament.hs
Normal file
@ -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"
|
||||
]
|
||||
)
|
||||
]
|
317
src/swarm-tournament/Swarm/Web/Tournament/Database/Query.hs
Normal file
317
src/swarm-tournament/Swarm/Web/Tournament/Database/Query.hs
Normal file
@ -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
|
||||
)
|
84
src/swarm-tournament/Swarm/Web/Tournament/Type.hs
Normal file
84
src/swarm-tournament/Swarm/Web/Tournament/Type.hs
Normal file
@ -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
|
257
src/swarm-tournament/Swarm/Web/Tournament/Validate.hs
Normal file
257
src/swarm-tournament/Swarm/Web/Tournament/Validate.hs
Normal file
@ -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
|
@ -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
|
||||
]
|
73
src/swarm-tournament/Swarm/Web/Tournament/Validate/Upload.hs
Normal file
73
src/swarm-tournament/Swarm/Web/Tournament/Validate/Upload.hs
Normal file
@ -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
|
97
swarm.cabal
97
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
|
||||
|
@ -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 =
|
||||
|
103
test/tournament-host/Main.hs
Normal file
103
test/tournament-host/Main.hs
Normal file
@ -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
|
267
tournament/schema/schema-local.sql
Normal file
267
tournament/schema/schema-local.sql
Normal file
@ -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
|
||||
--
|
||||
|
5
tournament/scripts/database/dump-local-schema.sh
Executable file
5
tournament/scripts/database/dump-local-schema.sh
Executable file
@ -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
|
8
tournament/scripts/database/recreate-local-database.sh
Executable file
8
tournament/scripts/database/recreate-local-database.sh
Executable file
@ -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
|
27
tournament/scripts/demo/README.md
Normal file
27
tournament/scripts/demo/README.md
Normal file
@ -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
|
||||
```
|
27
tournament/scripts/demo/client/fetch.sh
Executable file
27
tournament/scripts/demo/client/fetch.sh
Executable file
@ -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
|
35
tournament/scripts/demo/client/submit.sh
Executable file
35
tournament/scripts/demo/client/submit.sh
Executable file
@ -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
|
8
tournament/scripts/demo/client/test-cases/local/good-submit.sh
Executable file
8
tournament/scripts/demo/client/test-cases/local/good-submit.sh
Executable file
@ -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
|
@ -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
|
14
tournament/scripts/demo/server-docker.sh
Executable file
14
tournament/scripts/demo/server-docker.sh
Executable file
@ -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
|
14
tournament/scripts/demo/server-native.sh
Executable file
14
tournament/scripts/demo/server-native.sh
Executable file
@ -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 \
|
||||
"$@"
|
101
tournament/scripts/docker/Dockerfile
Normal file
101
tournament/scripts/docker/Dockerfile
Normal file
@ -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)
|
5
tournament/scripts/docker/aws-login.sh
Executable file
5
tournament/scripts/docker/aws-login.sh
Executable file
@ -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
|
11
tournament/scripts/docker/build-image.sh
Executable file
11
tournament/scripts/docker/build-image.sh
Executable file
@ -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
|
16
tournament/scripts/docker/build-server-executable.sh
Executable file
16
tournament/scripts/docker/build-server-executable.sh
Executable file
@ -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
|
6
tournament/scripts/docker/docker-prereqs.sh
Normal file
6
tournament/scripts/docker/docker-prereqs.sh
Normal file
@ -0,0 +1,6 @@
|
||||
#!/bin/bash
|
||||
|
||||
# Run this script on your host machine to prepare
|
||||
# for development with Docker
|
||||
|
||||
sudo apt install docker.io
|
6
tournament/scripts/docker/local-docker-shell.sh
Executable file
6
tournament/scripts/docker/local-docker-shell.sh
Executable file
@ -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
|
1
tournament/scripts/docker/local-pg-credentials.env
Normal file
1
tournament/scripts/docker/local-pg-credentials.env
Normal file
@ -0,0 +1 @@
|
||||
LOCAL_PGPASS=irrelevantpassword
|
16
tournament/scripts/docker/redeploy-image.sh
Executable file
16
tournament/scripts/docker/redeploy-image.sh
Executable file
@ -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
|
BIN
tournament/web/favicon.ico
Normal file
BIN
tournament/web/favicon.ico
Normal file
Binary file not shown.
After Width: | Height: | Size: 7.6 KiB |
11
tournament/web/index.html
Normal file
11
tournament/web/index.html
Normal file
@ -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>
|
46
tournament/web/list-games.html
Normal file
46
tournament/web/list-games.html
Normal file
@ -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>
|
62
tournament/web/script/list-games.js
Normal file
62
tournament/web/script/list-games.js
Normal file
@ -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';
|
||||
});
|
||||
}
|
34
tournament/web/style/list-games.css
Normal file
34
tournament/web/style/list-games.css
Normal file
@ -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;
|
||||
}
|
29
tournament/web/style/spinner.css
Normal file
29
tournament/web/style/spinner.css
Normal file
@ -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);
|
||||
}
|
||||
}
|
48
tournament/web/style/tablesort.css
Normal file
48
tournament/web/style/tablesort.css
Normal file
@ -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;
|
||||
}
|
Loading…
Reference in New Issue
Block a user