module Handler.ShowChallenge where import Import import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, withSmallInput, bfs) import Data.Monoid import qualified Data.Text.Lazy as TL import Text.Markdown import System.Directory (doesFileExist) import qualified Data.Text as T import qualified Yesod.Table as Table import Handler.Extract import Handler.Shared import Handler.Tables import GEval.Core import GEval.OptionsParser import qualified Data.Map as Map import PersistSHA1 import Options.Applicative import System.IO (readFile) getShowChallengeR :: Text -> Handler Html getShowChallengeR name = do (Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name Just repo <- runDB $ get $ challengePublicRepo challenge (mainTest, leaderboard) <- getLeaderboardEntries challengeId mauth <- maybeAuth let muserId = (\(Entity uid _) -> uid) <$> mauth challengeLayout True challenge (showChallengeWidget muserId challenge mainTest repo leaderboard) getChallengeReadmeR :: Text -> Handler Html getChallengeReadmeR name = do (Entity _ challenge) <- runDB $ getBy404 $ UniqueName name readme <- challengeReadme name challengeLayout False challenge $ toWidget readme 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 muserId challenge test repo leaderboard = $(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 challengeLayout False challenge (challengeHowTo challenge (idToBeShown challenge maybeUser)) 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 challenge maybeUser = "ssh://gitolite@gonito.net/" ++ (idToBeShown challenge maybeUser) ++ "/" ++ (challengeName challenge) challengeHowTo challenge idToBeShown = $(widgetFile "challenge-how-to") getChallengeSubmissionR :: Text -> Handler Html getChallengeSubmissionR name = do (Entity _ challenge) <- runDB $ getBy404 $ UniqueName name maybeUser <- maybeAuth (formWidget, formEnctype) <- generateFormPost $ submissionForm (Just $ defaultRepo challenge maybeUser) 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 Nothing 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, submissionIsPublic=False } 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] [] 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..." challengeDir <- getRepoDir $ challengePrivateRepo challenge resultOrException <- liftIO $ rawEval challengeDir repoDir (testName test) case resultOrException of Right (Left parseResult) -> do err chan "Cannot parse options, check the challenge repo" Right (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 (Right (_, Nothing)) -> do err chan "Error during the evaluation" Left exception -> do err chan $ "Evaluation failed: " ++ (T.pack $ show exception) rawEval :: FilePath -> FilePath -> Text -> IO (Either GEvalException (Either (ParserResult GEvalOptions) (GEvalOptions, Maybe MetricValue))) rawEval challengeDir repoDir name = try (runGEvalGetOptions [ "--expected-directory", challengeDir, "--out-directory", repoDir, "--test-name", (T.unpack name)]) 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 -> do challenge <- runDB $ get404 challengeId let repoId = challengePublicRepo challenge repo <- runDB $ get404 repoId repoDir <- getRepoDir repoId cloneRepo' url branch (T.pack repoDir) (repoBranch repo) 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 -> Form (Text, Text, Text) submissionForm defaultUrl = renderBootstrap3 BootstrapBasicForm $ (,,) <$> areq textField (bfs MsgSubmissionDescription) Nothing <*> areq textField (bfs MsgSubmissionUrl) defaultUrl <*> areq textField (bfs MsgSubmissionBranch) (Just "master") 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 challengeEnt@(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name (evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId mauth <- maybeAuth let muserId = (\(Entity uid _) -> uid) <$> mauth challengeLayout True challenge (challengeAllSubmissionsWidget muserId challenge evaluationMaps tests) challengeAllSubmissionsWidget muserId challenge submissions tests = $(widgetFile "challenge-all-submissions") challengeLayout withHeader challenge widget = do maybeUser <- maybeAuth bc <- widgetToPageContent widget defaultLayout $ do setTitle "Challenge" $(widgetFile "challenge")