600 lines
24 KiB
Haskell
600 lines
24 KiB
Haskell
module Handler.ShowChallenge where
|
|
|
|
import Import
|
|
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.Map.Strict as M
|
|
|
|
import qualified Yesod.Table as Table
|
|
|
|
import Handler.Extract
|
|
import Handler.Shared
|
|
import Handler.Runner
|
|
import Handler.Tables
|
|
import Handler.TagUtils
|
|
import Handler.MakePublic
|
|
|
|
import GEval.Core
|
|
import GEval.OptionsParser
|
|
import GEval.ParseParams (parseParamsFromFilePath, OutputFileParsed(..))
|
|
|
|
import PersistSHA1
|
|
|
|
import Options.Applicative
|
|
|
|
import System.IO (readFile)
|
|
|
|
import System.FilePath (takeFileName, dropExtensions)
|
|
|
|
import Data.Attoparsec.Text
|
|
|
|
import Data.Text (pack, unpack)
|
|
|
|
import Data.Conduit.SmartSource
|
|
|
|
import Data.List (nub)
|
|
|
|
getShowChallengeR :: Text -> Handler Html
|
|
getShowChallengeR name = do
|
|
(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
|
|
Just repo <- runDB $ get $ challengePublicRepo challenge
|
|
(mainTest, leaderboard, (entries, tests)) <- getLeaderboardEntries challengeId
|
|
mauth <- maybeAuth
|
|
let muserId = (\(Entity uid _) -> uid) <$> mauth
|
|
|
|
let params = getAllParams entries
|
|
|
|
app <- getYesod
|
|
let scheme = appRepoScheme $ appSettings app
|
|
|
|
challengeRepo <- runDB $ get404 $ challengePublicRepo challenge
|
|
|
|
challengeLayout True challenge (showChallengeWidget muserId
|
|
challenge scheme
|
|
challengeRepo
|
|
mainTest
|
|
repo
|
|
leaderboard
|
|
params
|
|
tests)
|
|
|
|
getChallengeReadmeR :: Text -> Handler Html
|
|
getChallengeReadmeR name = do
|
|
(Entity _ challenge) <- runDB $ getBy404 $ UniqueName name
|
|
readme <- challengeReadme name
|
|
challengeLayout False challenge $ toWidget readme
|
|
|
|
challengeReadme :: Text -> HandlerFor App Html
|
|
challengeReadme name = do
|
|
(Entity _ challenge) <- runDB $ getBy404 $ UniqueName name
|
|
let repoId = challengePublicRepo challenge
|
|
repoDir <- getRepoDir repoId
|
|
let readmeFilePath = repoDir </> readmeFile
|
|
contents <- liftIO $ System.IO.readFile readmeFilePath
|
|
return $ markdown def $ TL.pack contents
|
|
|
|
showChallengeWidget :: Maybe UserId
|
|
-> Challenge
|
|
-> RepoScheme
|
|
-> Repo
|
|
-> Test
|
|
-> Repo
|
|
-> [LeaderboardEntry]
|
|
-> [Text]
|
|
-> [Entity Test]
|
|
-> WidgetFor App ()
|
|
showChallengeWidget muserId
|
|
challenge
|
|
scheme
|
|
challengeRepo
|
|
test
|
|
repo
|
|
leaderboard
|
|
params
|
|
tests
|
|
= $(widgetFile "show-challenge")
|
|
where leaderboardWithRanks = zip [1..] leaderboard
|
|
maybeRepoLink = getRepoLink repo
|
|
|
|
getRepoLink :: Repo -> Maybe Text
|
|
getRepoLink repo
|
|
| sitePrefix `isPrefixOf` url = Just $ (browsableGitRepo bareRepoName) ++ "/" ++ (repoBranch repo)
|
|
| otherwise = Nothing
|
|
where sitePrefix = "git://gonito.net/" :: Text
|
|
sitePrefixLen = length sitePrefix
|
|
url = repoUrl repo
|
|
bareRepoName = drop sitePrefixLen url
|
|
|
|
getChallengeHowToR :: Text -> Handler Html
|
|
getChallengeHowToR name = do
|
|
(Entity _ challenge) <- runDB $ getBy404 $ UniqueName name
|
|
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
|
|
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
|
|
|
|
defaultRepo :: RepoScheme -> Challenge -> Repo -> Maybe (Entity User) -> Text
|
|
defaultRepo SelfHosted challenge _ maybeUser = "ssh://gitolite@gonito.net/" ++ (idToBeShown challenge maybeUser) ++ "/" ++ (challengeName challenge)
|
|
defaultRepo Branches _ repo _ = repoUrl repo
|
|
|
|
defaultBranch :: IsString a => RepoScheme -> Maybe a
|
|
defaultBranch SelfHosted = Just "master"
|
|
defaultBranch Branches = Nothing
|
|
|
|
challengeHowTo challenge settings repo shownId isIDSet isSSHUploaded mToken = $(widgetFile "challenge-how-to")
|
|
|
|
getChallengeSubmissionR :: Text -> Handler Html
|
|
getChallengeSubmissionR name = do
|
|
(Entity _ challenge) <- runDB $ getBy404 $ UniqueName name
|
|
maybeUser <- maybeAuth
|
|
|
|
Just repo <- runDB $ get $ challengePublicRepo challenge
|
|
app <- getYesod
|
|
let scheme = appRepoScheme $ appSettings app
|
|
|
|
(formWidget, formEnctype) <- generateFormPost $ submissionForm (Just $ defaultRepo scheme challenge repo maybeUser) (defaultBranch scheme) (repoGitAnnexRemote repo)
|
|
challengeLayout True challenge $ challengeSubmissionWidget formWidget formEnctype challenge
|
|
|
|
postChallengeSubmissionR :: Text -> Handler TypedContent
|
|
postChallengeSubmissionR name = do
|
|
(Entity challengeId _) <- runDB $ getBy404 $ UniqueName name
|
|
((result, _), _) <- runFormPost $ submissionForm Nothing Nothing Nothing
|
|
let submissionData = case result of
|
|
FormSuccess res -> Just res
|
|
_ -> Nothing
|
|
Just (mDescription, mTags, submissionUrl, submissionBranch, submissionGitAnnexRemote) = submissionData
|
|
|
|
userId <- requireAuthId
|
|
runViewProgress $ doCreateSubmission userId challengeId mDescription mTags RepoSpec {
|
|
repoSpecUrl=submissionUrl,
|
|
repoSpecBranch=submissionBranch,
|
|
repoSpecGitAnnexRemote=submissionGitAnnexRemote}
|
|
|
|
postTriggerLocallyR :: Handler TypedContent
|
|
postTriggerLocallyR = do
|
|
(Just challengeName) <- lookupPostParam "challenge"
|
|
(Just localId) <- lookupPostParam "user"
|
|
mBranch <- lookupPostParam "branch"
|
|
[Entity userId _] <- runDB $ selectList [UserLocalId ==. Just localId] []
|
|
let localRepo = gitServer ++ localId ++ "/" ++ challengeName
|
|
trigger userId challengeName localRepo mBranch
|
|
|
|
postTriggerRemotelyR :: Handler TypedContent
|
|
postTriggerRemotelyR = do
|
|
(Just challengeName) <- lookupPostParam "challenge"
|
|
(Just url) <- lookupPostParam "url"
|
|
(Just token) <- lookupPostParam "token"
|
|
mBranch <- lookupPostParam "branch"
|
|
[Entity userId _] <- runDB $ selectList [UserTriggerToken ==. Just token] []
|
|
trigger userId challengeName url mBranch
|
|
|
|
trigger :: UserId -> Text -> Text -> Maybe Text -> Handler TypedContent
|
|
trigger userId challengeName url mBranch = do
|
|
let branch = fromMaybe "master" mBranch
|
|
mChallengeEnt <- runDB $ getBy $ UniqueName challengeName
|
|
case mChallengeEnt of
|
|
Just (Entity challengeId _) -> runOpenViewProgress $ doCreateSubmission userId challengeId
|
|
Nothing Nothing
|
|
RepoSpec {repoSpecUrl=url,
|
|
repoSpecBranch=branch,
|
|
repoSpecGitAnnexRemote=Nothing}
|
|
Nothing -> return $ toTypedContent (("Unknown challenge `" ++ (Data.Text.unpack challengeName) ++ "`. Cannot be triggered, must be submitted manually at Gonito.net!\n") :: String)
|
|
|
|
doCreateSubmission :: UserId -> Key Challenge -> Maybe Text -> Maybe Text -> RepoSpec -> Channel -> Handler ()
|
|
doCreateSubmission userId challengeId mDescription mTags repoSpec chan = do
|
|
maybeRepoKey <- getSubmissionRepo challengeId repoSpec chan
|
|
case maybeRepoKey of
|
|
Just repoId -> do
|
|
repo <- runDB $ get404 repoId
|
|
|
|
repoDir <- getRepoDir repoId
|
|
commitMessage <- getLastCommitMessage repoDir chan
|
|
let (mCommitDescription, mCommitTags) = parseCommitMessage commitMessage
|
|
|
|
submissionId <- getSubmission userId repoId (repoCurrentCommit repo) challengeId (fromMaybe (fromMaybe "???" mCommitDescription) mDescription) chan
|
|
_ <- getOuts chan submissionId
|
|
|
|
runDB $ addTags submissionId (if isNothing mTags then mCommitTags else mTags) []
|
|
msg chan "SUBMISSION CREATED"
|
|
|
|
app <- getYesod
|
|
if appAutoOpening $ appSettings app
|
|
then
|
|
doMakePublic submissionId chan
|
|
else
|
|
return ()
|
|
Nothing -> return ()
|
|
|
|
getSubmission :: UserId -> Key Repo -> SHA1 -> Key Challenge -> Text -> Channel -> Handler (Key Submission)
|
|
getSubmission userId repoId commit challengeId description chan = do
|
|
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=description,
|
|
submissionStamp=time,
|
|
submissionSubmitter=userId,
|
|
submissionIsPublic=False,
|
|
submissionIsHidden=Just False }
|
|
|
|
parseCommitMessage :: Maybe Text -> (Maybe Text, Maybe Text)
|
|
parseCommitMessage Nothing = (Nothing, Nothing)
|
|
parseCommitMessage (Just commitMessage) =
|
|
case parseOnly commitMessageParser commitMessage of
|
|
Left _ -> (Nothing, Nothing)
|
|
Right (d, ts) -> (d, ts)
|
|
|
|
commitMessageParser :: Data.Attoparsec.Text.Parser (Maybe Text, Maybe Text)
|
|
commitMessageParser = do
|
|
skipMany emptyLine
|
|
d <- nonEmptyLine
|
|
mTs <- (do
|
|
ts <- findTagsLine
|
|
return $ Just ts) <|> (return Nothing)
|
|
return (Just d, mTs)
|
|
|
|
findTagsLine :: Data.Attoparsec.Text.Parser Text
|
|
findTagsLine = tagsLine <|> (anyLine >> findTagsLine)
|
|
|
|
tagsLine :: Data.Attoparsec.Text.Parser Text
|
|
tagsLine = do
|
|
_ <- (string "tags" <|> string "labels" <|> string "Tags" <|> string "Labels")
|
|
_ <- char ':'
|
|
skipMany space
|
|
s <- many notEndOfLine
|
|
endOfLine
|
|
return $ Data.Text.pack s
|
|
|
|
commaSep :: Data.Attoparsec.Text.Parser a -> Data.Attoparsec.Text.Parser [a]
|
|
commaSep p = p `sepBy` (skipMany space *> char ',' *> skipMany space)
|
|
|
|
nonEmptyLine :: Data.Attoparsec.Text.Parser Text
|
|
nonEmptyLine = do
|
|
skipMany space
|
|
l1 <- notSpace
|
|
l <- (many notEndOfLine)
|
|
endOfLine
|
|
return $ Data.Text.pack (l1:l)
|
|
|
|
anyLine :: Data.Attoparsec.Text.Parser ()
|
|
anyLine = do
|
|
skipMany notEndOfLine
|
|
endOfLine
|
|
|
|
notSpace :: Data.Attoparsec.Text.Parser Char
|
|
notSpace = satisfy (\c -> c /= '\r' && c /= '\n' && c /= ' ' && c /= '\t')
|
|
|
|
notEndOfLine :: Data.Attoparsec.Text.Parser Char
|
|
notEndOfLine = satisfy (\c -> c /= '\r' && c /= '\n')
|
|
|
|
emptyLine :: Data.Attoparsec.Text.Parser ()
|
|
emptyLine = do
|
|
many space *> endOfLine
|
|
|
|
getOuts :: Channel -> Key Submission -> Handler ([Out])
|
|
getOuts chan submissionId = do
|
|
submission <- runDB $ get404 submissionId
|
|
let challengeId = submissionChallenge submission
|
|
repoDir <- getRepoDir $ submissionRepo submission
|
|
activeTests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] []
|
|
|
|
outs' <- mapM (outsForTest repoDir submissionId) activeTests
|
|
let outs = concat outs'
|
|
|
|
mapM_ checkOrInsertOut outs
|
|
mapM_ (checkOrInsertEvaluation repoDir chan) outs
|
|
return outs
|
|
|
|
outFileName :: FilePath
|
|
outFileName = "out.tsv"
|
|
|
|
getOutFilePath :: FilePath -> Test -> FilePath
|
|
getOutFilePath repoDir test = repoDir </> (T.unpack $ testName test) </> outFileName
|
|
|
|
findOutFile :: FilePath -> Test -> IO (Maybe FilePath)
|
|
findOutFile repoDir test = do
|
|
let baseOut = getOutFilePath repoDir test
|
|
findFilePossiblyCompressed baseOut
|
|
|
|
doesOutExist :: FilePath -> Entity Test -> IO Bool
|
|
doesOutExist repoDir (Entity _ test) = do
|
|
result <- findOutFile repoDir test
|
|
return $ isJust result
|
|
|
|
outForTest :: MonadIO m => FilePath -> FilePath -> Key Variant -> Entity Test -> m Out
|
|
outForTest repoDir outF variantId (Entity testId test) = do
|
|
let outPath = repoDir </> (T.unpack $ testName test) </> outF
|
|
checksum <- liftIO $ gatherSHA1ForCollectionOfFiles [outPath]
|
|
return Out {
|
|
outVariant=variantId,
|
|
outTest=testId,
|
|
outChecksum=SHA1 checksum }
|
|
|
|
outsForTest :: FilePath -> SubmissionId -> Entity Test -> HandlerFor App [Out]
|
|
outsForTest repoDir submissionId testEnt@(Entity _ test) = do
|
|
outFiles <- liftIO $ outFilesForTest repoDir test
|
|
|
|
forM outFiles $ \outFile -> do
|
|
theVariant <- getVariant submissionId outFile
|
|
outForTest repoDir outFile theVariant testEnt
|
|
|
|
-- returns the filename (not file path)
|
|
outFilesForTest :: FilePath -> Test -> IO [FilePath]
|
|
outFilesForTest repoDir test = do
|
|
mMultipleOuts <- checkMultipleOutsCore repoDir (Data.Text.unpack $ testName test) "out.tsv"
|
|
case mMultipleOuts of
|
|
Just outFiles -> return $ map takeFileName outFiles
|
|
Nothing -> do
|
|
mOutFile <- findOutFile repoDir test
|
|
case mOutFile of
|
|
Just outF -> return [takeFileName outF]
|
|
Nothing -> return []
|
|
|
|
getVariant :: SubmissionId -> FilePath -> Handler VariantId
|
|
getVariant submissionId outFilePath = runDB $ do
|
|
let outFile = takeFileName outFilePath
|
|
let name = Data.Text.pack $ dropExtensions outFile
|
|
maybeVariant <- getBy $ UniqueVariantSubmissionName submissionId name
|
|
case maybeVariant of
|
|
Just (Entity vid _) -> return vid
|
|
Nothing -> do
|
|
vid <- insert $ Variant submissionId name
|
|
let (OutputFileParsed _ paramMap) = parseParamsFromFilePath outFile
|
|
forM_ (M.toList paramMap) $ \(param, val) -> do
|
|
_ <- insert $ Parameter vid param val
|
|
return ()
|
|
return vid
|
|
|
|
checkOrInsertOut :: Out -> Handler ()
|
|
checkOrInsertOut out = do
|
|
maybeOut <- runDB $ getBy $ UniqueOutVariantTestChecksum (outVariant out) (outTest out) (outChecksum out)
|
|
case maybeOut of
|
|
Just _ -> return ()
|
|
Nothing -> (runDB $ insert out) >> return ()
|
|
|
|
checkOrInsertEvaluation :: FilePath -> Channel -> Out -> Handler ()
|
|
checkOrInsertEvaluation repoDir chan out = do
|
|
test <- runDB $ get404 $ outTest out
|
|
challenge <- runDB $ get404 $ testChallenge test
|
|
maybeEvaluation <- runDB $ getBy $ UniqueEvaluationTestChecksum (outTest out) (outChecksum out)
|
|
case maybeEvaluation of
|
|
Just (Entity _ evaluation) -> do
|
|
msg chan $ concat ["Already evaluated with score ", (T.pack $ fromMaybe "???" $ show <$> evaluationScore evaluation)]
|
|
Nothing -> do
|
|
msg chan $ "Start evaluation..."
|
|
challengeDir <- getRepoDir $ challengePrivateRepo challenge
|
|
variant <- runDB $ get404 $ outVariant out
|
|
resultOrException <- liftIO $ rawEval challengeDir (testMetric test) repoDir (testName test) ((T.unpack $ variantName variant) <.> "tsv")
|
|
case resultOrException of
|
|
Right (Left _) -> do
|
|
err chan "Cannot parse options, check the challenge repo"
|
|
Right (Right (_, Just [(_, [result])])) -> do
|
|
msg chan $ concat [ "Evaluated! Score ", (T.pack $ show result) ]
|
|
time <- liftIO getCurrentTime
|
|
_ <- runDB $ insert $ Evaluation {
|
|
evaluationTest=outTest out,
|
|
evaluationChecksum=outChecksum out,
|
|
evaluationScore=Just result,
|
|
evaluationErrorMessage=Nothing,
|
|
evaluationStamp=time }
|
|
msg chan "Evaluation done"
|
|
Right (Right (_, Just _)) -> do
|
|
err chan "Unexpected multiple results (???)"
|
|
Right (Right (_, Nothing)) -> do
|
|
err chan "Error during the evaluation"
|
|
Left exception -> do
|
|
err chan $ "Evaluation failed: " ++ (T.pack $ show exception)
|
|
|
|
rawEval :: FilePath -> Metric -> FilePath -> Text -> FilePath -> IO (Either GEvalException (Either (ParserResult GEvalOptions) (GEvalOptions, Maybe [(SourceSpec, [MetricValue])])))
|
|
rawEval challengeDir metric repoDir name outF = Import.try (runGEvalGetOptions [
|
|
"--alt-metric", (show metric),
|
|
"--expected-directory", challengeDir,
|
|
"--out-directory", repoDir,
|
|
"--out-file", outF,
|
|
"--test-name", (T.unpack name)])
|
|
|
|
getSubmissionRepo :: Key Challenge -> RepoSpec -> Channel -> Handler (Maybe (Key Repo))
|
|
getSubmissionRepo challengeId repoSpec chan = do
|
|
let url = repoSpecUrl repoSpec
|
|
let branch = repoSpecBranch repoSpec
|
|
let gitAnnexRemote = repoSpecGitAnnexRemote repoSpec
|
|
maybeRepo <- runDB $ getBy $ UniqueUrlBranch url branch
|
|
case maybeRepo of
|
|
Just (Entity repoId _) -> do
|
|
msg chan "Repo already there"
|
|
available <- checkRepoAvailibility challengeId repoId chan
|
|
if available
|
|
then
|
|
do
|
|
-- this is not completely right... some other thread
|
|
-- might update this to a different value
|
|
runDB $ update repoId [RepoGitAnnexRemote =. gitAnnexRemote]
|
|
updateStatus <- updateRepo repoId chan
|
|
if updateStatus
|
|
then
|
|
return $ Just repoId
|
|
else
|
|
return Nothing
|
|
else
|
|
return Nothing
|
|
Nothing -> do
|
|
challenge <- runDB $ get404 challengeId
|
|
let repoId = challengePublicRepo challenge
|
|
repo <- runDB $ get404 repoId
|
|
repoDir <- getRepoDir repoId
|
|
let repoCloningSpec = RepoCloningSpec {
|
|
cloningSpecRepo = repoSpec,
|
|
cloningSpecReferenceRepo = RepoSpec {
|
|
repoSpecUrl = (T.pack repoDir),
|
|
repoSpecBranch = (repoBranch repo),
|
|
repoSpecGitAnnexRemote = Nothing
|
|
}
|
|
}
|
|
cloneRepo' repoCloningSpec 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 formWidget formEnctype challenge = $(widgetFile "challenge-submission")
|
|
|
|
submissionForm :: Maybe Text -> Maybe Text -> Maybe Text -> Form (Maybe Text, Maybe Text, Text, Text, Maybe Text)
|
|
submissionForm defaultUrl defBranch defaultGitAnnexRemote = renderBootstrap3 BootstrapBasicForm $ (,,,,)
|
|
<$> aopt textField (fieldWithTooltip MsgSubmissionDescription MsgSubmissionDescriptionTooltip) Nothing
|
|
<*> aopt textField (tagsfs MsgSubmissionTags) Nothing
|
|
<*> areq textField (bfs MsgSubmissionUrl) defaultUrl
|
|
<*> areq textField (bfs MsgSubmissionBranch) defBranch
|
|
<*> aopt textField (bfs MsgSubmissionGitAnnexRemote) (Just defaultGitAnnexRemote)
|
|
|
|
getChallengeMySubmissionsR :: Text -> Handler Html
|
|
getChallengeMySubmissionsR name = do
|
|
userId <- requireAuthId
|
|
getChallengeSubmissions (\(Entity _ submission) -> (submissionSubmitter submission == userId)) name
|
|
|
|
getChallengeAllSubmissionsR :: Text -> Handler Html
|
|
getChallengeAllSubmissionsR name = getChallengeSubmissions (\_ -> True) name
|
|
|
|
getChallengeSubmissions :: ((Entity Submission) -> Bool) -> Text -> Handler Html
|
|
getChallengeSubmissions condition name = do
|
|
Entity challengeId challenge <- runDB $ getBy404 $ UniqueName name
|
|
(evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId
|
|
mauth <- maybeAuth
|
|
let muserId = (\(Entity uid _) -> uid) <$> mauth
|
|
|
|
app <- getYesod
|
|
let scheme = appRepoScheme $ appSettings app
|
|
|
|
challengeRepo <- runDB $ get404 $ challengePublicRepo challenge
|
|
|
|
let params = getAllParams evaluationMaps
|
|
|
|
challengeLayout True challenge (challengeAllSubmissionsWidget muserId
|
|
challenge
|
|
scheme
|
|
challengeRepo
|
|
evaluationMaps
|
|
tests
|
|
params)
|
|
|
|
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")
|
|
|
|
paramGraphsWidget :: Challenge -> [Entity Test] -> [Text] -> WidgetFor App ()
|
|
paramGraphsWidget challenge tests params = $(widgetFile "param-graphs")
|
|
where chartJSs = getCharsJss challenge selectedTests params
|
|
selectedTests = getMainTests tests
|
|
|
|
getCharsJss :: Challenge -> [Entity Test] -> [Text] -> JavascriptUrl (Route App)
|
|
getCharsJss 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
|
|
maybeUser <- maybeAuth
|
|
bc <- widgetToPageContent widget
|
|
defaultLayout $ do
|
|
setTitle "Challenge"
|
|
$(widgetFile "challenge")
|