getting submission repo

This commit is contained in:
Filip Gralinski 2015-09-28 23:43:55 +02:00
parent 9a5104cbb4
commit 24ac68937c
3 changed files with 106 additions and 11 deletions

View File

@ -82,7 +82,37 @@ cloneRepo url branch chan = do
Just _ -> do Just _ -> do
err chan "Repo already there" err chan "Repo already there"
return Nothing 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] msg chan $ concat ["Preparing to clone repo ", url]
if checkRepoUrl url if checkRepoUrl url
then do then do
@ -97,10 +127,9 @@ cloneRepo url branch chan = do
tmpRepoDir] chan tmpRepoDir] chan
case exitCode of case exitCode of
ExitSuccess -> do ExitSuccess -> do
(exitCode, out) <- runProgram (Just tmpRepoDir) gitPath ["rev-parse", "HEAD"] chan maybeHeadCommit <- getHeadCommit tmpRepoDir chan
case exitCode of case maybeHeadCommit of
ExitSuccess -> do Just commitRaw -> do
msg chan $ concat ["HEAD commit is ", commitId]
userId <- requireAuthId userId <- requireAuthId
time <- liftIO getCurrentTime time <- liftIO getCurrentTime
repoId <- runDB $ insert $ Repo { repoId <- runDB $ insert $ Repo {
@ -114,10 +143,7 @@ cloneRepo url branch chan = do
liftIO $ renameDirectory tmpRepoDir repoDir liftIO $ renameDirectory tmpRepoDir repoDir
msg chan $ concat ["Repo is in ", (T.pack repoDir)] msg chan $ concat ["Repo is in ", (T.pack repoDir)]
return $ Just repoId return $ Just repoId
where commitId = T.replace "\n" "" out Nothing -> do
commitRaw = fromTextToSHA1 commitId
ExitFailure _ -> do
err chan "cannot determine HEAD commit"
return Nothing return Nothing
ExitFailure _ -> do ExitFailure _ -> do
err chan "git failed" 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] err chan $ concat ["Wrong URL to a Git repo (note that one of the following protocols must be specified: ", validGitProtocolsAsText]
return Nothing return Nothing
getRepoDir :: Key Repo -> FilePath getRepoDir :: Key Repo -> FilePath
getRepoDir repoId = arena </> ("r" ++ repoIdAsString) getRepoDir repoId = arena </> ("r" ++ repoIdAsString)
where repoIdAsString = show $ fromSqlKey repoId where repoIdAsString = show $ fromSqlKey repoId

View File

@ -36,13 +36,62 @@ getChallengeSubmissionR name = do
postChallengeSubmissionR :: Text -> Handler TypedContent postChallengeSubmissionR :: Text -> Handler TypedContent
postChallengeSubmissionR name = do postChallengeSubmissionR name = do
(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
((result, formWidget), formEnctype) <- runFormPost submissionForm ((result, formWidget), formEnctype) <- runFormPost submissionForm
let submissionData = case result of let submissionData = case result of
FormSuccess res -> Just res FormSuccess res -> Just res
_ -> Nothing _ -> Nothing
Just (description, submissionUrl, submissionBranch) = submissionData 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") challengeSubmissionWidget formWidget formEnctype challenge = $(widgetFile "challenge-submission")

View File

@ -31,5 +31,24 @@ Test
checksum SHA1 checksum SHA1
commit SHA1 commit SHA1
active Bool default=True 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) -- By default this file is used in Model.hs (which is imported by Foundation.hs)