getting submission repo

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

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")
 

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)