mirror of
https://github.com/swarm-game/swarm.git
synced 2024-12-13 05:10:31 +03:00
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
This commit is contained in:
Karl Ostmo
GitHub
parent
e071252d72
commit
82e8ac95ad
@ -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
|
||||
parseNativeDev =
|
||||
switch
|
||||
(long "native-dev" <> help "Running locally outside of a Docker container for development")
|
||||
parseRunningLocally :: Parser DeploymentEnvironment
|
||||
parseRunningLocally =
|
||||
flag
|
||||
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
|
||||
, storeCache = withConnInfo insertScenario
|
||||
{ lookupCache = withConn lookupScenarioSolution
|
||||
, storeCache = withConn insertScenario
|
||||
, getContent = withConn lookupScenarioContent
|
||||
}
|
||||
, solutionStorage =
|
||||
ScenarioPersistence
|
||||
{ lookupCache = withConnInfo lookupSolutionSubmission
|
||||
, storeCache = withConnInfo insertSolutionSubmission
|
||||
{ lookupCache = withConn lookupSolutionSubmission
|
||||
, storeCache = withConn insertSolutionSubmission
|
||||
, getContent = withConn lookupSolutionContent
|
||||
}
|
||||
, authenticationStorage =
|
||||
AuthenticationStorage
|
||||
{ usernameFromCookie = withConn getUsernameFromCookie
|
||||
, cookieFromUsername = withConn insertCookie
|
||||
}
|
||||
}
|
||||
where
|
||||
withConnInfo f x =
|
||||
runReaderT (f x) databaseFilename
|
||||
withConn f x =
|
||||
withConnection databaseFilename $ \conn -> do
|
||||
execute_ conn "PRAGMA foreign_keys = ON;"
|
||||
runReaderT (f x) conn
|
||||
|
||||
@ -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
|
||||
|
||||
130
src/swarm-tournament/Swarm/Web/Auth.hs
Normal file
130
src/swarm-tournament/Swarm/Web/Auth.hs
Normal file
@ -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
|
||||
@ -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 Network.Wai (responseLBS)
|
||||
import Network.Wai.Application.Static (defaultFileServerSettings, ssIndices)
|
||||
import Database.SQLite.Simple (withConnection)
|
||||
import GHC.Generics (Generic)
|
||||
import Network.HTTP.Client qualified as HC
|
||||
import Network.HTTP.Client.TLS (tlsManagerSettings)
|
||||
import Network.HTTP.Types (hCookie, ok200, renderSimpleQuery)
|
||||
import Network.Wai (Request, requestHeaders, responseLBS)
|
||||
import Network.Wai.Application.Static (defaultFileServerSettings)
|
||||
import Network.Wai.Handler.Warp qualified as Warp
|
||||
import Network.Wai.Parse (
|
||||
defaultParseRequestBodyOptions,
|
||||
@ -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 Swarm.Game.Scenario.Scoring.CodeSize (ScenarioCodeMetrics (..))
|
||||
import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler)
|
||||
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)
|
||||
|
||||
placeholderAlias :: UserAlias
|
||||
placeholderAlias = UserAlias "Karl"
|
||||
import Web.Cookie
|
||||
|
||||
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
|
||||
:<|> "upload" :> "solution" :> MultipartForm Mem (MultipartData Mem) :> Post '[JSON] SolutionFileCharacterization
|
||||
"api" :> "private" :> "upload" :> "scenario" :> Header "Referer" TL.Text :> AuthProtect "cookie-auth" :> MultipartForm Mem (MultipartData Mem) :> Verb 'POST 303 '[JSON] (Headers '[Header "Location" TL.Text] ScenarioCharacterization)
|
||||
:<|> "api" :> "private" :> "upload" :> "solution" :> Header "Referer" TL.Text :> AuthProtect "cookie-auth" :> MultipartForm Mem (MultipartData Mem) :> Verb 'POST 303 '[JSON] (Headers '[Header "Location" TL.Text] SolutionFileCharacterization)
|
||||
:<|> "scenario" :> Capture "sha1" Sha1 :> "metadata" :> Get '[JSON] ScenarioMetadata
|
||||
:<|> "scenario" :> Capture "sha1" Sha1 :> "fetch" :> Get '[PlainText] TL.Text
|
||||
:<|> "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
|
||||
:<|> "solution" :> Capture "sha1" Sha1 :> "fetch" :> Get '[PlainText] TL.Text
|
||||
:<|> "list" :> "games" :> Get '[JSON] [TournamentGame]
|
||||
:<|> "list" :> "game" :> Capture "sha1" Sha1 :> Get '[JSON] GameWithSolutions
|
||||
:<|> "api" :> "private" :> "login" :> "status" :> AuthProtect "cookie-auth" :> Get '[JSON] UserAlias
|
||||
:<|> "github-auth-callback" :> QueryParam "code" TokenExchangeCode :> Verb 'GET 303 '[JSON] LoginType
|
||||
:<|> "api" :> "private" :> "login" :> "local" :> Header "Referer" TL.Text :> Verb 'GET 303 '[JSON] LoginType
|
||||
:<|> "api" :> "private" :> "login" :> "logout" :> Header "Referer" TL.Text :> Verb 'GET 303 '[JSON] LoginType
|
||||
|
||||
mkApp :: AppData -> Servant.Server TournamentAPI
|
||||
mkApp appData =
|
||||
@ -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
|
||||
uploadScenario (AppData gameVersion persistenceLayer) multipartData =
|
||||
Handler . withExceptT toServantError . ExceptT $
|
||||
type ToplevelAPI =
|
||||
TournamentAPI
|
||||
:<|> "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 (AppData _ persistenceLayer) multipartData =
|
||||
Handler . withExceptT toServantError . ExceptT $
|
||||
uploadSolution ::
|
||||
AppData ->
|
||||
Maybe TL.Text ->
|
||||
UserAlias ->
|
||||
MultipartData Mem ->
|
||||
Handler (Headers '[Header "Location" TL.Text] SolutionFileCharacterization)
|
||||
uploadSolution (AppData _ _ persistenceLayer _) maybeRefererUrl userName multipartData =
|
||||
Handler . fmap addH . withExceptT toServantError . ExceptT $
|
||||
validateSubmittedSolution
|
||||
args
|
||||
(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 $
|
||||
liftIO $
|
||||
runReaderT listGames databaseFilename
|
||||
Handler . liftIO . withConnection databaseFilename $ runReaderT listGames
|
||||
|
||||
listSolutions :: Sha1 -> Handler GameWithSolutions
|
||||
listSolutions sha1 =
|
||||
Handler . liftIO . withConnection databaseFilename . runReaderT $ listSubmissions sha1
|
||||
|
||||
doGithubCallback ::
|
||||
AuthenticationStorage IO ->
|
||||
GitHubCredentials ->
|
||||
Maybe TokenExchangeCode ->
|
||||
LoginHandler
|
||||
doGithubCallback authStorage creds maybeCode = do
|
||||
c <- maybe (fail "Missing 'code' parameter") return maybeCode
|
||||
|
||||
manager <- liftIO $ HC.newManager tlsManagerSettings
|
||||
receivedTokens <- exchangeCode manager creds c
|
||||
|
||||
let aToken = token $ accessToken receivedTokens
|
||||
userInfo <- fetchAuthenticatedUser manager aToken
|
||||
let user = UserAlias $ login userInfo
|
||||
x <- doLoginResponse authStorage defaultRedirectPage user
|
||||
liftIO . withConnection databaseFilename . runReaderT $ do
|
||||
insertGitHubTokens user receivedTokens
|
||||
return x
|
||||
|
||||
doLocalDevelopmentLogin ::
|
||||
AuthenticationStorage IO ->
|
||||
DeploymentEnvironment ->
|
||||
Maybe TL.Text ->
|
||||
LoginHandler
|
||||
doLocalDevelopmentLogin authStorage envType maybeRefererUrl =
|
||||
case envType of
|
||||
ProdDeployment -> error "Login bypass not available in production"
|
||||
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 appData = Servant.serveWithContext api context server
|
||||
app :: Bool -> AppData -> Application
|
||||
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 =
|
||||
server :: Bool -> Server ToplevelAPI
|
||||
server fakeFileserverForUnitTest =
|
||||
mkApp appData
|
||||
:<|> Tagged serveDocs
|
||||
:<|> serveDirectoryWith
|
||||
(defaultFileServerSettings "tournament/web")
|
||||
{ ssIndices = [unsafeToPiece "index.html"]
|
||||
}
|
||||
:<|> fileserver
|
||||
where
|
||||
fileserver =
|
||||
if fakeFileserverForUnitTest
|
||||
then -- This is required because the data only files available to
|
||||
-- the testing environment are included in the cabal file
|
||||
-- in the "data-files" clause.
|
||||
-- However, since that clause is global to the package,
|
||||
-- we choose not to include the tournament server's web
|
||||
-- files there.
|
||||
-- Instead, we manually stub the paths that are used as redirects
|
||||
-- so that the web API invocation does not 404 when looking for them.
|
||||
|
||||
serveDirectoryEmbedded
|
||||
[ (TL.unpack defaultRedirectPage, "Hello World!")
|
||||
, (TL.unpack defaultSolutionSubmissionRedirectPage, "Hello World!")
|
||||
]
|
||||
else
|
||||
serveDirectoryWith
|
||||
(defaultFileServerSettings "tournament/web")
|
||||
|
||||
serveDocs _ resp =
|
||||
resp $ responseLBS ok200 [plain] swarmApiHtml
|
||||
plain = ("Content-Type", "text/html")
|
||||
resp $ responseLBS ok200 [htmlType] tournamentsApiHtml
|
||||
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"
|
||||
]
|
||||
)
|
||||
]
|
||||
|
||||
@ -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
|
||||
{ lookupScenarioFileContent :: Sha1 -> IO (Maybe LBS.ByteString)
|
||||
-- ^ Dump scenario file
|
||||
, scenarioStorage :: ScenarioPersistence ScenarioUploadResponsePayload
|
||||
, solutionStorage :: ScenarioPersistence SolutionUploadResponsePayload
|
||||
data AuthenticationStorage m = AuthenticationStorage
|
||||
{ usernameFromCookie :: TL.Text -> m (Maybe UserAlias)
|
||||
, cookieFromUsername :: UserAlias -> m TL.Text
|
||||
}
|
||||
|
||||
data ScenarioPersistence b = ScenarioPersistence
|
||||
{ lookupCache :: Sha1 -> IO (Maybe AssociatedSolutionSolutionCharacterization)
|
||||
data PersistenceLayer m = PersistenceLayer
|
||||
{ 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
|
||||
{ expirationTime :: UTCTime
|
||||
, loginToken :: Password
|
||||
}
|
||||
instance FromRow TournamentSolution where
|
||||
fromRow =
|
||||
TournamentSolution
|
||||
<$> field
|
||||
<*> field
|
||||
<*> fromRow
|
||||
|
||||
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
|
||||
instance FromRow SolutionFileCharacterization where
|
||||
fromRow =
|
||||
SolutionFileCharacterization
|
||||
<$> (Sha1 <$> field)
|
||||
<*> fromRow
|
||||
|
||||
-- * 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
|
||||
-- Avoid GHC warning re: partiality of head
|
||||
queryHead = \case
|
||||
[] -> error "Query result in getUserId should never be empty!"
|
||||
hd : _ -> hd
|
||||
insertNew =
|
||||
fmap (UserId . fromOnly . queryHead)
|
||||
$ query
|
||||
-- | If the username already exists, overwrite the row.
|
||||
insertCookie ::
|
||||
UserAlias ->
|
||||
ReaderT Connection IO TL.Text
|
||||
insertCookie gitHubUsername = do
|
||||
conn <- ask
|
||||
liftIO $ do
|
||||
[Only cookieString] <-
|
||||
query
|
||||
conn
|
||||
"INSERT INTO users (alias) VALUES (?) RETURNING id;"
|
||||
$ Only userAlias
|
||||
"REPLACE INTO users (alias) VALUES (?) RETURNING cookie;"
|
||||
(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
|
||||
liftIO . fmap (fmap fromOnly . listToMaybe) . withConnection connInfo $ \conn ->
|
||||
conn <- ask
|
||||
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
|
||||
liftIO $ withConnection connInfo $ \conn -> runMaybeT $ do
|
||||
conn <- ask
|
||||
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
|
||||
solnChar <- liftIO . fmap listToMaybe . withConnection 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
|
||||
conn <- ask
|
||||
solnChar <-
|
||||
liftIO . fmap listToMaybe $
|
||||
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
|
||||
liftIO $ withConnection connInfo $ \conn ->
|
||||
query_ conn "SELECT original_filename, scenario_uploader, scenario, submission_count, swarm_git_sha1 FROM submissions;"
|
||||
conn <- ask
|
||||
liftIO $
|
||||
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
|
||||
h <- liftIO $ withConnection connInfo $ \conn -> do
|
||||
uid <- getUserId conn $ uploader $ upload s
|
||||
conn <- ask
|
||||
h <- liftIO $ do
|
||||
[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
|
||||
liftIO $ withConnection connInfo $ \conn -> do
|
||||
uid <- getUserId conn $ uploader solutionUpload
|
||||
|
||||
conn <- ask
|
||||
liftIO $ do
|
||||
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)
|
||||
"INSERT INTO solution_submission (uploader, content_sha1, solution_evaluation, content) VALUES (?, ?, ?, ?) RETURNING content_sha1;"
|
||||
( uploader solutionUpload
|
||||
, fileHash $ fileMetadata $ fileUpload solutionUpload
|
||||
, solutionEvalId
|
||||
, fileContent $ fileUpload solutionUpload
|
||||
)
|
||||
return $ Sha1 echoedSha1
|
||||
|
||||
insertSolution ::
|
||||
|
||||
@ -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
|
||||
}
|
||||
|
||||
@ -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
|
||||
, ScenarioUploadResponsePayload gameVersion
|
||||
( AssociatedSolutionCharacterization (fileHash $ fileMetadata file) solnMetrics
|
||||
, 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 $
|
||||
gamestateFromScenarioText scenarioContent
|
||||
fmap fst $
|
||||
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 ->
|
||||
|
||||
@ -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)) ->
|
||||
ExceptT e IO (FileMetadata, AssociatedSolutionSolutionCharacterization)
|
||||
(FileUpload -> ExceptT e IO (AssociatedSolutionCharacterization, a)) ->
|
||||
ExceptT e IO (FileMetadata, AssociatedSolutionCharacterization)
|
||||
withFileCache (PersistenceArgs userAlias multipartData persistenceFunctions) errorWrapper cacheStoreFunction = do
|
||||
file <- withExceptT errorWrapper $ obtainFileUpload multipartData
|
||||
maybePreexisting <-
|
||||
|
||||
@ -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,
|
||||
|
||||
@ -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 = noPersistence
|
||||
{ scenarioStorage =
|
||||
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
|
||||
assertEqual "Server response should be 200" ok200 $ responseStatus resp
|
||||
let baseUrl = "http://localhost:" ++ show p
|
||||
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
|
||||
|
||||
@ -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,
|
||||
PRIMARY KEY("id" AUTOINCREMENT)
|
||||
"cookie" TEXT NOT NULL UNIQUE DEFAULT (lower(hex(randomblob(16)))),
|
||||
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.swarm_git_sha1
|
||||
scenarios.uploader AS scenario_uploader,
|
||||
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;
|
||||
|
||||
@ -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 \
|
||||
"$@"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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>
|
||||
|
||||
72
tournament/web/list-solutions.html
Normal file
72
tournament/web/list-solutions.html
Normal file
@ -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>
|
||||
68
tournament/web/script/common.js
Normal file
68
tournament/web/script/common.js
Normal file
@ -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 + ")"));
|
||||
});
|
||||
|
||||
}
|
||||
});
|
||||
}
|
||||
@ -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) {
|
||||
throw new Error(`HTTP error, status = ${response.status}`);
|
||||
if (response.ok) {
|
||||
|
||||
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';
|
||||
});
|
||||
}
|
||||
}
|
||||
|
||||
77
tournament/web/script/list-solutions.js
Normal file
77
tournament/web/script/list-solutions.js
Normal file
@ -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';
|
||||
});
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user