gonito/Handler/ShowChallenge.hs

449 lines
18 KiB
Haskell
Raw Normal View History

2015-09-04 23:23:32 +02:00
module Handler.ShowChallenge where
import Import
2015-09-06 15:33:37 +02:00
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3,
2016-02-15 20:36:01 +01:00
withSmallInput, bfs)
2015-09-04 23:23:32 +02:00
2015-09-29 22:31:56 +02:00
import Data.Monoid
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 System.Directory (doesFileExist)
import qualified Data.Text as T
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
2015-09-06 14:24:49 +02:00
2015-09-29 18:23:11 +02:00
import GEval.Core
import GEval.OptionsParser
2015-09-29 22:31:56 +02:00
import qualified Data.Map as Map
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)
import Data.Attoparsec.Text
2017-09-28 16:11:22 +02:00
import Data.Text (pack, unpack)
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
2016-02-17 09:34:34 +01:00
(mainTest, leaderboard) <- getLeaderboardEntries challengeId
2016-02-16 21:10:10 +01:00
mauth <- maybeAuth
let muserId = (\(Entity uid _) -> uid) <$> mauth
app <- getYesod
let scheme = appRepoScheme $ appSettings app
challengeRepo <- runDB $ get404 $ challengePublicRepo challenge
challengeLayout True challenge (showChallengeWidget muserId challenge scheme challengeRepo mainTest repo leaderboard)
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
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
showChallengeWidget muserId challenge scheme challengeRepo test repo leaderboard = $(widgetFile "show-challenge")
2015-12-12 18:53:20 +01:00
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
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
keys <- runDB $ selectList [PublicKeyUser ==. userId] []
return $ not (null keys)
Nothing -> return False
challengeLayout False challenge (challengeHowTo challenge settings repo (idToBeShown challenge maybeUser) isIDSet isSSHUploaded mToken)
2015-11-11 22:10:41 +01:00
idToBeShown challenge maybeUser =
case maybeUser of
Just user -> case userLocalId $ entityVal user of
Just localId -> localId
Nothing -> defaultIdToBe
Nothing -> defaultIdToBe
where defaultIdToBe = "YOURID" :: Text
defaultRepo SelfHosted challenge _ maybeUser = "ssh://gitolite@gonito.net/" ++ (idToBeShown challenge maybeUser) ++ "/" ++ (challengeName challenge)
defaultRepo Branches _ repo _ = repoUrl repo
defaultBranch SelfHosted = Just "master"
defaultBranch Branches = Nothing
2015-11-11 22:10:41 +01:00
challengeHowTo challenge settings repo idToBeShown isIDSet isSSHUploaded mToken = $(widgetFile "challenge-how-to")
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
2015-09-28 23:43:55 +02:00
(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
((result, formWidget), formEnctype) <- 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
maybeRepoKey <- getSubmissionRepo challengeId repoSpec chan
2015-09-28 23:43:55 +02:00
case maybeRepoKey of
Just repoId -> do
repo <- runDB $ get404 repoId
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
runDB $ addTags submissionId (if isNothing mTags then mCommitTags else mTags) []
2015-09-29 18:23:11 +02:00
msg chan "Done"
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
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,
2016-02-14 08:59:12 +01:00
submissionIsPublic=False }
2015-09-29 14:15:49 +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
(string "tags" <|> string "labels" <|> string "Tags" <|> string "Labels")
char ':'
skipMany space
s <- many notEndOfLine
endOfLine
return $ Data.Text.pack s
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 = do
many space
endOfLine
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-06-08 21:59:06 +02:00
testsDone <- filterM (liftIO . doesOutExist repoDir) activeTests
2015-09-29 14:15:49 +02:00
outs <- mapM (outForTest repoDir submissionId) testsDone
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
outFileName = "out.tsv"
getOutFilePath repoDir test = repoDir </> (T.unpack $ testName test) </> outFileName
2018-06-08 21:59:06 +02:00
findOutFile repoDir test = do
let baseOut = getOutFilePath repoDir test
let possibleOuts = [baseOut] ++ (map (baseOut <.>) ["gz", "bz2", "xz"])
foundFiles <- filterM doesFileExist possibleOuts
return $ case foundFiles of
[] -> Nothing
(h:_) -> Just h
doesOutExist repoDir (Entity _ test) = do
result <- findOutFile repoDir test
return $ isJust result
2015-09-29 14:15:49 +02:00
outForTest repoDir submissionId (Entity testId test) = do
2018-06-08 21:59:06 +02:00
(Just outF) <- liftIO $ findOutFile repoDir test
checksum <- liftIO $ gatherSHA1ForCollectionOfFiles [outF]
2015-09-29 14:15:49 +02:00
return Out {
outSubmission=submissionId,
outTest=testId,
outChecksum=SHA1 checksum }
checkOrInsertOut :: Out -> Handler ()
checkOrInsertOut out = do
maybeOut <- runDB $ getBy $ UniqueOutSubmissionTestChecksum (outSubmission out) (outTest out) (outChecksum out)
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
resultOrException <- liftIO $ rawEval challengeDir (testMetric test) repoDir (testName test)
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"
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
_ <- 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
rawEval :: FilePath -> Metric -> FilePath -> Text -> IO (Either GEvalException (Either (ParserResult GEvalOptions) (GEvalOptions, Maybe [MetricValue])))
rawEval challengeDir metric repoDir name = Import.try (runGEvalGetOptions [
"--metric", (show metric),
"--expected-directory", challengeDir,
"--out-directory", repoDir,
"--test-name", (T.unpack name)])
2015-09-29 14:33:19 +02:00
2018-06-05 16:23:16 +02:00
getSubmissionRepo :: Key Challenge -> RepoSpec -> Channel -> Handler (Maybe (Key Repo))
getSubmissionRepo challengeId repoSpec chan = do
let url = repoSpecUrl repoSpec
let branch = repoSpecBranch repoSpec
2015-09-28 23:43:55 +02:00
maybeRepo <- runDB $ getBy $ UniqueUrlBranch url branch
case maybeRepo of
Just (Entity repoId repo) -> do
msg chan "Repo already there"
available <- checkRepoAvailibility challengeId repoId chan
if available
then
do
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),
repoSpecBranch = (repoBranch repo)
}
2018-06-01 22:52:49 +02:00
}
2018-06-05 16:23:16 +02:00
cloneRepo' 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")
submissionForm :: Maybe Text -> Maybe Text -> Maybe Text -> Form (Maybe Text, Maybe Text, Text, Text, Maybe Text)
submissionForm defaultUrl defaultBranch 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) defaultBranch
<*> 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
2015-12-12 18:53:20 +01:00
challengeEnt@(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
(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
app <- getYesod
let scheme = appRepoScheme $ appSettings app
challengeRepo <- runDB $ get404 $ challengePublicRepo challenge
challengeLayout True challenge (challengeAllSubmissionsWidget muserId challenge scheme challengeRepo evaluationMaps tests)
challengeAllSubmissionsWidget muserId challenge scheme challengeRepo submissions tests = $(widgetFile "challenge-all-submissions")
2015-09-29 22:31:56 +02:00
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")