gonito/Handler/ShowChallenge.hs

724 lines
32 KiB
Haskell
Raw Normal View History

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)
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
2019-02-22 14:41:43 +01:00
import Handler.Dashboard
2019-03-20 16:31:08 +01:00
import Handler.Common
2015-09-06 14:24:49 +02:00
import Gonito.ExtractMetadata (ExtractionOptions(..),
extractMetadataFromRepoDir,
GonitoMetadata(..),
2018-11-12 20:41:46 +01:00
parseTags,
Link(..))
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.EvaluationScheme
2019-01-24 21:22:02 +01:00
import GEval.Common (MetricValue)
2015-09-29 18:23:11 +02:00
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)
2019-02-14 22:57:29 +01:00
import System.FilePath (takeFileName, dropExtensions, (-<.>))
2018-07-14 15:27:49 +02:00
2017-09-28 16:11:22 +02:00
import Data.Text (pack, unpack)
2018-06-29 08:05:33 +02:00
import Data.Conduit.SmartSource
2018-07-28 17:04:27 +02:00
import Data.List (nub)
2018-11-13 16:15:02 +01:00
import qualified Database.Esqueleto as E
import Database.Esqueleto ((^.))
2015-09-04 23:23:32 +02:00
getShowChallengeR :: Text -> Handler Html
getShowChallengeR name = do
2018-09-08 21:21:21 +02:00
app <- getYesod
let leaderboardStyle = appLeaderboardStyle $ appSettings app
2019-03-20 16:31:08 +01:00
challengeEnt@(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
2015-09-28 17:45:10 +02:00
Just repo <- runDB $ get $ challengePublicRepo challenge
2018-09-08 21:21:21 +02:00
(leaderboard, (entries, tests)) <- getLeaderboardEntries leaderboardStyle challengeId
2016-02-16 21:10:10 +01:00
mauth <- maybeAuth
2018-09-01 14:23:41 +02:00
let params = getNumericalParams entries
let scheme = appRepoScheme $ appSettings app
challengeRepo <- runDB $ get404 $ challengePublicRepo challenge
2019-03-20 16:31:08 +01:00
challengeLayout True challenge (showChallengeWidget mauth
challengeEnt
scheme
2018-07-28 21:36:45 +02:00
challengeRepo
repo
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
2019-03-20 16:31:08 +01:00
showChallengeWidget :: Maybe (Entity User)
-> Entity Challenge
2018-07-28 21:36:45 +02:00
-> RepoScheme
-> Repo
-> Repo
-> [LeaderboardEntry]
-> [Text]
-> [Entity Test]
2018-07-28 21:36:45 +02:00
-> WidgetFor App ()
2019-03-20 16:31:08 +01:00
showChallengeWidget mUserEnt
(Entity challengeId challenge)
scheme
challengeRepo
repo
leaderboard
params
tests
= $(widgetFile "show-challenge")
2015-12-12 18:53:20 +01:00
where leaderboardWithRanks = zip [1..] leaderboard
maybeRepoLink = getRepoLink repo
delta = Number 4
higherTheBetterArray = getIsHigherTheBetterArray $ map entityVal tests
2019-03-20 16:31:08 +01:00
mUserId = entityKey <$> mUserEnt
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
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
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
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
2019-03-20 16:31:08 +01:00
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)
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
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"
mGitAnnexRemote <- lookupPostParam "git-annex-remote"
2017-09-28 16:11:22 +02:00
[Entity userId _] <- runDB $ selectList [UserLocalId ==. Just localId] []
let localRepo = gitServer ++ localId ++ "/" ++ challengeName
trigger userId challengeName localRepo mBranch mGitAnnexRemote
2017-09-28 16:11:22 +02:00
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"
mGitAnnexRemote <- lookupPostParam "git-annex-remote"
2017-09-28 16:11:22 +02:00
[Entity userId _] <- runDB $ selectList [UserTriggerToken ==. Just token] []
trigger userId challengeName url mBranch mGitAnnexRemote
2017-09-28 16:11:22 +02:00
trigger :: UserId -> Text -> Text -> Maybe Text -> Maybe Text -> Handler TypedContent
trigger userId challengeName url mBranch mGitAnnexRemote = 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,
2019-03-20 16:31:08 +01:00
repoSpecBranch=branch,
repoSpecGitAnnexRemote=mGitAnnexRemote}
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
2019-03-20 16:31:08 +01:00
challenge <- runDB $ get404 challengeId
doCreateSubmission' (challengeArchived challenge) userId challengeId mDescription mTags repoSpec chan
doCreateSubmission' :: Maybe Bool -> UserId -> Key Challenge -> Maybe Text -> Maybe Text -> RepoSpec -> 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 mDescription mTags repoSpec chan = do
maybeRepoKey <- getSubmissionRepo userId challengeId repoSpec chan
case maybeRepoKey of
2015-09-28 23:43:55 +02:00
Just repoId -> do
2018-11-12 22:01:51 +01:00
2018-11-14 17:41:01 +01:00
challenge <- runDB $ get404 challengeId
2018-11-14 20:59:40 +01:00
user <- runDB $ get404 userId
2018-11-14 17:41:01 +01:00
2019-02-22 14:41:43 +01:00
relevantIndicators <- getOngoingTargets challengeId
2018-11-12 22:01:51 +01:00
activeTests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] []
let (Entity mainTestId mainTest) = getMainTest activeTests
2018-11-13 16:15:02 +01:00
let orderDirection = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of
2018-11-13 16:15:02 +01:00
TheHigherTheBetter -> E.desc
TheLowerTheBetter -> E.asc
bestResultSoFar <- runDB $ E.select $ E.from $ \(evaluation, submission, variant, out) -> do
E.where_ (submission ^. SubmissionChallenge E.==. E.val challengeId
2018-11-17 09:49:25 +01:00
E.&&. submission ^. SubmissionIsHidden E.==. E.val False
2018-11-13 16:15:02 +01:00
E.&&. variant ^. VariantSubmission E.==. submission ^. SubmissionId
E.&&. evaluation ^. EvaluationChecksum E.==. out ^. OutChecksum
2018-11-14 17:41:01 +01:00
E.&&. (E.not_ (E.isNothing (evaluation ^. EvaluationScore)))
2018-11-13 16:15:02 +01:00
E.&&. out ^. OutVariant E.==. variant ^. VariantId
E.&&. evaluation ^. EvaluationTest E.==. E.val mainTestId)
E.orderBy [orderDirection (evaluation ^. EvaluationScore)]
E.limit 1
return evaluation
let bestScoreSoFar = join (evaluationScore <$> entityVal <$> (listToMaybe bestResultSoFar))
2018-11-12 22:01:51 +01:00
case bestScoreSoFar of
Just s -> msg chan ("best score so far is: " ++ (Data.Text.pack $ show s))
Nothing -> msg chan "first submission so far"
2015-09-28 23:43:55 +02:00
repo <- runDB $ get404 repoId
repoDir <- getRepoDir repoId
gonitoMetadata <- liftIO
$ extractMetadataFromRepoDir repoDir (ExtractionOptions {
extractionOptionsDescription = mDescription,
extractionOptionsTags = Just $ parseTags mTags,
extractionOptionsGeneralParams = Nothing,
2018-11-03 12:30:39 +01:00
extractionOptionsUnwantedParams = Nothing,
extractionOptionsParamFiles = Nothing,
2018-11-13 14:48:41 +01:00
extractionOptionsMLRunPath = Nothing,
2018-11-16 12:43:44 +01:00
extractionOptionsExternalLinks = Nothing,
extractionOptionsDependencies = Nothing })
submissionId <- getSubmission userId
repoId
(repoCurrentCommit repo)
challengeId
(gonitoMetadataDescription gonitoMetadata)
chan
2018-11-12 20:41:46 +01:00
_ <- 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
2018-11-16 12:43:44 +01:00
2018-11-12 22:01:51 +01:00
outs <- getOuts chan submissionId (gonitoMetadataGeneralParams gonitoMetadata)
2018-11-14 20:59:40 +01:00
currentTagIds <- runDB $ selectList [SubmissionTagSubmission ==. submissionId] []
runDB $ addTags submissionId (gonitoMetadataTags gonitoMetadata) (
map (submissionTagTag . entityVal) currentTagIds)
msg chan "SUBMISSION CREATED"
app <- getYesod
2018-11-12 22:01:51 +01:00
newScores <- mapM (getScoreForOut mainTestId) outs
let newScores' = catMaybes newScores
let newScores'' = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of
2018-11-12 22:01:51 +01:00
TheHigherTheBetter -> reverse $ sort newScores'
TheLowerTheBetter -> sort newScores'
let compOp = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of
2018-11-12 22:01:51 +01:00
TheLowerTheBetter -> (<)
TheHigherTheBetter -> (>)
2019-02-22 14:41:43 +01:00
let submissionLink = slackLink app "submission" ("q/" ++ (fromSHA1ToText (repoCurrentCommit repo)))
2018-11-12 22:01:51 +01:00
case bestScoreSoFar of
Just b -> case newScores'' of
(s:_) -> if compOp s b
2018-11-14 17:41:01 +01:00
then
do
2018-11-14 20:59:40 +01:00
let challengeLink = slackLink app (challengeTitle challenge) ("challenge/"
++ (challengeName challenge))
let message = ("Whoa! New best result for "
++ challengeLink
++ " challenge by "
++ (fromMaybe "???" $ userName user)
++ ", "
2018-11-14 17:41:01 +01:00
++ (T.pack $ show $ testMetric mainTest)
2018-11-14 20:59:40 +01:00
++ ": "
++ (formatScore (testPrecision mainTest) s)
2018-11-14 17:41:01 +01:00
++ " ("
++ (if s > b
then "+"
else "")
2018-11-14 20:59:40 +01:00
++ (formatScore (testPrecision mainTest) (s-b))
++ ")."
++ " See " ++ submissionLink ++ "."
++ " :clap:")
2018-11-14 17:41:01 +01:00
msg chan message
case appNewBestResultSlackHook $ appSettings app of
Just "" -> return ()
2018-11-14 17:41:01 +01:00
Just hook -> liftIO $ runSlackHook hook message
Nothing -> return ()
2018-11-12 22:01:51 +01:00
else return ()
[] -> return ()
Nothing -> return ()
2018-07-24 15:33:35 +02:00
if appAutoOpening $ appSettings app
then
doMakePublic userId submissionId chan
2018-07-24 15:33:35 +02:00
else
return ()
2019-02-22 14:41:43 +01:00
if not (null relevantIndicators)
then
checkIndicators user challengeId submissionId submissionLink relevantIndicators chan
else
return ()
2015-09-28 23:43:55 +02:00
Nothing -> return ()
2019-02-22 14:41:43 +01:00
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 (\(Entity sid _) -> sid == submissionId) 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 appNewBestResultSlackHook $ appSettings app of
Just "" -> return ()
Just hook -> liftIO $ runSlackHook hook message
Nothing -> return ()
else
return ()
where indicatorText = prettyIndicatorEntry indicator
2018-11-12 22:01:51 +01:00
getScoreForOut mainTestId out = do
mEvaluation <- runDB $ selectFirst [EvaluationChecksum ==. (outChecksum out),
EvaluationTest ==. mainTestId]
[]
return $ case mEvaluation of
Just evaluation -> evaluationScore $ entityVal evaluation
Nothing -> Nothing
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
2019-08-27 22:36:51 +02:00
challenge <- runDB $ get404 challengeId
2015-09-29 14:15:49 +02:00
maybeSubmission <- runDB $ getBy $ UniqueSubmissionRepoCommitChallenge repoId commit challengeId
case maybeSubmission of
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,
submissionIsPublic=False,
2019-08-27 22:36:51 +02:00
submissionIsHidden=False,
submissionVersion=challengeVersion challenge}
2015-09-29 14:15:49 +02:00
2018-11-03 12:30:39 +01:00
getOuts :: Channel -> Key Submission -> M.Map Text Text -> Handler ([Out])
getOuts chan submissionId generalParams = 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
2018-11-03 12:30:39 +01:00
outs' <- mapM (outsForTest repoDir submissionId generalParams) activeTests
2018-07-14 15:27:49 +02:00
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
2019-02-14 22:57:29 +01:00
ofs <- mapM (\ext -> findFilePossiblyCompressed (baseOut -<.> ext)) extensionsHandled
return $ listToMaybe $ catMaybes ofs
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-11-03 12:30:39 +01:00
outsForTest :: FilePath -> SubmissionId -> M.Map Text Text -> Entity Test -> HandlerFor App [Out]
outsForTest repoDir submissionId generalParams testEnt@(Entity _ test) = do
2018-07-14 15:27:49 +02:00
outFiles <- liftIO $ outFilesForTest repoDir test
forM outFiles $ \outFile -> do
2018-11-03 12:30:39 +01:00
theVariant <- getVariant submissionId generalParams outFile
2018-07-14 15:27:49 +02:00
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 []
2018-11-03 10:56:58 +01:00
getVariant :: SubmissionId -> M.Map Text Text -> FilePath -> Handler VariantId
getVariant submissionId generalParams outFilePath = runDB $ do
2018-07-14 15:27:49 +02:00
let outFile = takeFileName outFilePath
let name = Data.Text.pack $ dropExtensions outFile
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
2018-11-03 10:56:58 +01:00
forM_ (M.toList (paramMap `M.union` generalParams)) $ \(param, val) -> do
2018-07-14 15:27:49 +02:00
_ <- insert $ Parameter vid param val
return ()
2018-11-03 10:56:58 +01:00
2018-07-14 15:27:49 +02:00
return vid
2015-09-29 14:15:49 +02:00
checkOrInsertOut :: Out -> Handler ()
checkOrInsertOut out = do
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 ", (fromMaybe "???" $ formatNonScientifically <$> evaluationScore evaluation)]
2015-09-29 14:33:19 +02:00
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 (evaluationSchemeMetric $ testMetric test) repoDir (testName test) ((T.unpack $ variantName variant) <.> "tsv")
2015-11-11 09:50:32 +01:00
case resultOrException of
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
msg chan $ concat [ "Evaluated! Score ", (formatNonScientifically result) ]
2015-09-29 18:23:11 +02:00
time <- liftIO getCurrentTime
_ <- 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"
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),
"--expected-directory", challengeDir,
"--out-directory", repoDir,
2018-07-14 15:27:49 +02:00
"--out-file", outF,
"--test-name", (T.unpack name)])
2015-09-29 14:33:19 +02:00
getSubmissionRepo :: UserId -> Key Challenge -> RepoSpec -> Channel -> Handler (Maybe (Key Repo))
2019-08-29 08:56:22 +02:00
getSubmissionRepo userId challengeId repoSpec chan = getPossiblyExistingRepo checkRepoAvailibility userId challengeId repoSpec 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")
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
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
<*> areq textField (bfs MsgSubmissionBranch) defBranch
<*> 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
Entity challengeId challenge <- runDB $ getBy404 $ UniqueName name
2018-11-12 14:12:51 +01:00
(evaluationMaps, tests') <- runDB $ getChallengeSubmissionInfos condition challengeId
2018-09-08 21:24:25 +02:00
let tests = sortBy testComparator tests'
2016-02-16 21:10:10 +01:00
mauth <- maybeAuth
let muserId = (\(Entity uid _) -> uid) <$> mauth
2015-09-29 22:31:56 +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)
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-11-12 10:11:58 +01:00
where delta = Number 4
higherTheBetterArray = getIsHigherTheBetterArray $ map entityVal tests
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
selectedTests = reverse $ getMainTests tests
2018-09-01 14:01:17 +02:00
getChartJss :: Challenge -> [Entity Test] -> [Text] -> JavascriptUrl (Route App)
getChartJss challenge tests params =
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
-> Entity Test
2018-07-28 17:30:00 +02:00
-> Text
-> JavascriptUrl (Route App)
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({
bindto: '#chart-' + #{toJSON param} + '-' + #{toJSON testId},
2018-07-28 17:04:27 +02:00
data: data,
axis: {
x: {
label: #{toJSON param},
},
y: {
label: #{toJSON testFormatted},
}
}
}) });
|]
where testFormatted = formatTest test
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")