forked from filipg/gonito
Filip Gralinski
9f4942a657
All the data (except for the repo URL and dev outputs) could be inferred, anyway. So it would not make much sense to hide it.
1729 lines
77 KiB
Haskell
1729 lines
77 KiB
Haskell
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE DoAndIfThenElse #-}
|
|
|
|
module Handler.ShowChallenge where
|
|
|
|
import Import hiding (Proxy, fromList)
|
|
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs)
|
|
|
|
import qualified Data.Text.Lazy as TL
|
|
import Text.Markdown
|
|
|
|
import qualified Data.Text as T
|
|
|
|
import qualified Data.HashMap.Strict as HMS
|
|
|
|
import qualified Yesod.Table as Table
|
|
|
|
import Control.Concurrent.Lifted (threadDelay)
|
|
|
|
import Handler.Extract
|
|
import Handler.Shared
|
|
import Handler.Runner
|
|
import Handler.Tables
|
|
import Handler.TagUtils
|
|
import Handler.MakePublic
|
|
import Handler.Dashboard
|
|
import Handler.Common
|
|
import Handler.Evaluate
|
|
import Handler.JWT
|
|
import Handler.Team
|
|
|
|
import Database.Persist.Sql (fromSqlKey)
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
import Web.Announcements
|
|
|
|
import Data.Maybe (fromJust)
|
|
|
|
import Text.Blaze
|
|
|
|
import Data.Aeson
|
|
|
|
import Gonito.ExtractMetadata (ExtractionOptions(..),
|
|
extractMetadataFromRepoDir,
|
|
GonitoMetadata(..),
|
|
parseTags,
|
|
Link(..))
|
|
|
|
import qualified Text.Read as TR
|
|
|
|
import GEval.Core
|
|
import GEval.EvaluationScheme
|
|
import GEval.Formatting
|
|
import GEval.Common (MetricResult(..))
|
|
|
|
import PersistSHA1
|
|
|
|
import System.IO (readFile)
|
|
|
|
import Data.Text (pack, unpack)
|
|
|
|
import Data.List (nub)
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import Database.Esqueleto ((^.))
|
|
|
|
import Data.Swagger hiding (get)
|
|
import qualified Data.Swagger as DS
|
|
|
|
import Data.Swagger.Declare
|
|
import Control.Lens hiding ((.=), (^.))
|
|
import Data.Proxy as DPR
|
|
import Data.HashMap.Strict.InsOrd (fromList)
|
|
|
|
instance ToJSON LeaderboardEntry where
|
|
toJSON entry = object
|
|
[ "submitter" .= (formatSubmitter $ leaderboardUser entry)
|
|
, "team" .= (teamIdent <$> entityVal <$> leaderboardTeam entry)
|
|
, "when" .= (submissionStamp $ leaderboardBestSubmission entry)
|
|
, "version" .= leaderboardVersion entry
|
|
, "description" .= descriptionToBeShown (leaderboardBestSubmission entry)
|
|
(leaderboardBestVariant entry)
|
|
(leaderboardParams entry)
|
|
, "times" .= leaderboardNumberOfSubmissions entry
|
|
, "hash" .= (fromSHA1ToText $ submissionCommit $ leaderboardBestSubmission entry)
|
|
, "isPublic" .= (submissionIsPublic $ leaderboardBestSubmission entry)
|
|
, "isReevaluable" .= (leaderboardIsReevaluable entry)
|
|
, "isVisible" .= (leaderboardIsVisible entry)
|
|
, "id" .= (leaderboardBestSubmissionId entry)
|
|
, "variant" .= (leaderboardBestVariantId entry)
|
|
]
|
|
|
|
declareLeaderboardSwagger :: Declare (Definitions Schema) Swagger
|
|
declareLeaderboardSwagger = do
|
|
-- param schemas
|
|
let challengeNameSchema = toParamSchema (Proxy :: Proxy String)
|
|
|
|
leaderboardResponse <- declareResponse (Proxy :: Proxy LeaderboardView)
|
|
|
|
return $ mempty
|
|
& paths .~
|
|
fromList [ ("/api/leaderboard/{challengeName}",
|
|
mempty & DS.get ?~ (mempty
|
|
& parameters .~ [ Inline $ mempty
|
|
& name .~ "challengeName"
|
|
& required ?~ True
|
|
& schema .~ ParamOther (mempty
|
|
& in_ .~ ParamPath
|
|
& paramSchema .~ challengeNameSchema) ]
|
|
& produces ?~ MimeList ["application/json"]
|
|
& description ?~ "Returns a leaderboard for a given challenge"
|
|
& at 200 ?~ Inline leaderboardResponse))
|
|
]
|
|
|
|
|
|
leaderboardApi :: Swagger
|
|
leaderboardApi = spec & definitions .~ defs
|
|
where
|
|
(defs, spec) = runDeclare declareLeaderboardSwagger mempty
|
|
|
|
data LeaderboardView = LeaderboardView {
|
|
leaderboardViewTests :: [Entity Test],
|
|
leaderboardViewEntries :: [LeaderboardEntryView]
|
|
}
|
|
|
|
instance ToJSON LeaderboardView where
|
|
toJSON v = object
|
|
[ "tests" .= (map getTestReference $ leaderboardViewTests v)
|
|
, "entries" .= leaderboardViewEntries v
|
|
]
|
|
|
|
instance ToSchema LeaderboardView where
|
|
declareNamedSchema _ = do
|
|
testsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [TestReference])
|
|
entriesSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [LeaderboardEntryView])
|
|
return $ NamedSchema (Just "Leaderboard") $ mempty
|
|
& type_ .~ SwaggerObject
|
|
& properties .~
|
|
fromList [ ("tests", testsSchema)
|
|
, ("entries", entriesSchema)
|
|
]
|
|
& required .~ [ "tests", "entries" ]
|
|
|
|
getLeaderboardJsonR :: Text -> Handler Value
|
|
getLeaderboardJsonR challengeName = do
|
|
Entity challengeId challenge <- runDB $ getBy404 $ UniqueName challengeName
|
|
leaderboardStyle <- determineLeaderboardStyle challenge
|
|
(leaderboard, (_, tests)) <- getLeaderboardEntries 1 leaderboardStyle challengeId
|
|
return $ toJSON $ LeaderboardView {
|
|
leaderboardViewTests = tests,
|
|
leaderboardViewEntries = map (toLeaderboardEntryView tests) leaderboard }
|
|
|
|
data LeaderboardEntryView = LeaderboardEntryView {
|
|
leaderboardEntryViewEntry :: LeaderboardEntry,
|
|
leaderboardEntryViewEvaluations :: [EvaluationView]
|
|
}
|
|
|
|
addJsonKey :: Text -> Value -> Value -> Value
|
|
addJsonKey key val (Object xs) = Object $ HMS.insert key val xs
|
|
addJsonKey _ _ xs = xs
|
|
|
|
|
|
-- Helper definitions for properties used in more than one place
|
|
|
|
isVisibleSchema :: Referenced Schema
|
|
isVisibleSchema = Inline $ toSchema (DPR.Proxy :: DPR.Proxy Bool)
|
|
& description .~ Just "Whether the details of the submissions are visible (i.e. either the submission is public or the user has the right permissions)"
|
|
|
|
isPublicSchema :: Referenced Schema
|
|
isPublicSchema = Inline $ toSchema (DPR.Proxy :: DPR.Proxy Bool)
|
|
& description .~ Just "Whether the submissions is public (i.e. whether its details are available to everyone)"
|
|
|
|
hashSchema :: Referenced Schema
|
|
hashSchema = Inline $ toSchema (DPR.Proxy :: DPR.Proxy String)
|
|
& description .~ Just "Git SHA1 commit hash; could be used as an argument for queries (if the submission is visible)"
|
|
& example .~ Just "ec41f0e2636bfedbd765c9871c813f7c5b896c51"
|
|
|
|
versionSchema :: Referenced Schema
|
|
versionSchema = Inline $ toSchema (DPR.Proxy :: DPR.Proxy [Int])
|
|
& description .~ Just "Challenge version under which the submission was done"
|
|
& example .~ Just (toJSON [2 :: Int, 0, 1])
|
|
|
|
submitterSchema :: Referenced Schema
|
|
submitterSchema = Inline $ toSchema (DPR.Proxy :: DPR.Proxy String)
|
|
& description .~ Just ("Name of the submitter, might be a special value in square brackets, e.g. " <> anonymizedLabel <> " or " <> nameNotGivenLabel)
|
|
& example .~ Just "John Smith"
|
|
|
|
submissionIdSchema :: Referenced Schema
|
|
submissionIdSchema = Inline $ toSchema (DPR.Proxy :: DPR.Proxy Int)
|
|
& description .~ Just "Internal database identifier of the submission"
|
|
& example .~ Just(toJSON (42 :: Int))
|
|
|
|
variantIdSchema :: Referenced Schema
|
|
variantIdSchema = Inline $ toSchema (DPR.Proxy :: DPR.Proxy Int)
|
|
& description .~ Just "Internal database identifier of the submission variant"
|
|
& example .~ Just (toJSON (53 :: Int))
|
|
|
|
|
|
|
|
instance ToJSON LeaderboardEntryView where
|
|
toJSON v = addJsonKey "evaluations"
|
|
(toJSON $ leaderboardEntryViewEvaluations v)
|
|
(toJSON $ leaderboardEntryViewEntry v)
|
|
|
|
instance ToSchema LeaderboardEntryView where
|
|
declareNamedSchema _ = do
|
|
stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
|
|
boolSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Bool)
|
|
evaluationsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [EvaluationView])
|
|
|
|
return $ NamedSchema (Just "LeaderboardEntry") $ mempty
|
|
& type_ .~ SwaggerObject
|
|
& properties .~
|
|
fromList [ ("submitter", submitterSchema)
|
|
, ("team", stringSchema)
|
|
, ("when", stringSchema)
|
|
, ("version", versionSchema)
|
|
, ("description", stringSchema)
|
|
, ("times", Inline $ toSchema (DPR.Proxy :: DPR.Proxy Int)
|
|
& description .~ Just "How many times a submission from the same user/of the same tag was submitted"
|
|
& minProperties .~ Just 1
|
|
& example .~ Just (toJSON (2:: Int)))
|
|
, ("hash", hashSchema)
|
|
, ("evaluations", evaluationsSchema)
|
|
, ("isPublic", isPublicSchema)
|
|
, ("isReevaluable", boolSchema)
|
|
, ("isVisible", isVisibleSchema)
|
|
, ("id", submissionIdSchema)
|
|
, ("variantId", variantIdSchema)
|
|
]
|
|
& required .~ [ "submitter", "when", "version", "description", "times", "hash", "evaluations" ]
|
|
|
|
toLeaderboardEntryView :: [(Entity Test)] -> LeaderboardEntry -> LeaderboardEntryView
|
|
toLeaderboardEntryView tests entry = LeaderboardEntryView {
|
|
leaderboardEntryViewEntry = entry,
|
|
leaderboardEntryViewEvaluations = catMaybes $
|
|
map (convertEvaluationToView (leaderboardEvaluationMap entry)) tests
|
|
}
|
|
|
|
determineLeaderboardStyle :: Challenge -> Handler LeaderboardStyle
|
|
determineLeaderboardStyle challenge = do
|
|
app <- getYesod
|
|
let leaderboardStyle = appLeaderboardStyle $ appSettings app
|
|
return $ case challengeIsCompetition challenge of
|
|
Just True -> BySubmitter
|
|
_ -> leaderboardStyle
|
|
|
|
getShowChallengeR :: Text -> Handler Html
|
|
getShowChallengeR challengeName = do
|
|
app <- getYesod
|
|
challengeEnt@(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName challengeName
|
|
leaderboardStyle <- determineLeaderboardStyle challenge
|
|
|
|
isHealthy <- isChallengeHealthy challenge
|
|
|
|
Just repo <- runDB $ get $ challengePublicRepo challenge
|
|
(leaderboard, (entries, tests)) <- getLeaderboardEntries 1 leaderboardStyle challengeId
|
|
|
|
showAltLeaderboard <- runDB $ hasMetricsOfSecondPriority challengeId
|
|
|
|
(altLeaderboard, altTests) <- if showAltLeaderboard
|
|
then
|
|
do
|
|
(leaderboard', (_, tests')) <- getLeaderboardEntries 3 ByTag challengeId
|
|
return $ (Just leaderboard', Just tests')
|
|
else
|
|
return (Nothing, Nothing)
|
|
|
|
mauth <- maybeAuth
|
|
|
|
let params = getNumericalParams entries
|
|
|
|
let scheme = appRepoScheme $ appSettings app
|
|
|
|
challengeRepo <- runDB $ get404 $ challengePublicRepo challenge
|
|
|
|
challengeLayout True challenge (showChallengeWidget mauth
|
|
challengeEnt
|
|
scheme
|
|
challengeRepo
|
|
repo
|
|
leaderboard
|
|
altLeaderboard
|
|
params
|
|
tests
|
|
altTests
|
|
isHealthy)
|
|
|
|
hasMetricsOfSecondPriority :: (PersistQueryRead backend, MonadIO m, BaseBackend backend ~ SqlBackend) => Key Challenge -> ReaderT backend m Bool
|
|
hasMetricsOfSecondPriority challengeId = do
|
|
tests' <- selectList [TestChallenge ==. challengeId, TestActive ==. True] []
|
|
let tests = filter (\t -> (evaluationSchemePriority $ testMetric $ entityVal t) == 2) tests'
|
|
return $ not (null tests)
|
|
|
|
|
|
getChallengeReadmeR :: Text -> Handler Html
|
|
getChallengeReadmeR challengeName = do
|
|
(Entity _ challenge) <- runDB $ getBy404 $ UniqueName challengeName
|
|
readme <- challengeReadme challengeName
|
|
challengeLayout False challenge $ toWidget readme
|
|
|
|
challengeReadmeInMarkdownApi :: Swagger
|
|
challengeReadmeInMarkdownApi = spec & definitions .~ defs
|
|
where
|
|
(defs, spec) = runDeclare declareChallengeReadmeInMarkdownSwagger mempty
|
|
|
|
declareChallengeReadmeInMarkdownSwagger :: Declare (Definitions Schema) Swagger
|
|
declareChallengeReadmeInMarkdownSwagger = do
|
|
-- param schemas
|
|
let challengeNameSchema = toParamSchema (Proxy :: Proxy String)
|
|
|
|
return $ mempty
|
|
& paths .~
|
|
fromList [ ("/api/challenge-readme/{challengeName}/markdown",
|
|
mempty & DS.get ?~ (mempty
|
|
& parameters .~ [ Inline $ mempty
|
|
& name .~ "challengeName"
|
|
& required ?~ True
|
|
& schema .~ ParamOther (mempty
|
|
& in_ .~ ParamPath
|
|
& paramSchema .~ challengeNameSchema) ]
|
|
& produces ?~ MimeList ["application/text"]
|
|
& description ?~ "Returns the challenge README in Markdown"))
|
|
]
|
|
|
|
getChallengeReadmeInMarkdownR :: Text -> Handler TL.Text
|
|
getChallengeReadmeInMarkdownR challengeName = doChallengeReadmeContents challengeName
|
|
|
|
challengeReadme :: Text -> Handler Html
|
|
challengeReadme challengeName = do
|
|
theContents <- doChallengeReadmeContents challengeName
|
|
return $ markdown def theContents
|
|
|
|
-- Checks whether the directories with repos are available
|
|
isChallengeHealthy :: Challenge -> Handler Bool
|
|
isChallengeHealthy challenge = do
|
|
publicRepoDirExists <- doesRepoExistsOnTheDisk $ challengePublicRepo challenge
|
|
privateRepoDirExists <- doesRepoExistsOnTheDisk $ challengePrivateRepo challenge
|
|
return $ publicRepoDirExists && privateRepoDirExists
|
|
|
|
doChallengeReadmeContents :: Text -> Handler TL.Text
|
|
doChallengeReadmeContents challengeName = do
|
|
(Entity _ challenge) <- runDB $ getBy404 $ UniqueName challengeName
|
|
let repoId = challengePublicRepo challenge
|
|
repoDir <- getRepoDir repoId
|
|
let readmeFilePath = repoDir </> readmeFile
|
|
theContents <- liftIO $ System.IO.readFile readmeFilePath
|
|
return $ TL.pack theContents
|
|
|
|
showChallengeWidget :: Maybe (Entity User)
|
|
-> Entity Challenge
|
|
-> RepoScheme
|
|
-> Repo
|
|
-> Repo
|
|
-> [LeaderboardEntry]
|
|
-> (Maybe [LeaderboardEntry])
|
|
-> [Text]
|
|
-> [Entity Test]
|
|
-> (Maybe [Entity Test])
|
|
-> Bool
|
|
-> WidgetFor App ()
|
|
showChallengeWidget mUserEnt
|
|
(Entity challengeId challenge)
|
|
scheme
|
|
challengeRepo
|
|
repo
|
|
leaderboard
|
|
mAltLeaderboard
|
|
params
|
|
tests
|
|
mAltTests
|
|
isHealthy
|
|
= $(widgetFile "show-challenge")
|
|
where leaderboardWithRanks = zip [1..] leaderboard
|
|
mAltLeaderboardWithRanks = zip [1..] <$> mAltLeaderboard
|
|
maybeRepoLink = getRepoLink repo
|
|
delta = Number 4
|
|
higherTheBetterArray = getIsHigherTheBetterArray $ map entityVal tests
|
|
mUserId = entityKey <$> mUserEnt
|
|
|
|
data GitServer = Gogs | GitLab | GitHub | Gonito
|
|
deriving (Eq, Show)
|
|
|
|
guessGitServer :: Text -> Maybe GitServer
|
|
guessGitServer bareUrl
|
|
| "git.wmi.amu.edu.pl" `isPrefixOf` bareUrl = Just Gogs
|
|
| "gitlab." `isPrefixOf` bareUrl = Just GitLab
|
|
| "git." `isPrefixOf` bareUrl = Just GitLab
|
|
| "github." `isPrefixOf` bareUrl = Just GitHub
|
|
| "gonito.net" `isPrefixOf` bareUrl = Just Gonito
|
|
| otherwise = Nothing
|
|
|
|
getHttpLink :: Repo -> Maybe (Text, Text)
|
|
getHttpLink repo = case guessGitServer bareUrl of
|
|
Just Gogs -> Just (convertToHttpLink bareUrl, "/src/" <> branch)
|
|
Just GitLab -> Just (convertToHttpLink bareUrl, "/-/tree/" <> branch)
|
|
Just GitHub -> Just (convertToHttpLink bareUrl, "/tree/" <> branch)
|
|
Just Gonito -> Just (fixGonito $ convertToHttpLink bareUrl, "/" <> branch)
|
|
Nothing -> Nothing
|
|
where bareUrl = removeProtocol $ removeLogin rurl
|
|
removeLogin t = r
|
|
where (_, r) = T.breakOnEnd "@" t
|
|
rurl = repoUrl repo
|
|
branch = repoBranch repo
|
|
convertToHttpLink = ("https://" <>) . (T.replace ":" "/") . (T.replace ".git" "")
|
|
removeProtocol = stripPrefixes ["https://", "http://", "git://", "ssh://",
|
|
"ssh." -- when a domain with ssh. prefix is used
|
|
]
|
|
stripPrefixes prefixes t = foldr stripPrefixFrom t prefixes
|
|
stripPrefixFrom pref t = if pref `isPrefixOf` t
|
|
then drop (length pref) t
|
|
else t
|
|
fixGonito t = (T.replace "https://gonito.net" "https://gonito.net/gitlist" t) <> ".git"
|
|
|
|
getRepoLink :: Repo -> Maybe Text
|
|
getRepoLink repo = case getHttpLink repo of
|
|
Just (hostname, linkRest) -> Just $ hostname <> linkRest
|
|
Nothing -> if sitePrefix `isPrefixOf` theUrl
|
|
then Just $ (browsableGitRepo bareRepoName) ++ "/" ++ (repoBranch repo)
|
|
else Nothing
|
|
where sitePrefix = "git://gonito.net/" :: Text
|
|
sitePrefixLen = length sitePrefix
|
|
theUrl = repoUrl repo
|
|
bareRepoName = drop sitePrefixLen theUrl
|
|
|
|
instance ToJSON (Repo) where
|
|
toJSON repo = object
|
|
[ "url" .= repoUrl repo
|
|
, "branch" .= repoBranch repo
|
|
, "browsableUrl" .= getRepoLink repo
|
|
]
|
|
|
|
instance ToSchema (Repo) where
|
|
declareNamedSchema _ = do
|
|
stringSchema <- declareSchemaRef (Proxy :: Proxy String)
|
|
return $ NamedSchema (Just "DataRepository") $ mempty
|
|
& type_ .~ SwaggerObject
|
|
& properties .~
|
|
fromList [ ("url", Inline $ toSchema (DPR.Proxy :: DPR.Proxy String)
|
|
& description .~ Just "Git URL to be cloned (https://, git:// or ssh:// protocol)"
|
|
& example .~ Just (toJSON ("git://gonito.net/fiszki-ocr" :: String)))
|
|
, ("branch", stringSchema)
|
|
, ("browsableUrl", Inline $ toSchema (DPR.Proxy :: DPR.Proxy String)
|
|
& description .~ Just "An URL address that your browser can open; usually, but not always available"
|
|
& example .~ Just (toJSON ("https://github.com/applicaai/kleister-charity/tree/master" :: String)))
|
|
|
|
]
|
|
& required .~ [ "url", "branch" ]
|
|
|
|
getChallengeRepoJsonR :: Text -> Handler Value
|
|
getChallengeRepoJsonR chName = do
|
|
(Entity _ challenge) <- runDB $ getBy404 $ UniqueName chName
|
|
repo <- runDB $ get404 $ challengePublicRepo challenge
|
|
return $ toJSON repo
|
|
|
|
declareChallengeRepoSwagger :: Declare (Definitions Schema) Swagger
|
|
declareChallengeRepoSwagger = do
|
|
-- param schemas
|
|
let challengeNameSchema = toParamSchema (Proxy :: Proxy String)
|
|
|
|
return $ mempty
|
|
& paths .~
|
|
fromList [ ("/api/challenge-repo/{challengeName}",
|
|
mempty & DS.get ?~ (mempty
|
|
& parameters .~ [ Inline $ mempty
|
|
& name .~ "challengeName"
|
|
& required ?~ True
|
|
& schema .~ ParamOther (mempty
|
|
& in_ .~ ParamPath
|
|
& paramSchema .~ challengeNameSchema) ]
|
|
& produces ?~ MimeList ["application/json"]
|
|
& description ?~ "Return metadata for the challenge repository"))
|
|
]
|
|
|
|
challengeRepoApi :: Swagger
|
|
challengeRepoApi = spec & definitions .~ defs
|
|
where
|
|
(defs, spec) = runDeclare declareChallengeRepoSwagger mempty
|
|
|
|
|
|
getChallengeHowToR :: Text -> Handler Html
|
|
getChallengeHowToR challengeName = do
|
|
(Entity _ challenge) <- runDB $ getBy404 $ UniqueName challengeName
|
|
maybeUser <- maybeAuth
|
|
|
|
app <- getYesod
|
|
let settings = appSettings app
|
|
|
|
let publicRepoId = challengePublicRepo challenge
|
|
repo <- runDB $ get404 publicRepoId
|
|
|
|
case maybeUser of
|
|
Just (Entity userId user) -> do
|
|
enableTriggerToken userId (userTriggerToken user)
|
|
Nothing -> return ()
|
|
|
|
let mToken = case maybeUser of
|
|
Just (Entity _ user) -> userTriggerToken user
|
|
Nothing -> Nothing
|
|
|
|
let isIDSet = case maybeUser of
|
|
Just (Entity _ user) -> isJust $ userLocalId user
|
|
Nothing -> False
|
|
isSSHUploaded <- case maybeUser of
|
|
Just (Entity userId _) -> do
|
|
ukeys <- runDB $ selectList [PublicKeyUser ==. userId] []
|
|
return $ not (null ukeys)
|
|
Nothing -> return False
|
|
challengeLayout False challenge (challengeHowTo
|
|
challenge
|
|
settings
|
|
repo
|
|
(idToBeShown challenge maybeUser)
|
|
isIDSet
|
|
isSSHUploaded
|
|
(join $ userAltRepoScheme <$> entityVal <$> maybeUser)
|
|
mToken)
|
|
|
|
idToBeShown :: p -> Maybe (Entity User) -> Text
|
|
idToBeShown _ maybeUser =
|
|
case maybeUser of
|
|
Just user -> case userLocalId $ entityVal user of
|
|
Just localId -> localId
|
|
Nothing -> defaultIdToBe
|
|
Nothing -> defaultIdToBe
|
|
where defaultIdToBe = "YOURID" :: Text
|
|
|
|
externalRepoPlaceholder :: Text
|
|
externalRepoPlaceholder = "URL_TO_YOUR_REPO"
|
|
|
|
defaultRepo :: RepoScheme -> Text -> Challenge -> Repo -> Maybe (Entity User) -> Text
|
|
defaultRepo SelfHosted repoHost challenge _ maybeUser = repoHost ++ (idToBeShown challenge maybeUser) ++ "/" ++ (challengeName challenge)
|
|
defaultRepo Branches _ _ repo _ = repoUrl repo
|
|
defaultRepo NoInternalGitServer _ _ _ _ = externalRepoPlaceholder
|
|
|
|
defaultBranch :: IsString a => RepoScheme -> Maybe a
|
|
defaultBranch SelfHosted = Just "master"
|
|
defaultBranch Branches = Nothing
|
|
defaultBranch NoInternalGitServer = Nothing
|
|
|
|
challengeHowTo :: Challenge -> AppSettings -> Repo -> Text -> Bool -> Bool -> Maybe Text -> Maybe Text -> WidgetFor App ()
|
|
challengeHowTo challenge settings repo shownId isIDSet isSSHUploaded mAltRepoScheme mToken = $(widgetFile "challenge-how-to")
|
|
where myBranch = "my-brilliant-branch" :: Text
|
|
urlToYourRepo = case mAltRepoScheme of
|
|
Just altRepoScheme -> encodeSlash (altRepoScheme <> (challengeName challenge))
|
|
Nothing -> externalRepoPlaceholder
|
|
|
|
postHealR :: ChallengeId -> Handler TypedContent
|
|
postHealR challengeId = runViewProgress $ doHeal challengeId
|
|
|
|
doHeal :: Key Challenge -> Channel -> HandlerFor App ()
|
|
doHeal challengeId chan = do
|
|
challenge <- runDB $ get404 challengeId
|
|
_ <- getRepoDirOrClone (challengePrivateRepo challenge) chan
|
|
_ <- getRepoDirOrClone (challengePublicRepo challenge) chan
|
|
return ()
|
|
|
|
postArchiveR :: ChallengeId -> Handler Html
|
|
postArchiveR challengeId = doSetArchive True challengeId
|
|
|
|
postUnarchiveR :: ChallengeId -> Handler Html
|
|
postUnarchiveR challengeId = doSetArchive False challengeId
|
|
|
|
doSetArchive :: Bool -> ChallengeId -> Handler Html
|
|
doSetArchive status challengeId = do
|
|
runDB $ update challengeId [ChallengeArchived =. Just status]
|
|
challenge <- runDB $ get404 challengeId
|
|
getShowChallengeR $ challengeName challenge
|
|
|
|
|
|
archiveForm :: ChallengeId -> Form ChallengeId
|
|
archiveForm challengeId = renderBootstrap3 BootstrapBasicForm $ areq hiddenField "" (Just challengeId)
|
|
|
|
getChallengeSubmissionR :: Text -> Handler Html
|
|
getChallengeSubmissionR challengeName = do
|
|
(Entity _ challenge) <- runDB $ getBy404 $ UniqueName challengeName
|
|
maybeUser <- maybeAuth
|
|
|
|
Just repo <- runDB $ get $ challengePublicRepo challenge
|
|
app <- getYesod
|
|
let scheme = appRepoScheme $ appSettings app
|
|
let repoHost = appRepoHost $ appSettings app
|
|
|
|
let defaultUrl = fromMaybe (defaultRepo scheme repoHost challenge repo maybeUser)
|
|
((<> challengeName) <$> (join $ userAltRepoScheme <$> entityVal <$> maybeUser))
|
|
|
|
Entity userId _ <- requireAuth
|
|
|
|
defaultTeam <- fetchDefaultTeam userId
|
|
|
|
(formWidget, formEnctype) <- generateFormPost $ submissionForm userId (Just defaultUrl) (defaultBranch scheme) (repoGitAnnexRemote repo) (Just defaultTeam)
|
|
challengeLayout True challenge $ challengeSubmissionWidget formWidget formEnctype challenge
|
|
|
|
|
|
declareChallengeSubmissionSwagger :: Declare (Definitions Schema) Swagger
|
|
declareChallengeSubmissionSwagger = do
|
|
-- param schemas
|
|
let challengeNameSchema = toParamSchema (Proxy :: Proxy String)
|
|
let stringSchema = toParamSchema (Proxy :: Proxy String)
|
|
|
|
challengeSubmissionResponse <- declareResponse (Proxy :: Proxy Int)
|
|
wrongSubmissionResponse <- declareResponse (Proxy :: Proxy GonitoStatus)
|
|
|
|
return $ mempty
|
|
& paths .~
|
|
fromList [ ("/api/challenge-submission/{challengeName}",
|
|
mempty & DS.post ?~ (mempty
|
|
& parameters .~ [ Inline $ mempty
|
|
& name .~ "challengeName"
|
|
& required ?~ True
|
|
& schema .~ ParamOther (mempty
|
|
& in_ .~ ParamPath
|
|
& paramSchema .~ challengeNameSchema),
|
|
Inline $ mempty
|
|
& name .~ "f1"
|
|
& description .~ Just "submission description"
|
|
& required ?~ False
|
|
& schema .~ ParamOther (mempty
|
|
& in_ .~ ParamFormData
|
|
& paramSchema .~ stringSchema),
|
|
Inline $ mempty
|
|
& name .~ "f2"
|
|
& description .~ Just "submission tags"
|
|
& required ?~ False
|
|
& schema .~ ParamOther (mempty
|
|
& in_ .~ ParamFormData
|
|
& paramSchema .~ stringSchema),
|
|
Inline $ mempty
|
|
& name .~ "f3"
|
|
& description .~ Just "repo URL"
|
|
& required ?~ True
|
|
& schema .~ ParamOther (mempty
|
|
& in_ .~ ParamFormData
|
|
& paramSchema .~ stringSchema),
|
|
Inline $ mempty
|
|
& name .~ "f4"
|
|
& description .~ Just "repo branch"
|
|
& required ?~ True
|
|
& schema .~ ParamOther (mempty
|
|
& in_ .~ ParamFormData
|
|
& paramSchema .~ stringSchema),
|
|
|
|
Inline $ mempty
|
|
& name .~ "f5"
|
|
& description .~ Just "git-annex remote specification"
|
|
& required ?~ False
|
|
& schema .~ ParamOther (mempty
|
|
& in_ .~ ParamFormData
|
|
& paramSchema .~ stringSchema)]
|
|
& produces ?~ MimeList ["application/json"]
|
|
& description ?~ "Initiates a submission based on a given repo URL/branch. Returns an asynchrous job ID."
|
|
& at 200 ?~ Inline challengeSubmissionResponse
|
|
& at 422 ?~ Inline wrongSubmissionResponse))
|
|
]
|
|
|
|
challengeSubmissionApi :: Swagger
|
|
challengeSubmissionApi = spec & definitions .~ defs
|
|
where
|
|
(defs, spec) = runDeclare declareChallengeSubmissionSwagger mempty
|
|
|
|
|
|
data ChallangeSubmissionStatus = SubmissionOK | SubmissionWrong Text
|
|
deriving (Eq, Show)
|
|
|
|
data GonitoStatus = GonitoStatus {
|
|
detail :: Text
|
|
} deriving (Eq, Show, Generic)
|
|
|
|
instance ToJSON GonitoStatus
|
|
instance ToSchema GonitoStatus
|
|
|
|
postChallengeSubmissionJsonR :: Text -> Handler Value
|
|
postChallengeSubmissionJsonR challengeName = do
|
|
Entity userId _ <- requireAuthPossiblyByToken
|
|
|
|
challengeEnt@(Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName
|
|
((result, _), _) <- runFormPostNoToken $ submissionForm userId Nothing Nothing Nothing Nothing
|
|
let submissionData' = case result of
|
|
FormSuccess res -> Just res
|
|
_ -> Nothing
|
|
Just submissionData = submissionData'
|
|
|
|
status <- checkSubmission challengeEnt submissionData
|
|
|
|
case status of
|
|
SubmissionOK -> runViewProgressAsynchronously $ doCreateSubmission userId challengeId submissionData
|
|
SubmissionWrong errorMsg -> sendResponseStatus status422 $ toJSON (GonitoStatus errorMsg)
|
|
|
|
checkSubmission :: Entity Challenge -> ChallengeSubmissionData -> Handler ChallangeSubmissionStatus
|
|
checkSubmission (Entity _ challenge) submissionData = do
|
|
let repo = challengeSubmissionDataRepo submissionData
|
|
if (null $ repoSpecUrl repo)
|
|
then
|
|
return $ SubmissionWrong "empty URL"
|
|
else
|
|
do
|
|
if (null $ repoSpecBranch repo)
|
|
then
|
|
return $ SubmissionWrong "empty branch"
|
|
else
|
|
do
|
|
if (willClone challenge submissionData)
|
|
then
|
|
do
|
|
return SubmissionOK
|
|
else
|
|
do
|
|
return $ SubmissionWrong "Refusing to clone the submission from this URL."
|
|
|
|
postChallengeSubmissionR :: Text -> Handler TypedContent
|
|
postChallengeSubmissionR challengeName = do
|
|
userId <- requireAuthId
|
|
|
|
(Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName
|
|
((result, _), _) <- runFormPost $ submissionForm userId Nothing Nothing Nothing Nothing
|
|
let submissionData' = case result of
|
|
FormSuccess res -> Just res
|
|
_ -> Nothing
|
|
Just submissionData = submissionData'
|
|
|
|
runViewProgress $ doCreateSubmission userId challengeId submissionData
|
|
|
|
postTriggerLocallyR :: Handler TypedContent
|
|
postTriggerLocallyR = do
|
|
(Just challengeName) <- lookupPostParam "challenge"
|
|
(Just localId) <- lookupPostParam "user"
|
|
mBranch <- lookupPostParam "branch"
|
|
mGitAnnexRemote <- lookupPostParam "git-annex-remote"
|
|
[Entity userId _] <- runDB $ selectList [UserLocalId ==. Just localId] []
|
|
|
|
app <- getYesod
|
|
let repoHost = appRepoHost $ appSettings app
|
|
|
|
let localRepo = repoHost ++ localId ++ "/" ++ challengeName
|
|
trigger userId challengeName localRepo mBranch mGitAnnexRemote
|
|
|
|
postTriggerRemotelyR :: Handler TypedContent
|
|
postTriggerRemotelyR = do
|
|
(Just challengeName) <- lookupPostParam "challenge"
|
|
(Just theUrl) <- lookupPostParam "url"
|
|
(Just token) <- lookupPostParam "token"
|
|
mBranch <- lookupPostParam "branch"
|
|
mGitAnnexRemote <- lookupPostParam "git-annex-remote"
|
|
doTrigger token challengeName theUrl mBranch mGitAnnexRemote
|
|
|
|
postTriggerRemotelySimpleR :: Text -> Text -> Text -> Text -> Handler TypedContent
|
|
postTriggerRemotelySimpleR token challengeName theUrl branch =
|
|
doTrigger token challengeName (decodeSlash theUrl) (Just branch) Nothing
|
|
|
|
getTriggerRemotelySimpleR :: Text -> Text -> Text -> Text -> Handler TypedContent
|
|
getTriggerRemotelySimpleR token challengeName theUrl branch =
|
|
doTrigger token challengeName (decodeSlash theUrl) (Just branch) Nothing
|
|
|
|
data GitServerPayload = GitServerPayload {
|
|
gitServerPayloadRef :: Text,
|
|
-- Unfortunately, the URL is given in "ssh_url" field
|
|
-- for Gogs and "git_ssh_url" for GitLab, hence two
|
|
-- fields here
|
|
gitServerPayloadSshUrl :: Maybe Text,
|
|
gitServerPayloadGitSshUrl :: Maybe Text
|
|
}
|
|
deriving (Show, Eq)
|
|
|
|
instance FromJSON GitServerPayload where
|
|
parseJSON (Object o) = GitServerPayload
|
|
<$> o .: "ref"
|
|
<*> ((o .: "repository") >>= (.:? "ssh_url"))
|
|
<*> ((o .: "repository") >>= (.:? "git_ssh_url"))
|
|
|
|
postTriggerByWebhookR :: Text -> Text -> Handler TypedContent
|
|
postTriggerByWebhookR token challengeName = do
|
|
payload <- requireJsonBody :: Handler GitServerPayload
|
|
let ref = gitServerPayloadRef payload
|
|
let refPrefix = "refs/heads/"
|
|
if refPrefix `isPrefixOf` ref
|
|
then
|
|
do
|
|
let branch = T.replace refPrefix "" ref
|
|
let theUrl = fromMaybe (fromJust $ gitServerPayloadGitSshUrl payload)
|
|
(gitServerPayloadSshUrl payload)
|
|
doTrigger token challengeName theUrl (Just branch) Nothing
|
|
else
|
|
error $ "unexpected ref `" ++ (T.unpack ref) ++ "`"
|
|
|
|
|
|
doTrigger :: Text -> Text -> Text -> Maybe Text -> Maybe Text -> Handler TypedContent
|
|
doTrigger token challengeName theUrl mBranch mGitAnnexRemote = do
|
|
[Entity userId _] <- runDB $ selectList [UserTriggerToken ==. Just token] []
|
|
trigger userId challengeName theUrl mBranch mGitAnnexRemote
|
|
|
|
trigger :: UserId -> Text -> Text -> Maybe Text -> Maybe Text -> Handler TypedContent
|
|
trigger userId challengeName theUrl mBranch mGitAnnexRemote = do
|
|
let branch = fromMaybe "master" mBranch
|
|
mChallengeEnt <- runDB $ getBy $ UniqueName challengeName
|
|
|
|
let defSubmission = ChallengeSubmissionData {
|
|
challengeSubmissionDataDescription = Nothing,
|
|
challengeSubmissionDataTags = Nothing,
|
|
challengeSubmissionDataRepo = RepoSpec {
|
|
repoSpecUrl=theUrl,
|
|
repoSpecBranch=branch,
|
|
repoSpecGitAnnexRemote=mGitAnnexRemote},
|
|
challengeSubmissionDataTeam = Nothing
|
|
}
|
|
|
|
case mChallengeEnt of
|
|
Just (Entity challengeId _) -> runOpenViewProgress $ doCreateSubmission userId challengeId defSubmission
|
|
Nothing -> return $ toTypedContent (("Unknown challenge `" ++ (Data.Text.unpack challengeName) ++ "`. Cannot be triggered, must be submitted manually at Gonito.net!\n") :: String)
|
|
|
|
isBefore :: UTCTime -> Maybe UTCTime -> Bool
|
|
isBefore _ Nothing = True
|
|
isBefore moment (Just deadline) = moment <= deadline
|
|
|
|
-- | An attempt to filtre out mistaken/unwanted submissions (without cloning
|
|
-- the submission repo, just by looking at the metadata)
|
|
willClone :: Challenge -> ChallengeSubmissionData -> Bool
|
|
willClone challenge submissionData =
|
|
(challengeName challenge) `isInfixOf` theUrl && branch /= dontPeek && not (dontPeek `isInfixOf` theUrl)
|
|
where theUrl = repoSpecUrl $ challengeSubmissionDataRepo submissionData
|
|
branch = repoSpecBranch $ challengeSubmissionDataRepo submissionData
|
|
dontPeek = "dont-peek"
|
|
|
|
|
|
-- | Main place where submission is done (whether manually or by trigger)
|
|
doCreateSubmission :: UserId -> Key Challenge -> ChallengeSubmissionData -> Channel -> Handler ()
|
|
doCreateSubmission userId challengeId challengeSubmissionData chan = do
|
|
challenge <- runDB $ get404 challengeId
|
|
|
|
theVersion <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
|
|
theNow <- liftIO getCurrentTime
|
|
|
|
if theNow `isBefore` (versionDeadline $ entityVal theVersion)
|
|
then
|
|
do
|
|
let wanted = willClone challenge challengeSubmissionData
|
|
if wanted
|
|
then
|
|
doCreateSubmission' (challengeArchived challenge) userId challengeId challengeSubmissionData chan
|
|
else
|
|
msg chan "Refusing to clone the submission from this URL"
|
|
else
|
|
msg chan "Submission is past the deadline, no submission will be accepted from now on."
|
|
|
|
doCreateSubmission' :: Maybe Bool -> UserId -> Key Challenge -> ChallengeSubmissionData -> Channel -> Handler ()
|
|
doCreateSubmission' (Just True) _ _ _ chan = msg chan "This challenge is archived, you cannot submit to it. Ask the site admin to unarchive it."
|
|
doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do
|
|
let mDescription = challengeSubmissionDataDescription challengeSubmissionData
|
|
let mTags = challengeSubmissionDataTags challengeSubmissionData
|
|
let repoSpec = challengeSubmissionDataRepo challengeSubmissionData
|
|
|
|
maybeRepoKey <- getSubmissionRepo userId challengeId repoSpec chan
|
|
case maybeRepoKey of
|
|
Just repoId -> do
|
|
|
|
challenge <- runDB $ get404 challengeId
|
|
user <- runDB $ get404 userId
|
|
|
|
relevantIndicators <- getOngoingTargets challengeId
|
|
|
|
|
|
(Entity _ currentVersion) <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
|
|
let submittedMajorVersion = versionMajor currentVersion
|
|
|
|
mMainEnt <- runDB $ fetchMainTest challengeId
|
|
bestScoreSoFar <- case mMainEnt of
|
|
Just (Entity _ mainTest) -> do
|
|
let orderDirection = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of
|
|
TheHigherTheBetter -> E.desc
|
|
TheLowerTheBetter -> E.asc
|
|
|
|
bestResultSoFar <- runDB $ E.select $ E.from $ \(evaluation, submission, variant, out, test, theVersion) -> do
|
|
E.where_ (submission ^. SubmissionChallenge E.==. E.val challengeId
|
|
E.&&. submission ^. SubmissionIsHidden E.==. E.val False
|
|
E.&&. variant ^. VariantSubmission E.==. submission ^. SubmissionId
|
|
E.&&. evaluation ^. EvaluationChecksum E.==. out ^. OutChecksum
|
|
E.&&. (E.not_ (E.isNothing (evaluation ^. EvaluationScore)))
|
|
E.&&. out ^. OutVariant E.==. variant ^. VariantId
|
|
E.&&. evaluation ^. EvaluationTest E.==. test ^. TestId
|
|
E.&&. test ^. TestChallenge E.==. E.val challengeId
|
|
E.&&. test ^. TestName E.==. E.val (testName mainTest)
|
|
E.&&. test ^. TestMetric E.==. E.val (testMetric mainTest)
|
|
E.&&. test ^. TestActive
|
|
E.&&. (evaluation ^. EvaluationVersion E.==. theVersion ^. VersionCommit)
|
|
E.&&. theVersion ^. VersionCommit E.==. test ^. TestCommit
|
|
E.&&. theVersion ^. VersionMajor E.>=. E.val submittedMajorVersion)
|
|
E.orderBy [orderDirection (evaluation ^. EvaluationScore)]
|
|
E.limit 1
|
|
return evaluation
|
|
let bestScoreSoFar' = join (evaluationScore <$> entityVal <$> (listToMaybe bestResultSoFar))
|
|
return bestScoreSoFar'
|
|
Nothing -> return Nothing
|
|
|
|
case bestScoreSoFar of
|
|
Just s -> msg chan ("best score so far is: " ++ (Data.Text.pack $ show s))
|
|
Nothing -> msg chan "first submission so far"
|
|
|
|
repo <- runDB $ get404 repoId
|
|
|
|
repoDir <- getRepoDirOrClone repoId chan
|
|
|
|
gonitoMetadata <- liftIO
|
|
$ extractMetadataFromRepoDir repoDir (ExtractionOptions {
|
|
extractionOptionsDescription = mDescription,
|
|
extractionOptionsTags = Just $ parseTags mTags,
|
|
extractionOptionsGeneralParams = Nothing,
|
|
extractionOptionsUnwantedParams = Nothing,
|
|
extractionOptionsParamFiles = Nothing,
|
|
extractionOptionsMLRunPath = Nothing,
|
|
extractionOptionsExternalLinks = Nothing,
|
|
extractionOptionsDependencies = Nothing })
|
|
|
|
mTeamId <- case challengeSubmissionDataTeam challengeSubmissionData of
|
|
Just tid -> return $ Just tid
|
|
Nothing -> fetchDefaultTeam userId
|
|
|
|
submissionId <- getSubmission userId
|
|
mTeamId
|
|
repoId
|
|
(repoCurrentCommit repo)
|
|
challengeId
|
|
(gonitoMetadataDescription gonitoMetadata)
|
|
chan
|
|
|
|
_ <- runDB $ mapM insert $ map (\l -> ExternalLink {
|
|
externalLinkSubmission = submissionId,
|
|
externalLinkTitle = linkTitle l,
|
|
externalLinkUrl = linkUrl l }) $ gonitoMetadataExternalLinks gonitoMetadata
|
|
|
|
_ <- runDB $ mapM insertUnique $ map (\s -> Dependency {
|
|
dependencySubRepoCommit = s,
|
|
dependencySuperRepoCommit = (repoCurrentCommit repo) }) $ gonitoMetadataDependencies gonitoMetadata
|
|
|
|
outs <- getOuts False chan submissionId (gonitoMetadataGeneralParams gonitoMetadata)
|
|
|
|
currentTagIds <- runDB $ selectList [SubmissionTagSubmission ==. submissionId] []
|
|
|
|
runDB $ addTags submissionId (gonitoMetadataTags gonitoMetadata) (
|
|
map (submissionTagTag . entityVal) currentTagIds)
|
|
msg chan "SUBMISSION CREATED"
|
|
|
|
app <- getYesod
|
|
let mHook = appAnnouncementHook $ appSettings app
|
|
|
|
let submissionLink = linkInAnnouncement mHook app "submission" ("q/" ++ (fromSHA1ToText (repoCurrentCommit repo)))
|
|
|
|
case mMainEnt of
|
|
Just (Entity mainTestId mainTest) -> do
|
|
newScores <- mapM (getScoreForOut mainTestId) outs
|
|
let newScores' = catMaybes newScores
|
|
let newScores'' = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of
|
|
TheHigherTheBetter -> reverse $ sort newScores'
|
|
TheLowerTheBetter -> sort newScores'
|
|
let compOp = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of
|
|
TheLowerTheBetter -> (<)
|
|
TheHigherTheBetter -> (>)
|
|
|
|
case bestScoreSoFar of
|
|
Just b -> case newScores'' of
|
|
(s:_) -> if compOp s b
|
|
then
|
|
do
|
|
let challengeLink = linkInAnnouncement mHook app (challengeTitle challenge) ("challenge/"
|
|
++ (challengeName challenge))
|
|
let formattingOpts = getTestFormattingOpts mainTest
|
|
|
|
let message = ("Whoa! New best result for "
|
|
++ challengeLink
|
|
++ " challenge by "
|
|
++ (fromMaybe "???" $ userName user)
|
|
++ ", "
|
|
++ (T.pack $ show $ testMetric mainTest)
|
|
++ ": "
|
|
++ (T.pack $ formatTheResult formattingOpts (SimpleRun s))
|
|
++ " ("
|
|
++ (if s > b
|
|
then "+"
|
|
else "")
|
|
++ (T.pack $ formatTheResult formattingOpts (SimpleRun (s-b)))
|
|
++ ")."
|
|
++ " See " ++ submissionLink ++ "."
|
|
++ " :clap:")
|
|
msg chan message
|
|
case mHook of
|
|
Just hook -> liftIO $ sendAnnouncement hook message
|
|
|
|
Nothing -> return ()
|
|
else return ()
|
|
[] -> return ()
|
|
Nothing -> return ()
|
|
Nothing -> return ()
|
|
|
|
if appAutoOpening $ appSettings app
|
|
then
|
|
doMakePublic userId submissionId chan
|
|
else
|
|
return ()
|
|
|
|
if not (null relevantIndicators)
|
|
then
|
|
checkIndicators user challengeId submissionId submissionLink relevantIndicators chan
|
|
else
|
|
return ()
|
|
|
|
Nothing -> return ()
|
|
|
|
checkIndicators :: User -> ChallengeId -> SubmissionId -> Text -> [IndicatorEntry] -> Channel -> Handler ()
|
|
checkIndicators user challengeId submissionId submissionLink relevantIndicators chan = do
|
|
msg chan "Checking indicators..."
|
|
theNow <- liftIO $ getCurrentTime
|
|
mapM_ (\indicator -> checkIndicator theNow user challengeId submissionId submissionLink indicator chan) relevantIndicators
|
|
|
|
checkIndicator :: UTCTime -> User -> ChallengeId -> SubmissionId -> Text -> IndicatorEntry -> Channel -> Handler ()
|
|
checkIndicator theNow user challengeId submissionId submissionLink indicator chan = do
|
|
(entries, _) <- runDB $ getChallengeSubmissionInfos 1 (\(Entity sid _) -> sid == submissionId) (const True) id challengeId
|
|
mapM_ (\t -> checkTarget theNow user submissionLink entries indicator t chan) (indicatorEntryTargets indicator)
|
|
|
|
checkTarget :: UTCTime -> User -> Text -> [TableEntry] -> IndicatorEntry -> Entity Target -> Channel -> Handler ()
|
|
checkTarget theNow user submissionLink entries indicator target chan = do
|
|
app <- getYesod
|
|
let status = getTargetStatus theNow entries indicator target
|
|
if status == TargetPassed
|
|
then
|
|
do
|
|
let message = "Congratulations!!! The target " ++ indicatorText
|
|
++ " was beaten by "
|
|
++ (fromMaybe "???" $ userName user)
|
|
++ ", "
|
|
++ " See " ++ submissionLink ++ "."
|
|
++ (T.replicate 10 " :champagne: ") ++ " :mleczko: "
|
|
msg chan message
|
|
case appAnnouncementHook $ appSettings app of
|
|
Just hook -> liftIO $ sendAnnouncement hook message
|
|
Nothing -> return ()
|
|
else
|
|
return ()
|
|
where indicatorText = prettyIndicatorEntry indicator
|
|
|
|
getScoreForOut :: (PersistQueryRead (YesodPersistBackend site), YesodPersist site, BaseBackend (YesodPersistBackend site) ~ SqlBackend) => Key Test -> Out -> HandlerFor site (Maybe Double)
|
|
getScoreForOut mainTestId out = do
|
|
mEvaluation <- runDB $ selectFirst [EvaluationChecksum ==. (outChecksum out),
|
|
EvaluationTest ==. mainTestId]
|
|
[]
|
|
return $ case mEvaluation of
|
|
Just evaluation -> evaluationScore $ entityVal evaluation
|
|
Nothing -> Nothing
|
|
|
|
getSubmission :: UserId -> Maybe TeamId -> Key Repo -> SHA1 -> Key Challenge -> Text -> Channel -> Handler (Key Submission)
|
|
getSubmission userId mTeamId repoId commit challengeId subDescription chan = do
|
|
challenge <- runDB $ get404 challengeId
|
|
maybeSubmission <- runDB $ getBy $ UniqueSubmissionRepoCommitChallenge repoId commit challengeId
|
|
case maybeSubmission of
|
|
Just (Entity submissionId _) -> do
|
|
msg chan "Submission already there, re-checking"
|
|
return submissionId
|
|
Nothing -> do
|
|
msg chan "Creating new submission"
|
|
time <- liftIO getCurrentTime
|
|
runDB $ insert $ Submission {
|
|
submissionRepo=repoId,
|
|
submissionCommit=commit,
|
|
submissionChallenge=challengeId,
|
|
submissionDescription=subDescription,
|
|
submissionStamp=time,
|
|
submissionSubmitter=userId,
|
|
submissionIsPublic=False,
|
|
submissionIsHidden=False,
|
|
submissionVersion=challengeVersion challenge,
|
|
submissionTeam=mTeamId }
|
|
|
|
getSubmissionRepo :: UserId -> Key Challenge -> RepoSpec -> Channel -> Handler (Maybe (Key Repo))
|
|
getSubmissionRepo userId challengeId repoSpec chan = getPossiblyExistingRepo checkRepoAvailibility userId challengeId repoSpec chan
|
|
|
|
checkRepoAvailibility :: Key Challenge -> Key Repo -> Channel -> Handler Bool
|
|
checkRepoAvailibility challengeId repoId chan = do
|
|
maybeOtherChallengeId <- runDB $ selectFirst ( [ChallengePublicRepo ==. repoId]
|
|
||. [ChallengePrivateRepo ==. repoId]) []
|
|
case maybeOtherChallengeId of
|
|
Just _ -> do
|
|
err chan "Repository already used as a challenge repo, please use a different repo or a different branch"
|
|
return False
|
|
Nothing -> do
|
|
maybeOtherSubmissionId <- runDB $ selectFirst [SubmissionRepo ==. repoId,
|
|
SubmissionChallenge !=. challengeId] []
|
|
case maybeOtherSubmissionId of
|
|
Just _ -> do
|
|
err chan "Repository already used as a submission repo for a different challenge, please use a different repo or a different branch"
|
|
return False
|
|
Nothing -> return True
|
|
|
|
challengeSubmissionWidget :: (ToMarkup a1, ToWidget App a2) => a2 -> a1 -> Challenge -> WidgetFor App ()
|
|
challengeSubmissionWidget formWidget formEnctype challenge = $(widgetFile "challenge-submission")
|
|
|
|
externalRepoInfo settings = $(widgetFile "external-repo")
|
|
|
|
data ChallengeSubmissionData = ChallengeSubmissionData {
|
|
challengeSubmissionDataDescription :: Maybe Text,
|
|
challengeSubmissionDataTags :: Maybe Text,
|
|
challengeSubmissionDataRepo :: RepoSpec,
|
|
challengeSubmissionDataTeam :: Maybe TeamId }
|
|
|
|
|
|
fetchUserTeams :: (YesodPersist site, BackendCompatible SqlBackend (YesodPersistBackend site), PersistQueryRead (YesodPersistBackend site), PersistUniqueRead (YesodPersistBackend site)) => Key User -> HandlerFor site [Entity Team]
|
|
fetchUserTeams userId = runDB $ E.select $ E.from $ \(team, teamMember) -> do
|
|
E.where_ (teamMember ^. TeamMemberTeam E.==. team ^. TeamId
|
|
E.&&. teamMember ^. TeamMemberUser E.==. E.val userId)
|
|
E.orderBy [E.desc (teamMember ^. TeamMemberIsCaptain), E.asc (team ^. TeamIdent)]
|
|
return team
|
|
|
|
fetchDefaultTeam :: Key User -> HandlerFor App (Maybe (Key Team))
|
|
fetchDefaultTeam userId = do
|
|
myTeams <- fetchUserTeams userId
|
|
app <- getYesod
|
|
let autoTeam = appAutoTeam $ appSettings app
|
|
if autoTeam
|
|
then
|
|
return $ entityKey <$> listToMaybe myTeams
|
|
else
|
|
return Nothing
|
|
|
|
|
|
submissionForm :: UserId -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe (Maybe TeamId) -> Form ChallengeSubmissionData
|
|
submissionForm userId defaultUrl defBranch defaultGitAnnexRemote defaultTeam = renderBootstrap3 BootstrapBasicForm $ ChallengeSubmissionData
|
|
<$> aopt textField (fieldWithTooltip MsgSubmissionDescription MsgSubmissionDescriptionTooltip) Nothing
|
|
<*> aopt textField (tagsfs MsgSubmissionTags) Nothing
|
|
<*> (RepoSpec <$> areq textField (bfs MsgSubmissionUrl) defaultUrl
|
|
<*> areq textField (bfs MsgSubmissionBranch) defBranch
|
|
<*> aopt textField (bfs MsgSubmissionGitAnnexRemote) (Just defaultGitAnnexRemote))
|
|
<*> aopt (selectField teams) (bfs MsgAsTeam) defaultTeam
|
|
where teams = do
|
|
myTeams <- fetchUserTeams userId
|
|
optionsPairs $ map (\t -> (teamIdent $ entityVal t, entityKey t)) myTeams
|
|
|
|
|
|
getUserInfoR :: Handler Value
|
|
getUserInfoR = do
|
|
(Entity _ user) <- requireAuthPossiblyByToken
|
|
return $ String $ userIdent user
|
|
|
|
getAddUserR :: Handler Value
|
|
getAddUserR = do
|
|
mInfo <- authorizationTokenAuth
|
|
case mInfo of
|
|
Just infos -> do
|
|
let ident = jwtAuthInfoIdent infos
|
|
x <- runDB $ getBy $ UniqueUser ident
|
|
case x of
|
|
Just _ -> return $ Bool False
|
|
Nothing -> do
|
|
-- family or given name can be used for a team name
|
|
-- (as an ugly work-around...), hence we look at TEAM_FIELD and when
|
|
-- it is set to "given_name" or "family_name" it is not
|
|
-- considered a part of the user's
|
|
-- name
|
|
|
|
app <- getYesod
|
|
let teamField = appTeamField $ appSettings app
|
|
|
|
let uname = intercalate " " $ catMaybes (
|
|
[if teamField /= (Just "given_name")
|
|
then jwtAuthInfoGivenName infos
|
|
else Nothing,
|
|
if teamField /= (Just "family_name")
|
|
then jwtAuthInfoFamilyName infos
|
|
else Nothing])
|
|
|
|
|
|
let mUName = if (null uname)
|
|
then Nothing
|
|
else (Just uname)
|
|
|
|
userId <- runDB $ insert User
|
|
{ userIdent = ident
|
|
, userPassword = Nothing
|
|
, userName = mUName
|
|
, userIsAdmin = False
|
|
, userLocalId = Nothing
|
|
, userIsAnonymous = False
|
|
, userAvatar = Nothing
|
|
, userVerificationKey = Nothing
|
|
, userKeyExpirationDate = Nothing
|
|
, userTriggerToken = Nothing
|
|
, userAltRepoScheme = Nothing
|
|
}
|
|
|
|
case teamField of
|
|
Just teamFieldName -> do
|
|
case jwtAuthInfoCustomField teamFieldName infos of
|
|
Just team -> do
|
|
t <- runDB $ getBy $ UniqueTeam team
|
|
(teamId, isCaptain) <- case t of
|
|
Just (Entity existingTeamId _) -> return (existingTeamId, False)
|
|
Nothing -> do
|
|
newTeamId <- runDB $ insert $ Team {teamIdent = team,
|
|
teamAvatar = Nothing}
|
|
return (newTeamId, True)
|
|
runDB $ addMemberToTeam userId teamId isCaptain
|
|
return ()
|
|
Nothing -> return ()
|
|
Nothing -> return ()
|
|
|
|
return $ Bool True
|
|
Nothing -> return $ Bool False
|
|
|
|
addUserApi :: Swagger
|
|
addUserApi = spec & definitions .~ defs
|
|
where
|
|
(defs, spec) = runDeclare declareAddUserApi mempty
|
|
|
|
declareAddUserApi :: Declare (Definitions Schema) Swagger
|
|
declareAddUserApi = do
|
|
-- param schemas
|
|
response <- declareResponse (Proxy :: Proxy Bool)
|
|
|
|
return $ mempty
|
|
& paths .~
|
|
fromList [ ("/api/add-user",
|
|
mempty & DS.get ?~ (mempty
|
|
& parameters .~ [ ]
|
|
& produces ?~ MimeList ["application/json"]
|
|
& description ?~ "Creates a new user"
|
|
& at 200 ?~ Inline response))
|
|
]
|
|
|
|
|
|
userInfoApi :: Swagger
|
|
userInfoApi = spec & definitions .~ defs
|
|
where
|
|
(defs, spec) = runDeclare declareUserInfoApi mempty
|
|
|
|
declareUserInfoApi :: Declare (Definitions Schema) Swagger
|
|
declareUserInfoApi = do
|
|
-- param schemas
|
|
response <- declareResponse (Proxy :: Proxy String)
|
|
|
|
return $ mempty
|
|
& paths .~
|
|
fromList [ ("/api/user-info",
|
|
mempty & DS.get ?~ (mempty
|
|
& parameters .~ [ ]
|
|
& produces ?~ MimeList ["application/json"]
|
|
& description ?~ "Returns the identifier of the user"
|
|
& at 200 ?~ Inline response))
|
|
]
|
|
|
|
|
|
|
|
declareAllSubmissionsApi :: String -> String -> Declare (Definitions Schema) Swagger
|
|
declareAllSubmissionsApi q d = do
|
|
-- param schemas
|
|
let challengeNameSchema = toParamSchema (Proxy :: Proxy String)
|
|
|
|
allSubmissionsResponse <- declareResponse (Proxy :: Proxy SubmissionsView)
|
|
|
|
return $ mempty
|
|
& paths .~
|
|
fromList [ ("/api/" ++ q ++ "/{challengeName}",
|
|
mempty & DS.get ?~ (mempty
|
|
& parameters .~ [ Inline $ mempty
|
|
& name .~ "challengeName"
|
|
& required ?~ True
|
|
& schema .~ ParamOther (mempty
|
|
& in_ .~ ParamPath
|
|
& paramSchema .~ challengeNameSchema) ]
|
|
& produces ?~ MimeList ["application/json"]
|
|
& description ?~ T.pack d
|
|
& at 200 ?~ Inline allSubmissionsResponse))
|
|
]
|
|
|
|
|
|
allSubmissionsApi :: Swagger
|
|
allSubmissionsApi = spec & definitions .~ defs
|
|
where
|
|
(defs, spec) = runDeclare (declareAllSubmissionsApi "challenge-all-submissions" "Returns all submissions for a challenge") mempty
|
|
|
|
mySubmissionsApi :: Swagger
|
|
mySubmissionsApi = spec & definitions .~ defs
|
|
where
|
|
(defs, spec) = runDeclare (declareAllSubmissionsApi "challenge-my-submissions" "Returns all submissions for a challenge for the user") mempty
|
|
|
|
getChallengeAllSubmissionsJsonR :: Text -> Handler Value
|
|
getChallengeAllSubmissionsJsonR challengeName = do
|
|
v <- fetchAllSubmissionsView challengeName
|
|
return $ toJSON v
|
|
|
|
getChallengeMySubmissionsJsonR :: Text -> Handler Value
|
|
getChallengeMySubmissionsJsonR challengeName = do
|
|
v <- fetchMySubmissionsView challengeName
|
|
return $ toJSON v
|
|
|
|
fetchAllSubmissionsView :: Text -> Handler SubmissionsView
|
|
fetchAllSubmissionsView challengeName = do
|
|
fetchChallengeSubmissionsView (const True) challengeName
|
|
|
|
fetchMySubmissionsView :: Text -> Handler SubmissionsView
|
|
fetchMySubmissionsView challengeName = do
|
|
Entity userId _ <- requireAuthPossiblyByToken
|
|
fetchChallengeSubmissionsView (\(Entity _ submission) -> (submissionSubmitter submission == userId)) challengeName
|
|
|
|
convertTagInfoToView :: (Entity Import.Tag, Entity SubmissionTag) -> TagView
|
|
convertTagInfoToView tagInfo =
|
|
TagView {
|
|
tagViewName = tagName $ entityVal $ fst tagInfo,
|
|
tagViewDescription = tagDescription $ entityVal $ fst tagInfo,
|
|
tagViewAccepted = submissionTagAccepted $ entityVal $ snd tagInfo
|
|
}
|
|
|
|
convertEvaluationToView :: Map TestReference Evaluation -> Entity Test -> Maybe EvaluationView
|
|
convertEvaluationToView theMapping entTest =
|
|
case join $ evaluationScore <$> mEvaluation of
|
|
Just s ->
|
|
Just $ EvaluationView {
|
|
evaluationViewScore = formatTruncatedScore formattingOps mEvaluation,
|
|
evaluationViewFullScore = s,
|
|
evaluationViewTest = testRef
|
|
}
|
|
Nothing -> Nothing
|
|
where mEvaluation = Map.lookup testRef theMapping
|
|
formattingOps = getTestFormattingOpts $ entityVal entTest
|
|
testRef = getTestReference entTest
|
|
|
|
-- convertTableEntryToView :: Maybe UserId -> [Entity Test] -> TableEntry -> SubmissionView
|
|
convertTableEntryToView :: [Entity Test] -> TableEntry -> HandlerFor App SubmissionView
|
|
convertTableEntryToView tests entry = do
|
|
mUserId <- maybeAuthPossiblyByToken
|
|
|
|
isReevaluable <- runDB $ canBeReevaluated $ entityKey $ tableEntrySubmission entry
|
|
let isVisible = True
|
|
|
|
return $ SubmissionView {
|
|
submissionViewId = fromSqlKey $ entityKey $ tableEntrySubmission entry,
|
|
submissionViewVariantId = fromSqlKey $ entityKey $ tableEntryVariant entry,
|
|
submissionViewRank = tableEntryRank entry,
|
|
submissionViewSubmitter = formatSubmitter $ entityVal $ tableEntrySubmitter entry,
|
|
submissionViewWhen = submissionStamp submission,
|
|
submissionViewVersion = tableEntryVersion entry,
|
|
submissionViewDescription = descriptionToBeShown submission
|
|
(entityVal $ tableEntryVariant entry)
|
|
(map entityVal $ tableEntryParams entry),
|
|
submissionViewTags = Import.map convertTagInfoToView $ tableEntryTagsInfo entry,
|
|
submissionViewHash = fromSHA1ToText $ submissionCommit submission,
|
|
submissionViewEvaluations = catMaybes $ Import.map (convertEvaluationToView $ tableEntryMapping entry) tests,
|
|
submissionViewIsOwner = (entityKey <$> mUserId) == Just (submissionSubmitter submission),
|
|
submissionViewIsReevaluable = isReevaluable,
|
|
submissionViewIsVisible = isVisible,
|
|
submissionViewIsPublic = submissionIsPublic submission,
|
|
submissionViewTeam = teamIdent <$> entityVal <$> tableEntryTeam entry
|
|
}
|
|
where submission = entityVal $ tableEntrySubmission entry
|
|
|
|
fetchChallengeSubmissionsView :: ((Entity Submission) -> Bool) -> Text -> Handler SubmissionsView
|
|
fetchChallengeSubmissionsView condition challengeName = do
|
|
Entity challengeId _ <- runDB $ getBy404 $ UniqueName challengeName
|
|
(evaluationMaps, tests') <- runDB $ getChallengeSubmissionInfos 1 condition (const True) id challengeId
|
|
let tests = sortBy testComparator tests'
|
|
|
|
submissions <- mapM (convertTableEntryToView tests) evaluationMaps
|
|
|
|
return $ SubmissionsView {
|
|
submissionsViewSubmissions = submissions,
|
|
submissionsViewTests = map getTestReference tests
|
|
}
|
|
|
|
|
|
-- TODO switch to fetchChallengeSubmissionSview
|
|
getChallengeMySubmissionsR :: Text -> Handler Html
|
|
getChallengeMySubmissionsR challengeName = do
|
|
userId <- requireAuthId
|
|
getChallengeSubmissions (\(Entity _ submission) -> (submissionSubmitter submission == userId)) challengeName
|
|
|
|
getChallengeAllSubmissionsR :: Text -> Handler Html
|
|
getChallengeAllSubmissionsR challengeName = getChallengeSubmissions (\_ -> True) challengeName
|
|
|
|
data EvaluationView = EvaluationView {
|
|
evaluationViewScore :: Text,
|
|
evaluationViewFullScore :: Double,
|
|
evaluationViewTest :: TestReference
|
|
}
|
|
|
|
instance ToJSON EvaluationView where
|
|
toJSON e = object
|
|
[ "score" .= evaluationViewScore e
|
|
, "full-score" .= evaluationViewFullScore e
|
|
, "test" .= evaluationViewTest e
|
|
]
|
|
|
|
instance ToSchema EvaluationView where
|
|
declareNamedSchema _ = do
|
|
stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
|
|
doubleSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Double)
|
|
testRefSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy TestReference)
|
|
return $ NamedSchema (Just "Evaluation") $ mempty
|
|
& type_ .~ SwaggerObject
|
|
& properties .~
|
|
fromList [ ("score", stringSchema)
|
|
, ("full-score", doubleSchema)
|
|
, ("test", testRefSchema)
|
|
]
|
|
& required .~ [ "score", "full-score", "test" ]
|
|
|
|
|
|
data TagView = TagView {
|
|
tagViewName :: Text,
|
|
tagViewDescription :: Maybe Text,
|
|
tagViewAccepted :: Maybe Bool }
|
|
|
|
instance ToJSON TagView where
|
|
toJSON t = object
|
|
[ "name" .= tagViewName t
|
|
, "description" .= tagViewDescription t
|
|
, "accepted" .= tagViewAccepted t
|
|
]
|
|
|
|
instance ToSchema TagView where
|
|
declareNamedSchema _ = do
|
|
stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
|
|
boolSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Bool)
|
|
return $ NamedSchema (Just "TagView") $ mempty
|
|
& type_ .~ SwaggerObject
|
|
& properties .~
|
|
fromList [ ("name", stringSchema)
|
|
, ("description", stringSchema)
|
|
, ("accepted", boolSchema)
|
|
]
|
|
& required .~ [ "name", "description" ]
|
|
|
|
|
|
data SubmissionView = SubmissionView {
|
|
submissionViewId :: Int64,
|
|
submissionViewVariantId :: Int64,
|
|
submissionViewRank :: Int,
|
|
submissionViewSubmitter :: Text,
|
|
submissionViewWhen :: UTCTime,
|
|
submissionViewVersion :: (Int, Int, Int),
|
|
submissionViewDescription :: Text,
|
|
submissionViewTags :: [TagView],
|
|
submissionViewHash :: Text,
|
|
submissionViewEvaluations :: [EvaluationView],
|
|
submissionViewIsOwner :: Bool,
|
|
submissionViewIsReevaluable :: Bool,
|
|
submissionViewIsVisible :: Bool,
|
|
submissionViewIsPublic :: Bool,
|
|
submissionViewTeam :: Maybe Text
|
|
}
|
|
|
|
instance ToJSON SubmissionView where
|
|
toJSON s = object
|
|
["id" .= submissionViewId s
|
|
, "variant" .= submissionViewVariantId s
|
|
, "rank" .= submissionViewRank s
|
|
, "submitter" .= submissionViewSubmitter s
|
|
, "when" .= submissionViewWhen s
|
|
, "version" .= submissionViewVersion s
|
|
, "description" .= submissionViewDescription s
|
|
, "tags" .= submissionViewTags s
|
|
, "hash" .= submissionViewHash s
|
|
, "evaluations" .= submissionViewEvaluations s
|
|
, "isOwner" .= submissionViewIsOwner s
|
|
, "isReevaluable" .= submissionViewIsReevaluable s
|
|
, "isVisible" .= submissionViewIsVisible s
|
|
, "isPublic" .= submissionViewIsPublic s
|
|
, "team" .= submissionViewTeam s
|
|
]
|
|
|
|
instance ToSchema SubmissionView where
|
|
declareNamedSchema _ = do
|
|
stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
|
|
boolSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Bool)
|
|
intSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Int)
|
|
tagsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [TagView])
|
|
evalsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [EvaluationView])
|
|
return $ NamedSchema (Just "SubmissionView") $ mempty
|
|
& type_ .~ SwaggerObject
|
|
& properties .~
|
|
fromList [ ("id", submissionIdSchema)
|
|
, ("variant", variantIdSchema)
|
|
, ("rank", intSchema)
|
|
, ("submitter", submitterSchema)
|
|
, ("when", stringSchema)
|
|
, ("version", versionSchema)
|
|
, ("description", stringSchema)
|
|
, ("tags", tagsSchema)
|
|
, ("hash", hashSchema)
|
|
, ("evaluations", evalsSchema)
|
|
, ("isOwner", boolSchema)
|
|
, ("isReevaluable", boolSchema)
|
|
, ("isVisible", isVisibleSchema)
|
|
, ("isPublic", isPublicSchema)
|
|
, ("team", stringSchema)
|
|
]
|
|
& required .~ [ "id", "variant", "rank", "submitter", "when", "version",
|
|
"description", "tags", "hash", "evaluations",
|
|
"isOwner", "isReevaluable", "isVisible", "isPublic" ]
|
|
|
|
data SubmissionsView = SubmissionsView {
|
|
submissionsViewSubmissions :: [SubmissionView],
|
|
submissionsViewTests :: [TestReference]
|
|
}
|
|
|
|
instance ToJSON SubmissionsView where
|
|
toJSON ss = object
|
|
[ "tests" .= submissionsViewTests ss,
|
|
"submissions" .= submissionsViewSubmissions ss
|
|
]
|
|
|
|
instance ToSchema SubmissionsView where
|
|
declareNamedSchema _ = do
|
|
submissionViewsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [SubmissionView])
|
|
testRefsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [TestReference])
|
|
return $ NamedSchema (Just "SubmissionsView") $ mempty
|
|
& type_ .~ SwaggerObject
|
|
& properties .~
|
|
fromList [ ("submissions", submissionViewsSchema)
|
|
, ("tests", testRefsSchema)
|
|
]
|
|
& required .~ [ "tests", "submission" ]
|
|
|
|
getChallengeSubmissions :: ((Entity Submission) -> Bool) -> Text -> Handler Html
|
|
getChallengeSubmissions condition challengeName = do
|
|
Entity challengeId challenge <- runDB $ getBy404 $ UniqueName challengeName
|
|
(evaluationMaps, tests') <- runDB $ getChallengeSubmissionInfos 1 condition (const True) id challengeId
|
|
let tests = sortBy testComparator tests'
|
|
mauth <- maybeAuth
|
|
let muserId = (\(Entity uid _) -> uid) <$> mauth
|
|
|
|
app <- getYesod
|
|
let scheme = appRepoScheme $ appSettings app
|
|
|
|
challengeRepo <- runDB $ get404 $ challengePublicRepo challenge
|
|
|
|
let params = getNumericalParams evaluationMaps
|
|
|
|
challengeLayout True challenge (challengeAllSubmissionsWidget muserId
|
|
challenge
|
|
scheme
|
|
challengeRepo
|
|
evaluationMaps
|
|
tests
|
|
params)
|
|
|
|
getNumericalParams :: [TableEntry] -> [Text]
|
|
getNumericalParams entries = filter (isNumericalParam entries) $ getAllParams entries
|
|
|
|
isNumericalParam :: [TableEntry] -> Text -> Bool
|
|
isNumericalParam entries param =
|
|
all doesTextRepresentNumber
|
|
$ concat
|
|
$ map ((map parameterValue)
|
|
. (filter (\p -> parameterName p == param))
|
|
. (map entityVal)
|
|
. tableEntryParams) entries
|
|
|
|
doesTextRepresentNumber :: Text -> Bool
|
|
doesTextRepresentNumber t = isJust $ ((TR.readMaybe $ T.unpack t) :: Maybe Double)
|
|
|
|
getAllParams :: [TableEntry] -> [Text]
|
|
getAllParams entries = sort
|
|
$ nub
|
|
$ concat
|
|
$ map (\entry -> map (parameterName . entityVal) (tableEntryParams entry)) entries
|
|
|
|
|
|
challengeAllSubmissionsWidget :: Maybe UserId
|
|
-> Challenge
|
|
-> RepoScheme
|
|
-> Repo
|
|
-> [TableEntry]
|
|
-> [Entity Test]
|
|
-> [Text]
|
|
-> WidgetFor App ()
|
|
challengeAllSubmissionsWidget muserId challenge scheme challengeRepo submissions tests params =
|
|
$(widgetFile "challenge-all-submissions")
|
|
where delta = Number 4
|
|
higherTheBetterArray = getIsHigherTheBetterArray $ map entityVal tests
|
|
|
|
paramGraphsWidget :: Challenge -> [Entity Test] -> [Text] -> WidgetFor App ()
|
|
paramGraphsWidget challenge tests params = $(widgetFile "param-graphs")
|
|
where chartJSs = getChartJss challenge selectedTests params
|
|
selectedTests = reverse $ getMainTests tests
|
|
|
|
getChartJss :: Challenge -> [Entity Test] -> [Text] -> JavascriptUrl (Route App)
|
|
getChartJss challenge tests params =
|
|
mconcat $ [(getChartJs challenge test param) | test <- tests, param <- params]
|
|
|
|
getChartJs :: Challenge
|
|
-> Entity Test
|
|
-> Text
|
|
-> JavascriptUrl (Route App)
|
|
getChartJs challenge (Entity testId test) param = [julius|
|
|
$.getJSON("@{ChallengeParamGraphDataR (challengeName challenge) testId param}", function(data) {
|
|
c3.generate({
|
|
bindto: '#chart-' + #{toJSON param} + '-' + #{toJSON testId},
|
|
data: data,
|
|
axis: {
|
|
x: {
|
|
label: #{toJSON param},
|
|
},
|
|
y: {
|
|
label: #{toJSON testFormatted},
|
|
}
|
|
}
|
|
}) });
|
|
|]
|
|
where testFormatted = formatTest test
|
|
|
|
|
|
challengeLayout :: Bool -> Challenge -> WidgetFor App () -> HandlerFor App Html
|
|
challengeLayout withHeader challenge widget = do
|
|
tagsAvailableAsJSON <- runDB $ getAvailableTagsAsJSON
|
|
theVersion <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
|
|
let versionFormatted = formatVersion ((versionMajor $ entityVal theVersion),
|
|
(versionMinor $ entityVal theVersion),
|
|
(versionPatch $ entityVal theVersion))
|
|
maybeUser <- maybeAuth
|
|
bc <- widgetToPageContent widget
|
|
defaultLayout $ do
|
|
setTitle "Challenge"
|
|
$(widgetFile "challenge")
|
|
|
|
getTestProgressR :: Int -> Int -> Handler TypedContent
|
|
getTestProgressR m d = runViewProgress $ doTestProgress m d
|
|
|
|
getTestProgressJsonR :: Int -> Int -> Handler Value
|
|
getTestProgressJsonR m d = do
|
|
_ <- requireAuthPossiblyByToken
|
|
runViewProgressAsynchronously $ doTestProgress m d
|
|
|
|
declareTestProgressSwagger :: Declare (Definitions Schema) Swagger
|
|
declareTestProgressSwagger = do
|
|
-- param schemas
|
|
let numberSchema = toParamSchema (Proxy :: Proxy Int)
|
|
|
|
numberResponse <- declareResponse (Proxy :: Proxy Int)
|
|
|
|
return $ mempty
|
|
& paths .~
|
|
fromList [ ("/api/test-progress/{num}/{delay}",
|
|
mempty & DS.get ?~ (mempty
|
|
& parameters .~ [ Inline $ mempty
|
|
& name .~ "num"
|
|
& description ?~ "The number up to which to count"
|
|
& required ?~ True
|
|
& schema .~ ParamOther (mempty
|
|
& in_ .~ ParamPath
|
|
& paramSchema .~ numberSchema),
|
|
Inline $ mempty
|
|
& name .~ "delay"
|
|
& description ?~ "Delay in seconds"
|
|
& required ?~ True
|
|
& schema .~ ParamOther (mempty
|
|
& in_ .~ ParamPath
|
|
& paramSchema .~ numberSchema)
|
|
]
|
|
& produces ?~ MimeList ["application/json"]
|
|
& description ?~ "Counts up to a given number, returns an ID of an asynchronous job. This is just a sample end-point for testing logging of asynchronous jobs."
|
|
& at 200 ?~ Inline numberResponse))
|
|
]
|
|
|
|
testProgressApi :: Swagger
|
|
testProgressApi = spec & definitions .~ defs
|
|
where
|
|
(defs, spec) = runDeclare declareTestProgressSwagger mempty
|
|
|
|
|
|
doTestProgress :: Int -> Int -> Channel -> Handler ()
|
|
doTestProgress m d chan = do
|
|
_ <- forM [1..m] $ (\i -> do
|
|
msg chan $ (Data.Text.pack $ ("GO\n" ++ show i))
|
|
liftIO $ threadDelay (d * 1000000)
|
|
return ())
|
|
return ()
|
|
|
|
|
|
declareViewProgressWithWebSocketsSwagger :: Declare (Definitions Schema) Swagger
|
|
declareViewProgressWithWebSocketsSwagger = do
|
|
-- param schemas
|
|
let numberSchema = toParamSchema (Proxy :: Proxy Int)
|
|
|
|
numberResponse <- declareResponse (Proxy :: Proxy Int)
|
|
|
|
return $ mempty
|
|
& paths .~
|
|
fromList [ ("/api/view-progress-with-web-sockets/{jobId}",
|
|
mempty & DS.get ?~ (mempty
|
|
& parameters .~ [ Inline $ mempty
|
|
& name .~ "jobId"
|
|
& description ?~ "The ID for the job to be shown"
|
|
& required ?~ True
|
|
& schema .~ ParamOther (mempty
|
|
& in_ .~ ParamPath
|
|
& paramSchema .~ numberSchema)]
|
|
& produces ?~ MimeList ["application/json"]
|
|
& description ?~ "Initiates a web socket communication with which progress logs can be read. Returns just the Job ID (the same number as the parameter)"
|
|
& at 200 ?~ Inline numberResponse))
|
|
]
|
|
|
|
viewProgressWithWebSockets :: Swagger
|
|
viewProgressWithWebSockets = spec & definitions .~ defs
|
|
where
|
|
(defs, spec) = runDeclare declareViewProgressWithWebSocketsSwagger mempty
|
|
|
|
|
|
declareViewProgressLogSwagger :: Declare (Definitions Schema) Swagger
|
|
declareViewProgressLogSwagger = do
|
|
let numberSchema = toParamSchema (Proxy :: Proxy Int)
|
|
|
|
numberResponse <- declareResponse (Proxy :: Proxy Int)
|
|
|
|
return $ mempty
|
|
& paths .~
|
|
fromList [ ("/api/view-progress-log/{jobId}",
|
|
mempty & DS.get ?~ (mempty
|
|
& parameters .~ [ Inline $ mempty
|
|
& name .~ "jobId"
|
|
& description ?~ "The ID for the job to be shown"
|
|
& required ?~ True
|
|
& schema .~ ParamOther (mempty
|
|
& in_ .~ ParamPath
|
|
& paramSchema .~ numberSchema)]
|
|
& produces ?~ MimeList ["text/html"]
|
|
& description ?~ "Returns HTML code with embedded JS script for showing logs via web sockets"
|
|
& at 200 ?~ Inline numberResponse))
|
|
]
|
|
|
|
viewProgressLog :: Swagger
|
|
viewProgressLog = spec & definitions .~ defs
|
|
where
|
|
(defs, spec) = runDeclare declareViewProgressLogSwagger mempty
|