diff --git a/Handler/Shared.hs b/Handler/Shared.hs index b468198..a546f25 100644 --- a/Handler/Shared.hs +++ b/Handler/Shared.hs @@ -82,7 +82,37 @@ cloneRepo url branch chan = do Just _ -> do err chan "Repo already there" return Nothing - Nothing -> do + Nothing -> cloneRepo' url branch chan + +updateRepo :: Key Repo -> Channel -> Handler Bool +updateRepo repoId chan = do + repo <- runDB $ get404 repoId + let repoDir = getRepoDir repoId + (exitCode, _) <- runProgram (Just repoDir) gitPath ["pull", "--progress"] chan + case exitCode of + ExitSuccess -> do + maybeHeadCommit <- getHeadCommit repoDir chan + case maybeHeadCommit of + Just headCommit -> do + runDB $ update repoId [RepoCurrentCommit =. headCommit] + return True + Nothing -> return False + +getHeadCommit :: FilePath -> Channel -> Handler (Maybe SHA1) +getHeadCommit repoDir chan = do + (exitCode, out) <- runProgram (Just repoDir) gitPath ["rev-parse", "HEAD"] chan + case exitCode of + ExitSuccess -> do + msg chan $ concat ["HEAD commit is ", commitId] + return $ Just commitRaw + where commitId = T.replace "\n" "" out + commitRaw = fromTextToSHA1 commitId + ExitFailure _ -> do + err chan "cannot determine HEAD commit" + return Nothing + +cloneRepo' :: Text -> Text -> Channel -> Handler (Maybe (Key Repo)) +cloneRepo' url branch chan = do msg chan $ concat ["Preparing to clone repo ", url] if checkRepoUrl url then do @@ -97,10 +127,9 @@ cloneRepo url branch chan = do tmpRepoDir] chan case exitCode of ExitSuccess -> do - (exitCode, out) <- runProgram (Just tmpRepoDir) gitPath ["rev-parse", "HEAD"] chan - case exitCode of - ExitSuccess -> do - msg chan $ concat ["HEAD commit is ", commitId] + maybeHeadCommit <- getHeadCommit tmpRepoDir chan + case maybeHeadCommit of + Just commitRaw -> do userId <- requireAuthId time <- liftIO getCurrentTime repoId <- runDB $ insert $ Repo { @@ -114,10 +143,7 @@ cloneRepo url branch chan = do liftIO $ renameDirectory tmpRepoDir repoDir msg chan $ concat ["Repo is in ", (T.pack repoDir)] return $ Just repoId - where commitId = T.replace "\n" "" out - commitRaw = fromTextToSHA1 commitId - ExitFailure _ -> do - err chan "cannot determine HEAD commit" + Nothing -> do return Nothing ExitFailure _ -> do err chan "git failed" @@ -126,6 +152,7 @@ cloneRepo url branch chan = do err chan $ concat ["Wrong URL to a Git repo (note that one of the following protocols must be specified: ", validGitProtocolsAsText] return Nothing + getRepoDir :: Key Repo -> FilePath getRepoDir repoId = arena ("r" ++ repoIdAsString) where repoIdAsString = show $ fromSqlKey repoId diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index 0b94fc0..bc30f31 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -36,13 +36,62 @@ getChallengeSubmissionR name = do 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 $ (flip msg) "HAHA" + runViewProgress $ doCreateSubmission challengeId description submissionUrl submissionBranch + +doCreateSubmission :: Key Challenge -> Text -> Text -> Text -> Channel -> Handler () +doCreateSubmission challengeId _ url branch chan = do + maybeRepoKey <- getSubmissionRepo challengeId url branch chan + case maybeRepoKey of + Just repoId -> do + repo <- runDB $ get404 repoId + msg chan "HAHA" + Nothing -> return () + +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") diff --git a/config/models b/config/models index af407c2..5ba7611 100644 --- a/config/models +++ b/config/models @@ -31,5 +31,24 @@ Test checksum SHA1 commit SHA1 active Bool default=True - UniqueChallengeChecksum challenge name checksum + UniqueChallengeNameChecksum challenge name checksum +Submission + repo RepoId + commit SHA1 + challenge ChallengeId + description Text + stamp UTCTime default=now() + UniqueSubmissionRepoCommitChallenge repo commit challenge +Evaluation + test TestId + checksum SHA1 + score Double Maybe + errorMessage Text Maybe + stamp UTCTime default=now() + UniqueTestChecksum test checksum +Out + submission SubmissionId + test TestId + checksum SHA1 + UniqueOutSubmissionTestChecksum submission test checksum -- By default this file is used in Model.hs (which is imported by Foundation.hs)