2015-09-04 23:23:32 +02:00
module Handler.ShowChallenge where
import Import
2018-07-05 22:17:25 +02:00
import Yesod.Form.Bootstrap3 ( BootstrapFormLayout ( .. ) , renderBootstrap3 , bfs )
2015-09-04 23:23:32 +02:00
2015-09-29 22:31:56 +02:00
2017-09-22 14:23:03 +02:00
import qualified Data.Text.Lazy as TL
2015-09-06 14:24:49 +02:00
import Text.Markdown
2015-09-29 14:15:49 +02:00
import qualified Data.Text as T
2018-07-14 15:27:49 +02:00
import qualified Data.Map.Strict as M
2015-09-29 14:15:49 +02:00
2015-12-12 18:53:20 +01:00
import qualified Yesod.Table as Table
2015-09-06 14:24:49 +02:00
import Handler.Extract
import Handler.Shared
2018-06-05 08:22:51 +02:00
import Handler.Runner
2015-12-12 18:53:20 +01:00
import Handler.Tables
2017-09-27 19:38:42 +02:00
import Handler.TagUtils
2018-07-24 15:33:35 +02:00
import Handler.MakePublic
2015-09-06 14:24:49 +02:00
2018-09-01 14:23:41 +02:00
import qualified Text.Read as TR
2015-09-29 18:23:11 +02:00
import GEval.Core
import GEval.OptionsParser
2018-07-14 15:27:49 +02:00
import GEval.ParseParams ( parseParamsFromFilePath , OutputFileParsed ( .. ) )
2015-09-29 22:31:56 +02:00
2015-09-29 14:15:49 +02:00
import PersistSHA1
2015-11-11 09:50:32 +01:00
import Options.Applicative
2017-09-22 14:23:03 +02:00
import System.IO ( readFile )
2018-07-14 15:27:49 +02:00
import System.FilePath ( takeFileName , dropExtensions )
2017-09-27 22:44:00 +02:00
import Data.Attoparsec.Text
2017-09-28 16:11:22 +02:00
import Data.Text ( pack , unpack )
2017-09-27 22:44:00 +02:00
2018-06-29 08:05:33 +02:00
import Data.Conduit.SmartSource
2018-07-28 17:04:27 +02:00
import Data.List ( nub )
2015-09-04 23:23:32 +02:00
getShowChallengeR :: Text -> Handler Html
getShowChallengeR name = do
2015-12-12 18:53:20 +01:00
( Entity challengeId challenge ) <- runDB $ getBy404 $ UniqueName name
2015-09-28 17:45:10 +02:00
Just repo <- runDB $ get $ challengePublicRepo challenge
2018-07-28 22:10:55 +02:00
( mainTest , leaderboard , ( entries , tests ) ) <- getLeaderboardEntries challengeId
2016-02-16 21:10:10 +01:00
mauth <- maybeAuth
let muserId = ( \ ( Entity uid _ ) -> uid ) <$> mauth
2018-06-06 13:43:17 +02:00
2018-09-01 14:23:41 +02:00
let params = getNumericalParams entries
2018-07-28 22:10:55 +02:00
2018-06-06 13:43:17 +02:00
app <- getYesod
let scheme = appRepoScheme $ appSettings app
challengeRepo <- runDB $ get404 $ challengePublicRepo challenge
2018-07-28 21:36:45 +02:00
challengeLayout True challenge ( showChallengeWidget muserId
challenge scheme
challengeRepo
mainTest
repo
2018-07-28 22:10:55 +02:00
leaderboard
params
tests )
2015-09-06 14:24:49 +02:00
getChallengeReadmeR :: Text -> Handler Html
getChallengeReadmeR name = do
2016-05-16 23:44:28 +02:00
( Entity _ challenge ) <- runDB $ getBy404 $ UniqueName name
readme <- challengeReadme name
challengeLayout False challenge $ toWidget readme
2018-07-14 07:42:28 +02:00
challengeReadme :: Text -> HandlerFor App Html
2016-05-16 23:44:28 +02:00
challengeReadme name = do
2015-09-06 14:24:49 +02:00
( Entity _ challenge ) <- runDB $ getBy404 $ UniqueName name
let repoId = challengePublicRepo challenge
2016-01-08 21:57:29 +01:00
repoDir <- getRepoDir repoId
2015-09-06 14:24:49 +02:00
let readmeFilePath = repoDir </> readmeFile
2017-09-22 14:23:03 +02:00
contents <- liftIO $ System . IO . readFile readmeFilePath
return $ markdown def $ TL . pack contents
2015-09-06 14:24:49 +02:00
2018-07-28 21:36:45 +02:00
showChallengeWidget :: Maybe UserId
-> Challenge
-> RepoScheme
-> Repo
-> Test
-> Repo
-> [ LeaderboardEntry ]
2018-07-28 22:10:55 +02:00
-> [ Text ]
-> [ Entity Test ]
2018-07-28 21:36:45 +02:00
-> WidgetFor App ()
2018-07-28 22:10:55 +02:00
showChallengeWidget muserId
challenge
scheme
challengeRepo
test
repo
leaderboard
params
tests
= $ ( widgetFile " show-challenge " )
2015-12-12 18:53:20 +01:00
where leaderboardWithRanks = zip [ 1 .. ] leaderboard
2016-01-10 20:32:11 +01:00
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
2015-09-06 14:24:49 +02:00
2015-11-11 22:10:41 +01:00
getChallengeHowToR :: Text -> Handler Html
getChallengeHowToR name = do
( Entity _ challenge ) <- runDB $ getBy404 $ UniqueName name
maybeUser <- maybeAuth
2017-09-28 16:51:10 +02:00
2018-06-05 23:04:58 +02:00
app <- getYesod
2018-06-06 10:30:53 +02:00
let settings = appSettings app
let publicRepoId = challengePublicRepo challenge
repo <- runDB $ get404 publicRepoId
2018-06-05 23:04:58 +02:00
2017-09-28 16:51:10 +02:00
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
2017-09-25 12:47:01 +02:00
let isIDSet = case maybeUser of
Just ( Entity _ user ) -> isJust $ userLocalId user
Nothing -> False
isSSHUploaded <- case maybeUser of
Just ( Entity userId _ ) -> do
2018-07-28 17:30:00 +02:00
ukeys <- runDB $ selectList [ PublicKeyUser ==. userId ] []
return $ not ( null ukeys )
2017-09-25 12:47:01 +02:00
Nothing -> return False
2018-07-28 17:30:00 +02:00
challengeLayout False challenge ( challengeHowTo
challenge
settings
repo
( idToBeShown challenge maybeUser )
isIDSet
isSSHUploaded
mToken )
2015-11-11 22:10:41 +01:00
2018-07-14 07:42:28 +02:00
idToBeShown :: p -> Maybe ( Entity User ) -> Text
2018-07-28 17:04:27 +02:00
idToBeShown _ maybeUser =
2015-11-11 22:10:41 +01:00
case maybeUser of
Just user -> case userLocalId $ entityVal user of
Just localId -> localId
Nothing -> defaultIdToBe
Nothing -> defaultIdToBe
where defaultIdToBe = " YOURID " :: Text
2018-07-14 07:42:28 +02:00
defaultRepo :: RepoScheme -> Challenge -> Repo -> Maybe ( Entity User ) -> Text
2018-06-06 10:30:53 +02:00
defaultRepo SelfHosted challenge _ maybeUser = " ssh://gitolite@gonito.net/ " ++ ( idToBeShown challenge maybeUser ) ++ " / " ++ ( challengeName challenge )
defaultRepo Branches _ repo _ = repoUrl repo
2018-07-14 07:42:28 +02:00
defaultBranch :: IsString a => RepoScheme -> Maybe a
2018-06-06 10:30:53 +02:00
defaultBranch SelfHosted = Just " master "
defaultBranch Branches = Nothing
2015-11-11 22:10:41 +01:00
2018-07-28 21:36:45 +02:00
challengeHowTo challenge settings repo shownId isIDSet isSSHUploaded mToken = $ ( widgetFile " challenge-how-to " )
2018-09-01 11:06:42 +02:00
where myBranch = case appRepoScheme settings of
SelfHosted -> " master " :: Text
_ -> " my-brilliant-branch "
2015-09-06 15:33:37 +02:00
getChallengeSubmissionR :: Text -> Handler Html
getChallengeSubmissionR name = do
( Entity _ challenge ) <- runDB $ getBy404 $ UniqueName name
2015-11-11 22:10:41 +01:00
maybeUser <- maybeAuth
2018-06-06 10:30:53 +02:00
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 )
2015-09-06 15:33:37 +02:00
challengeLayout True challenge $ challengeSubmissionWidget formWidget formEnctype challenge
postChallengeSubmissionR :: Text -> Handler TypedContent
postChallengeSubmissionR name = do
2018-07-14 07:42:28 +02:00
( Entity challengeId _ ) <- runDB $ getBy404 $ UniqueName name
( ( result , _ ) , _ ) <- runFormPost $ submissionForm Nothing Nothing Nothing
2015-09-06 15:33:37 +02:00
let submissionData = case result of
FormSuccess res -> Just res
_ -> Nothing
2018-06-05 16:23:16 +02:00
Just ( mDescription , mTags , submissionUrl , submissionBranch , submissionGitAnnexRemote ) = submissionData
2015-09-06 15:33:37 +02:00
2017-09-28 11:29:48 +02:00
userId <- requireAuthId
2018-06-05 16:23:16 +02:00
runViewProgress $ doCreateSubmission userId challengeId mDescription mTags RepoSpec {
repoSpecUrl = submissionUrl ,
repoSpecBranch = submissionBranch ,
repoSpecGitAnnexRemote = submissionGitAnnexRemote }
2017-09-28 11:29:48 +02:00
2017-09-28 16:11:22 +02:00
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
2017-09-28 11:29:48 +02:00
postTriggerRemotelyR :: Handler TypedContent
postTriggerRemotelyR = do
2017-09-28 16:11:22 +02:00
( Just challengeName ) <- lookupPostParam " challenge "
2017-09-28 11:29:48 +02:00
( Just url ) <- lookupPostParam " url "
2017-09-28 16:11:22 +02:00
( Just token ) <- lookupPostParam " token "
2017-09-28 11:29:48 +02:00
mBranch <- lookupPostParam " branch "
2017-09-28 16:11:22 +02:00
[ 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
2017-09-28 11:29:48 +02:00
let branch = fromMaybe " master " mBranch
2017-09-28 16:11:22 +02:00
mChallengeEnt <- runDB $ getBy $ UniqueName challengeName
case mChallengeEnt of
2018-06-05 16:23:16 +02:00
Just ( Entity challengeId _ ) -> runOpenViewProgress $ doCreateSubmission userId challengeId
Nothing Nothing
RepoSpec { repoSpecUrl = url ,
repoSpecBranch = branch ,
repoSpecGitAnnexRemote = Nothing }
2017-09-28 16:11:22 +02:00
Nothing -> return $ toTypedContent ( ( " Unknown challenge ` " ++ ( Data . Text . unpack challengeName ) ++ " `. Cannot be triggered, must be submitted manually at Gonito.net! \ n " ) :: String )
2017-09-28 11:29:48 +02:00
2018-06-05 16:23:16 +02:00
doCreateSubmission :: UserId -> Key Challenge -> Maybe Text -> Maybe Text -> RepoSpec -> Channel -> Handler ()
doCreateSubmission userId challengeId mDescription mTags repoSpec chan = do
2018-08-30 21:58:27 +02:00
maybeRepoKey <- getSubmissionRepo userId challengeId repoSpec chan
2015-09-28 23:43:55 +02:00
case maybeRepoKey of
Just repoId -> do
repo <- runDB $ get404 repoId
2017-09-27 22:44:00 +02:00
repoDir <- getRepoDir repoId
commitMessage <- getLastCommitMessage repoDir chan
let ( mCommitDescription , mCommitTags ) = parseCommitMessage commitMessage
2017-09-28 11:29:48 +02:00
submissionId <- getSubmission userId repoId ( repoCurrentCommit repo ) challengeId ( fromMaybe ( fromMaybe " ??? " mCommitDescription ) mDescription ) chan
2015-09-29 18:23:11 +02:00
_ <- getOuts chan submissionId
2017-09-27 22:44:00 +02:00
2018-09-01 15:27:11 +02:00
currentTagIds <- runDB $ selectList [ SubmissionTagSubmission ==. submissionId ] []
runDB $ addTags submissionId ( if isNothing mTags then mCommitTags else mTags ) (
map ( submissionTagTag . entityVal ) currentTagIds )
2018-07-24 15:33:35 +02:00
msg chan " SUBMISSION CREATED "
app <- getYesod
if appAutoOpening $ appSettings app
then
2018-09-01 10:48:08 +02:00
doMakePublic userId submissionId chan
2018-07-24 15:33:35 +02:00
else
return ()
2015-09-28 23:43:55 +02:00
Nothing -> return ()
2017-09-28 11:29:48 +02:00
getSubmission :: UserId -> Key Repo -> SHA1 -> Key Challenge -> Text -> Channel -> Handler ( Key Submission )
getSubmission userId repoId commit challengeId description chan = do
2015-09-29 14:15:49 +02:00
maybeSubmission <- runDB $ getBy $ UniqueSubmissionRepoCommitChallenge repoId commit challengeId
case maybeSubmission of
2017-09-27 22:44:00 +02:00
Just ( Entity submissionId _ ) -> do
2015-09-29 14:15:49 +02:00
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 ,
2015-09-30 20:32:06 +02:00
submissionStamp = time ,
2016-02-14 08:44:16 +01:00
submissionSubmitter = userId ,
2018-06-27 13:09:11 +02:00
submissionIsPublic = False ,
submissionIsHidden = Just False }
2015-09-29 14:15:49 +02:00
2017-09-27 22:44:00 +02:00
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
2018-07-28 17:30:00 +02:00
_ <- ( string " tags " <|> string " labels " <|> string " Tags " <|> string " Labels " )
_ <- char ':'
2017-09-27 22:44:00 +02:00
skipMany space
s <- many notEndOfLine
endOfLine
return $ Data . Text . pack s
2018-07-28 17:30:00 +02:00
commaSep :: Data . Attoparsec . Text . Parser a -> Data . Attoparsec . Text . Parser [ a ]
2017-09-27 22:44:00 +02:00
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' )
2018-07-28 17:30:00 +02:00
emptyLine :: Data . Attoparsec . Text . Parser ()
2017-09-27 22:44:00 +02:00
emptyLine = do
2018-07-28 17:30:00 +02:00
many space *> endOfLine
2017-09-27 22:44:00 +02:00
2015-09-29 14:33:19 +02:00
getOuts :: Channel -> Key Submission -> Handler ( [ Out ] )
getOuts chan submissionId = do
2015-09-29 14:15:49 +02:00
submission <- runDB $ get404 submissionId
let challengeId = submissionChallenge submission
2016-01-08 21:57:29 +01:00
repoDir <- getRepoDir $ submissionRepo submission
2015-09-29 14:15:49 +02:00
activeTests <- runDB $ selectList [ TestChallenge ==. challengeId , TestActive ==. True ] []
2018-07-14 15:27:49 +02:00
outs' <- mapM ( outsForTest repoDir submissionId ) activeTests
let outs = concat outs'
2015-09-29 14:15:49 +02:00
mapM_ checkOrInsertOut outs
2015-09-29 14:33:19 +02:00
mapM_ ( checkOrInsertEvaluation repoDir chan ) outs
2015-09-29 14:15:49 +02:00
return outs
2018-07-05 22:17:25 +02:00
outFileName :: FilePath
2015-09-29 14:15:49 +02:00
outFileName = " out.tsv "
2018-07-05 22:17:25 +02:00
getOutFilePath :: FilePath -> Test -> FilePath
2015-09-29 14:15:49 +02:00
getOutFilePath repoDir test = repoDir </> ( T . unpack $ testName test ) </> outFileName
2018-07-05 22:17:25 +02:00
findOutFile :: FilePath -> Test -> IO ( Maybe FilePath )
2018-06-08 21:59:06 +02:00
findOutFile repoDir test = do
let baseOut = getOutFilePath repoDir test
2018-06-09 15:35:31 +02:00
findFilePossiblyCompressed baseOut
2018-06-08 21:59:06 +02:00
2018-07-05 22:17:25 +02:00
doesOutExist :: FilePath -> Entity Test -> IO Bool
2018-06-08 21:59:06 +02:00
doesOutExist repoDir ( Entity _ test ) = do
result <- findOutFile repoDir test
return $ isJust result
2015-09-29 14:15:49 +02:00
2018-07-14 15:27:49 +02:00
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 ]
2015-09-29 14:15:49 +02:00
return Out {
2018-07-05 22:15:21 +02:00
outVariant = variantId ,
2015-09-29 14:15:49 +02:00
outTest = testId ,
outChecksum = SHA1 checksum }
2018-07-14 15:27:49 +02:00
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
2018-07-04 17:01:45 +02:00
maybeVariant <- getBy $ UniqueVariantSubmissionName submissionId name
case maybeVariant of
Just ( Entity vid _ ) -> return vid
2018-07-14 15:27:49 +02:00
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
2018-07-04 17:01:45 +02:00
2015-09-29 14:15:49 +02:00
checkOrInsertOut :: Out -> Handler ()
checkOrInsertOut out = do
2018-07-06 16:54:17 +02:00
maybeOut <- runDB $ getBy $ UniqueOutVariantTestChecksum ( outVariant out ) ( outTest out ) ( outChecksum out )
2015-09-29 14:15:49 +02:00
case maybeOut of
Just _ -> return ()
Nothing -> ( runDB $ insert out ) >> return ()
2015-09-29 14:33:19 +02:00
checkOrInsertEvaluation :: FilePath -> Channel -> Out -> Handler ()
checkOrInsertEvaluation repoDir chan out = do
test <- runDB $ get404 $ outTest out
2015-09-29 18:23:11 +02:00
challenge <- runDB $ get404 $ testChallenge test
2015-09-29 14:33:19 +02:00
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... "
2016-01-08 21:57:29 +01:00
challengeDir <- getRepoDir $ challengePrivateRepo challenge
2018-07-14 15:27:49 +02:00
variant <- runDB $ get404 $ outVariant out
resultOrException <- liftIO $ rawEval challengeDir ( testMetric test ) repoDir ( testName test ) ( ( T . unpack $ variantName variant ) <.> " tsv " )
2015-11-11 09:50:32 +01:00
case resultOrException of
2018-06-08 15:00:40 +02:00
Right ( Left _ ) -> do
2015-09-29 18:23:11 +02:00
err chan " Cannot parse options, check the challenge repo "
2018-06-29 08:05:33 +02:00
Right ( Right ( _ , Just [ ( _ , [ result ] ) ] ) ) -> do
2015-09-29 18:23:11 +02:00
msg chan $ concat [ " Evaluated! Score " , ( T . pack $ show result ) ]
time <- liftIO getCurrentTime
2018-06-08 15:00:40 +02:00
_ <- runDB $ insert $ Evaluation {
2015-09-29 18:23:11 +02:00
evaluationTest = outTest out ,
evaluationChecksum = outChecksum out ,
evaluationScore = Just result ,
evaluationErrorMessage = Nothing ,
evaluationStamp = time }
msg chan " Evaluation done "
2018-06-08 15:00:40 +02:00
Right ( Right ( _ , Just _ ) ) -> do
err chan " Unexpected multiple results (???) "
2015-11-11 09:50:32 +01:00
Right ( Right ( _ , Nothing ) ) -> do
2015-09-29 18:23:11 +02:00
err chan " Error during the evaluation "
2015-11-11 09:50:32 +01:00
Left exception -> do
err chan $ " Evaluation failed: " ++ ( T . pack $ show exception )
2015-09-29 18:23:11 +02:00
2018-07-14 15:27:49 +02:00
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 [
2018-06-08 22:15:49 +02:00
" --alt-metric " , ( show metric ) ,
2018-06-08 15:00:40 +02:00
" --expected-directory " , challengeDir ,
" --out-directory " , repoDir ,
2018-07-14 15:27:49 +02:00
" --out-file " , outF ,
2018-06-08 15:00:40 +02:00
" --test-name " , ( T . unpack name ) ] )
2015-09-29 14:33:19 +02:00
2018-08-30 21:58:27 +02:00
getSubmissionRepo :: UserId -> Key Challenge -> RepoSpec -> Channel -> Handler ( Maybe ( Key Repo ) )
getSubmissionRepo userId challengeId repoSpec chan = do
2018-06-05 16:23:16 +02:00
let url = repoSpecUrl repoSpec
let branch = repoSpecBranch repoSpec
2018-06-14 20:35:48 +02:00
let gitAnnexRemote = repoSpecGitAnnexRemote repoSpec
2015-09-28 23:43:55 +02:00
maybeRepo <- runDB $ getBy $ UniqueUrlBranch url branch
case maybeRepo of
2018-06-14 20:35:48 +02:00
Just ( Entity repoId _ ) -> do
2015-09-28 23:43:55 +02:00
msg chan " Repo already there "
available <- checkRepoAvailibility challengeId repoId chan
if available
then
do
2018-06-14 20:35:48 +02:00
-- this is not completely right... some other thread
-- might update this to a different value
runDB $ update repoId [ RepoGitAnnexRemote =. gitAnnexRemote ]
2015-09-28 23:43:55 +02:00
updateStatus <- updateRepo repoId chan
if updateStatus
then
return $ Just repoId
else
return Nothing
else
return Nothing
2015-11-11 09:50:32 +01:00
Nothing -> do
challenge <- runDB $ get404 challengeId
let repoId = challengePublicRepo challenge
repo <- runDB $ get404 repoId
2016-01-08 21:57:29 +01:00
repoDir <- getRepoDir repoId
2018-06-05 16:23:16 +02:00
let repoCloningSpec = RepoCloningSpec {
cloningSpecRepo = repoSpec ,
2018-06-04 22:14:39 +02:00
cloningSpecReferenceRepo = RepoSpec {
repoSpecUrl = ( T . pack repoDir ) ,
2018-06-14 20:35:48 +02:00
repoSpecBranch = ( repoBranch repo ) ,
repoSpecGitAnnexRemote = Nothing
2018-06-04 22:14:39 +02:00
}
2018-06-01 22:52:49 +02:00
}
2018-08-30 21:58:27 +02:00
cloneRepo' userId repoCloningSpec chan
2015-09-28 23:43:55 +02:00
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
2015-09-06 15:33:37 +02:00
challengeSubmissionWidget formWidget formEnctype challenge = $ ( widgetFile " challenge-submission " )
2018-06-06 10:30:53 +02:00
submissionForm :: Maybe Text -> Maybe Text -> Maybe Text -> Form ( Maybe Text , Maybe Text , Text , Text , Maybe Text )
2018-06-14 20:35:48 +02:00
submissionForm defaultUrl defBranch defaultGitAnnexRemote = renderBootstrap3 BootstrapBasicForm $ ( , , , , )
2017-09-27 22:44:00 +02:00
<$> aopt textField ( fieldWithTooltip MsgSubmissionDescription MsgSubmissionDescriptionTooltip ) Nothing
2017-09-27 19:38:42 +02:00
<*> aopt textField ( tagsfs MsgSubmissionTags ) Nothing
2016-02-15 20:36:01 +01:00
<*> areq textField ( bfs MsgSubmissionUrl ) defaultUrl
2018-06-14 20:35:48 +02:00
<*> areq textField ( bfs MsgSubmissionBranch ) defBranch
2018-06-06 10:30:53 +02:00
<*> aopt textField ( bfs MsgSubmissionGitAnnexRemote ) ( Just defaultGitAnnexRemote )
2015-09-06 15:33:37 +02:00
2015-09-29 22:31:56 +02:00
getChallengeMySubmissionsR :: Text -> Handler Html
2015-09-30 20:42:25 +02:00
getChallengeMySubmissionsR name = do
userId <- requireAuthId
getChallengeSubmissions ( \ ( Entity _ submission ) -> ( submissionSubmitter submission == userId ) ) name
2015-09-29 22:31:56 +02:00
getChallengeAllSubmissionsR :: Text -> Handler Html
2015-09-30 20:42:25 +02:00
getChallengeAllSubmissionsR name = getChallengeSubmissions ( \ _ -> True ) name
getChallengeSubmissions :: ( ( Entity Submission ) -> Bool ) -> Text -> Handler Html
getChallengeSubmissions condition name = do
2018-06-27 13:09:11 +02:00
Entity challengeId challenge <- runDB $ getBy404 $ UniqueName name
2015-12-12 18:53:20 +01:00
( evaluationMaps , tests ) <- getChallengeSubmissionInfos condition challengeId
2016-02-16 21:10:10 +01:00
mauth <- maybeAuth
let muserId = ( \ ( Entity uid _ ) -> uid ) <$> mauth
2015-09-29 22:31:56 +02:00
2018-06-06 13:43:17 +02:00
app <- getYesod
let scheme = appRepoScheme $ appSettings app
challengeRepo <- runDB $ get404 $ challengePublicRepo challenge
2018-09-01 14:23:41 +02:00
let params = getNumericalParams evaluationMaps
2018-07-28 17:04:27 +02:00
2018-07-28 17:30:00 +02:00
challengeLayout True challenge ( challengeAllSubmissionsWidget muserId
challenge
scheme
challengeRepo
evaluationMaps
tests
params )
2018-09-01 14:23:41 +02:00
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 )
2018-07-28 22:10:55 +02:00
getAllParams :: [ TableEntry ] -> [ Text ]
getAllParams entries = sort
$ nub
$ concat
$ map ( \ entry -> map ( parameterName . entityVal ) ( tableEntryParams entry ) ) entries
2018-07-28 17:30:00 +02:00
challengeAllSubmissionsWidget :: Maybe UserId
-> Challenge
-> RepoScheme
-> Repo
-> [ TableEntry ]
-> [ Entity Test ]
-> [ Text ]
-> WidgetFor App ()
2018-07-28 17:04:27 +02:00
challengeAllSubmissionsWidget muserId challenge scheme challengeRepo submissions tests params =
$ ( widgetFile " challenge-all-submissions " )
2018-07-28 22:02:47 +02:00
paramGraphsWidget :: Challenge -> [ Entity Test ] -> [ Text ] -> WidgetFor App ()
paramGraphsWidget challenge tests params = $ ( widgetFile " param-graphs " )
2018-09-01 14:01:17 +02:00
where chartJSs = getChartJss challenge selectedTests params
2018-07-28 21:22:52 +02:00
selectedTests = getMainTests tests
2018-09-01 14:01:17 +02:00
getChartJss :: Challenge -> [ Entity Test ] -> [ Text ] -> JavascriptUrl ( Route App )
getChartJss challenge tests params =
2018-07-28 21:22:52 +02:00
mconcat $ [ ( getChartJs challenge test param ) | test <- tests , param <- params ]
2018-07-28 17:04:27 +02:00
2018-07-28 17:30:00 +02:00
getChartJs :: Challenge
2018-07-28 19:16:07 +02:00
-> Entity Test
2018-07-28 17:30:00 +02:00
-> Text
-> JavascriptUrl ( Route App )
2018-07-28 19:16:07 +02:00
getChartJs challenge ( Entity testId test ) param = [ julius |
$. getJSON ( " @{ChallengeParamGraphDataR (challengeName challenge) testId param} " , function ( data ) {
2018-07-28 17:04:27 +02:00
c3 . generate ( {
2018-07-28 19:16:07 +02:00
bindto : '# chart - ' + # { t o J S O N p a r a m } + ' - ' + # { t o J S O N t e s t I d } ,
2018-07-28 17:04:27 +02:00
data : data ,
axis : {
x : {
label : # { toJSON param } ,
} ,
y : {
label : # { toJSON testFormatted } ,
}
}
} ) } ) ;
| ]
where testFormatted = formatTest test
2018-06-06 13:43:17 +02:00
2015-09-29 22:31:56 +02:00
2018-07-05 22:17:25 +02:00
challengeLayout :: Bool -> Challenge -> WidgetFor App () -> HandlerFor App Html
2015-09-06 14:24:49 +02:00
challengeLayout withHeader challenge widget = do
2017-09-27 19:38:42 +02:00
tagsAvailableAsJSON <- runDB $ getAvailableTagsAsJSON
2016-05-03 12:29:56 +02:00
maybeUser <- maybeAuth
2015-09-06 14:24:49 +02:00
bc <- widgetToPageContent widget
2015-09-04 23:23:32 +02:00
defaultLayout $ do
2015-09-06 14:24:49 +02:00
setTitle " Challenge "
$ ( widgetFile " challenge " )