gonito/Handler/ShowChallenge.hs

254 lines
10 KiB
Haskell

module Handler.ShowChallenge where
import Import
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3,
withSmallInput)
import Data.Monoid
import qualified Yesod.Table as Table
import Yesod.Table (Table)
import qualified Data.Text.Lazy as TL
import Text.Markdown
import System.Directory (doesFileExist)
import qualified Data.Text as T
import Handler.Extract
import Handler.Shared
import GEval.Core
import GEval.OptionsParser
import Data.Map (Map)
import qualified Data.Map as Map
import PersistSHA1
getShowChallengeR :: Text -> Handler Html
getShowChallengeR name = do
(Entity _ challenge) <- runDB $ getBy404 $ UniqueName name
Just repo <- runDB $ get $ challengePublicRepo challenge
challengeLayout True challenge (showChallengeWidget challenge repo)
getChallengeReadmeR :: Text -> Handler Html
getChallengeReadmeR name = do
(Entity _ challenge) <- runDB $ getBy404 $ UniqueName name
let repoId = challengePublicRepo challenge
let repoDir = getRepoDir repoId
let readmeFilePath = repoDir </> readmeFile
contents <- readFile readmeFilePath
challengeLayout False challenge $ toWidget $ markdown def $ TL.fromStrict contents
showChallengeWidget challenge repo = $(widgetFile "show-challenge")
getChallengeSubmissionR :: Text -> Handler Html
getChallengeSubmissionR name = do
(Entity _ challenge) <- runDB $ getBy404 $ UniqueName name
(formWidget, formEnctype) <- generateFormPost submissionForm
challengeLayout True challenge $ challengeSubmissionWidget formWidget formEnctype challenge
postChallengeSubmissionR :: Text -> Handler TypedContent
postChallengeSubmissionR name = do
(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
((result, formWidget), formEnctype) <- runFormPost submissionForm
let submissionData = case result of
FormSuccess res -> Just res
_ -> Nothing
Just (description, submissionUrl, submissionBranch) = submissionData
runViewProgress $ doCreateSubmission challengeId description submissionUrl submissionBranch
doCreateSubmission :: Key Challenge -> Text -> Text -> Text -> Channel -> Handler ()
doCreateSubmission challengeId description url branch chan = do
maybeRepoKey <- getSubmissionRepo challengeId url branch chan
case maybeRepoKey of
Just repoId -> do
repo <- runDB $ get404 repoId
submissionId <- getSubmission repoId (repoCurrentCommit repo) challengeId description chan
_ <- getOuts chan submissionId
msg chan "Done"
Nothing -> return ()
getSubmission :: Key Repo -> SHA1 -> Key Challenge -> Text -> Channel -> Handler (Key Submission)
getSubmission repoId commit challengeId description chan = do
maybeSubmission <- runDB $ getBy $ UniqueSubmissionRepoCommitChallenge repoId commit challengeId
userId <- requireAuthId
case maybeSubmission of
Just (Entity submissionId submission) -> 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 }
getOuts :: Channel -> Key Submission -> Handler ([Out])
getOuts chan submissionId = do
submission <- runDB $ get404 submissionId
let challengeId = submissionChallenge submission
let repoDir = getRepoDir $ submissionRepo submission
activeTests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] []
testsDone <- filterM (doesOutExist repoDir) activeTests
outs <- mapM (outForTest repoDir submissionId) testsDone
mapM_ checkOrInsertOut outs
mapM_ (checkOrInsertEvaluation repoDir chan) outs
return outs
outFileName = "out.tsv"
getOutFilePath repoDir test = repoDir </> (T.unpack $ testName test) </> outFileName
doesOutExist repoDir (Entity _ test) = liftIO $ doesFileExist $ getOutFilePath repoDir test
outForTest repoDir submissionId (Entity testId test) = do
checksum <- liftIO $ gatherSHA1ForCollectionOfFiles [getOutFilePath repoDir test]
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 ()
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..."
result <- liftIO $ runGEvalGetOptions ["--expected-directory", (getRepoDir $ challengePrivateRepo challenge),
"--out-directory", repoDir]
case result of
Left parseResult -> do
err chan "Cannot parse options, check the challenge repo"
Right (opts, 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 (_, Nothing) -> do
err chan "Error during the evaluation"
getSubmissionRepo :: Key Challenge -> Text -> Text -> Channel -> Handler (Maybe (Key Repo))
getSubmissionRepo challengeId url branch chan = do
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
Nothing -> cloneRepo' url branch 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 :: Form (Text, Text, Text)
submissionForm = renderBootstrap3 BootstrapBasicForm $ (,,)
<$> areq textField (fieldSettingsLabel MsgSubmissionDescription) Nothing
<*> areq textField (fieldSettingsLabel MsgSubmissionUrl) Nothing
<*> areq textField (fieldSettingsLabel MsgSubmissionBranch) Nothing
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
allSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId] [Desc SubmissionStamp]
let submissions = filter condition allSubmissions
tests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] []
evaluationMaps <- mapM getEvaluationMap submissions
challengeLayout True challenge (challengeAllSubmissionsWidget challenge evaluationMaps tests)
getEvaluationMap :: Entity Submission -> Handler (Entity Submission, User, Map (Key Test) Evaluation)
getEvaluationMap s@(Entity submissionId submission) = do
outs <- runDB $ selectList [OutSubmission ==. submissionId] []
user <- runDB $ get404 $ submissionSubmitter submission
maybeEvaluations <- runDB $ mapM (\(Entity _ o) -> getBy $ UniqueEvaluationTestChecksum (outTest o) (outChecksum o)) outs
let evaluations = catMaybes maybeEvaluations
let m = Map.fromList $ map (\(Entity _ e) -> (evaluationTest e, e)) evaluations
return (s, user, m)
challengeAllSubmissionsWidget challenge submissions tests = $(widgetFile "challenge-all-submissions")
submissionsTable :: [Entity Test] -> Table site (Entity Submission, User, Map (Key Test) Evaluation)
submissionsTable tests = mempty
++ Table.text "submitter" (formatSubmitter . \(_, submitter, _) -> submitter)
++ Table.string "when" (show . submissionStamp . \(Entity _ s, _, _) -> s)
++ Table.text "description" (submissionDescription . \(Entity _ s, _, _) -> s)
++ mconcat (map (\(Entity k t) -> Table.string (testName t) (submissionScore k)) tests)
formatSubmitter :: User -> Text
formatSubmitter user = case userName user of
Just name -> name
Nothing -> "[name not given]"
submissionScore :: Key Test -> (Entity Submission, User, Map (Key Test) Evaluation) -> String
submissionScore k (_, _, m) = fromMaybe "N/A" (presentScore <$> lookup k m)
presentScore :: Evaluation -> String
presentScore evaluation = fromMaybe "???" (show <$> evaluationScore evaluation)
challengeLayout withHeader challenge widget = do
bc <- widgetToPageContent widget
defaultLayout $ do
setTitle "Challenge"
$(widgetFile "challenge")