Challenges can be updated

Handler/CreateChallenge.hs

@@ -11,6 +11,8 @@ import Handler.Extract
 import GEval.Core
 import GEval.OptionsParser
 
+import Gonito.ExtractMetadata (getLastCommitMessage)
+
 import System.Directory (doesFileExist)
 import System.FilePath.Find as SFF
 import System.FilePath
@@ -105,7 +107,7 @@ getChallengeUpdateR challengeId = do
         $(widgetFile "update-challenge")
 
 postChallengeUpdateR :: ChallengeId -> Handler TypedContent
-postChallengeUpdateR _ = do
+postChallengeUpdateR challengeId = do
     ((result, _), _) <- runFormPost updateChallengeForm
     let challengeData = case result of
             FormSuccess res -> Just res
@@ -118,9 +120,81 @@ postChallengeUpdateR _ = do
     if userIsAdmin user
       then
        do
-         runViewProgress $ (flip err) "TO BE IMPLEMENTED"
+         runViewProgress $ doChallengeUpdate challengeId updateType publicUrl publicBranch publicGitAnnexRemote privateUrl privateBranch privateGitAnnexRemote
       else
-        runViewProgress $ (flip err) "MUST BE AN ADMIN TO CREATE A CHALLENGE"
+        runViewProgress $ (flip err) "MUST BE AN ADMIN TO UPDATE A CHALLENGE"
+
+doChallengeUpdate :: ChallengeId -> ChallengeUpdateType -> Text -> Text -> Maybe Text -> Text -> Text -> Maybe Text -> Channel -> Handler ()
+doChallengeUpdate challengeId updateType publicUrl publicBranch publicGitAnnexRemote privateUrl privateBranch privateGitAnnexRemote chan = do
+  challenge <- runDB $ get404 challengeId
+  (Entity _ version) <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
+  let (newMajor, newMinor, newPatch) = incrementVersion updateType (versionMajor version,
+                                                                    versionMinor version,
+                                                                    versionPatch version)
+
+  msg chan ("UPDATING TO VERSION: " ++ (pack $ show newMajor) ++ "." ++ (pack $ show newMinor) ++ "." ++ (pack $ show newPatch))
+
+  userId <- requireAuthId
+  (Just publicRepoId) <- getPossiblyExistingRepo (\_ _ _ -> return True)
+                                                userId
+                                                challengeId
+                                                RepoSpec {
+                                                  repoSpecUrl = publicUrl,
+                                                  repoSpecBranch = publicBranch,
+                                                  repoSpecGitAnnexRemote = publicGitAnnexRemote}
+                                                chan
+
+  (Just privateRepoId) <- getPossiblyExistingRepo (\_ _ _ -> return True)
+                                                 userId
+                                                 challengeId
+                                                 RepoSpec {
+                                                   repoSpecUrl = privateUrl,
+                                                   repoSpecBranch = privateBranch,
+                                                   repoSpecGitAnnexRemote = privateGitAnnexRemote}
+                                                 chan
+
+  privateRepo <- runDB $ get404 $ privateRepoId
+  repoDir <- getRepoDir privateRepoId
+  (Just versionDescription) <- liftIO $ getLastCommitMessage repoDir
+  theNow <- liftIO getCurrentTime
+  let commit = (repoCurrentCommit privateRepo)
+
+  mAlreadyExistingVersion <- runDB $ getBy $ UniqueVersionByCommit commit
+  case mAlreadyExistingVersion of
+    Just (Entity versionId _) -> do
+                                 runDB $ update versionId [VersionMajor =. newMajor,
+                                                           VersionMinor =. newMinor,
+                                                           VersionPatch =. newPatch,
+                                                           VersionDescription =. versionDescription,
+                                                           VersionStamp =. theNow]
+
+    Nothing -> do
+               _ <- runDB $ insert $ Version commit
+                           newMajor
+                           newMinor
+                           newPatch
+                           versionDescription
+                           theNow
+               return ()
+
+  (title, description, mImage) <- extractChallengeMetadata publicRepoId chan
+
+  runDB $ update challengeId [ChallengePublicRepo =. publicRepoId,
+                              ChallengePrivateRepo =. privateRepoId,
+                              ChallengeVersion =. commit,
+                              ChallengeTitle =. title,
+                              ChallengeDescription =. description,
+                              ChallengeImage =. mImage]
+
+  updateTests challengeId chan
+
+  return ()
+
+
+incrementVersion :: ChallengeUpdateType -> (Int, Int, Int) -> (Int, Int, Int)
+incrementVersion MajorChange (major, minor, patch) = (major + 1, minor, patch)
+incrementVersion MinorChange (major, minor, patch) = (major, minor + 1, patch)
+incrementVersion ChallengePatch (major, minor, patch) = (major, minor, patch + 1)
 
 
 defaultMajorVersion :: Int
@@ -135,9 +209,8 @@ defaultPatchVersion = 0
 defaultInitialDescription :: Text
 defaultInitialDescription = "initial version"
 
-addChallenge :: Text -> (Key Repo) -> (Key Repo) -> Channel -> Handler ()
+extractChallengeMetadata :: Key Repo -> Channel -> Handler (Text, Text, Maybe ByteString)
-addChallenge name publicRepoId privateRepoId chan = do
+extractChallengeMetadata publicRepoId chan = do
-  msg chan "adding challenge..."
   publicRepoDir <- getRepoDir publicRepoId
   let readmeFilePath = publicRepoDir </> readmeFile
   doesReadmeExist <- liftIO $ doesFileExist readmeFilePath
@@ -157,6 +230,14 @@ addChallenge name publicRepoId privateRepoId chan = do
              else do
                return Nothing
 
+  return (T.pack $ title, T.pack $ description, mImage)
+
+addChallenge :: Text -> (Key Repo) -> (Key Repo) -> Channel -> Handler ()
+addChallenge name publicRepoId privateRepoId chan = do
+  msg chan "adding challenge..."
+
+  (title, description, mImage) <- extractChallengeMetadata publicRepoId chan
+
   privateRepo <- runDB $ get404 privateRepoId
   time <- liftIO getCurrentTime
 
@@ -174,8 +255,8 @@ addChallenge name publicRepoId privateRepoId chan = do
     challengePublicRepo=publicRepoId,
     challengePrivateRepo=privateRepoId,
     challengeName=name,
-    challengeTitle=(T.pack $ title),
+    challengeTitle=title,
-    challengeDescription=(T.pack $ description),
+    challengeDescription=description,
     challengeStamp=time,
     challengeImage=mImage,
     challengeStarred=False,
@@ -222,20 +303,30 @@ checkTestDir chan challengeId challenge commit testDir = do
          err chan "Cannot read metric"
          return ()
        Right opts -> do
-         _ <- runDB $ mapM (\(priority, metric) -> insert $ Test {
+         _ <- runDB $ mapM (insertOrUpdateTest testDir challengeId (SHA1 checksum) commit opts)  $ zip [1..] (gesMetrics $ geoSpec opts)
-           testChallenge=challengeId,
-           testMetric=metric,
-           testName=T.pack $ takeFileName testDir,
-           testChecksum=(SHA1 checksum),
-           testCommit=commit,
-           testActive=True,
-           testPrecision=gesPrecision $ geoSpec opts,
-           testPriority=Just priority}) $ zip [1..] (gesMetrics $ geoSpec opts)
          return ()
     else
       msg chan $ concat ["Test dir ", (T.pack testDir), " does not have expected results."]
   return ()
 
+insertOrUpdateTest testDir challengeId checksum commit opts (priority, metric) = do
+  let name=T.pack $ takeFileName testDir
+  mAlreadyExistingTest <- getBy $ UniqueChallengeNameMetricChecksum challengeId name metric checksum
+  case mAlreadyExistingTest of
+    Just (Entity testId _) -> update testId [TestCommit=.commit,
+                                            TestPrecision=.(gesPrecision $ geoSpec opts),
+                                            TestPriority=.Just priority]
+    Nothing -> do
+                _ <- insert $ Test {
+                  testChallenge=challengeId,
+                  testMetric=metric,
+                  testName=name,
+                  testChecksum=checksum,
+                  testCommit=commit,
+                  testActive=True,
+                  testPrecision=gesPrecision $ geoSpec opts,
+                  testPriority=Just priority}
+                return ()
 
 gatherSHA1 :: FilePath -> IO ByteString
 gatherSHA1 testDir = do
@@ -267,7 +358,7 @@ createChallengeForm = renderBootstrap3 BootstrapBasicForm $ (,,,,,,)
 
 updateChallengeForm :: Form (ChallengeUpdateType, Text, Text, Maybe Text, Text, Text, Maybe Text)
 updateChallengeForm = renderBootstrap3 BootstrapBasicForm $ (,,,,,,)
-    <$> areq (radioField optionsEnum) (bfs MsgChangeType) Nothing
+    <$> areq (radioField optionsEnum) "change type" (Just ChallengePatch)
     <*> areq textField (bfs MsgPublicUrl) Nothing
     <*> areq textField (bfs MsgBranch) (Just "master")
     <*> aopt textField (bfs MsgGitAnnexRemote) Nothing

Handler/Shared.hs

@@ -177,6 +177,47 @@ getHeadCommit repoDir chan = do
       err chan "cannot determine HEAD commit"
       return Nothing
 
+getPossiblyExistingRepo :: (Key Challenge -> Key Repo -> Channel -> Handler Bool)
+                          -> UserId -> Key Challenge -> RepoSpec -> Channel -> Handler (Maybe (Key Repo))
+getPossiblyExistingRepo checkRepo userId challengeId repoSpec chan = do
+  let url = repoSpecUrl repoSpec
+  let branch = repoSpecBranch repoSpec
+  let gitAnnexRemote = repoSpecGitAnnexRemote repoSpec
+  maybeRepo <- runDB $ getBy $ UniqueUrlBranch url branch
+  case maybeRepo of
+    Just (Entity repoId _) -> do
+      msg chan "Repo already there"
+      available <- checkRepo challengeId repoId chan
+      if available
+         then
+          do
+           -- this is not completely right... some other thread
+           -- might update this to a different value
+           runDB $ update repoId [RepoGitAnnexRemote =. gitAnnexRemote]
+           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
+      let repoCloningSpec = RepoCloningSpec {
+        cloningSpecRepo = repoSpec,
+        cloningSpecReferenceRepo = RepoSpec {
+                repoSpecUrl = (T.pack repoDir),
+                repoSpecBranch = (repoBranch repo),
+                repoSpecGitAnnexRemote = Nothing
+                }
+        }
+      cloneRepo' userId repoCloningSpec chan
+
+
 cloneRepo' :: UserId -> RepoCloningSpec -> Channel -> Handler (Maybe (Key Repo))
 cloneRepo' userId repoCloningSpec chan = do
       let url = repoSpecUrl $ cloningSpecRepo repoCloningSpec

Handler/ShowChallenge.hs

@@ -587,43 +587,7 @@ rawEval challengeDir metric repoDir name outF = Import.try (runGEvalGetOptions [
                                                           "--test-name", (T.unpack name)])
 
 getSubmissionRepo :: UserId -> Key Challenge -> RepoSpec -> Channel -> Handler (Maybe (Key Repo))
-getSubmissionRepo userId challengeId repoSpec chan = do
+getSubmissionRepo userId challengeId repoSpec chan = getPossiblyExistingRepo checkRepoAvailibility userId challengeId repoSpec chan
-  let url = repoSpecUrl repoSpec
-  let branch = repoSpecBranch repoSpec
-  let gitAnnexRemote = repoSpecGitAnnexRemote repoSpec
-  maybeRepo <- runDB $ getBy $ UniqueUrlBranch url branch
-  case maybeRepo of
-    Just (Entity repoId _) -> do
-      msg chan "Repo already there"
-      available <- checkRepoAvailibility challengeId repoId chan
-      if available
-         then
-          do
-           -- this is not completely right... some other thread
-           -- might update this to a different value
-           runDB $ update repoId [RepoGitAnnexRemote =. gitAnnexRemote]
-           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
-      let repoCloningSpec = RepoCloningSpec {
-        cloningSpecRepo = repoSpec,
-        cloningSpecReferenceRepo = RepoSpec {
-                repoSpecUrl = (T.pack repoDir),
-                repoSpecBranch = (repoBranch repo),
-                repoSpecGitAnnexRemote = Nothing
-                }
-        }
-      cloneRepo' userId repoCloningSpec chan
 
 checkRepoAvailibility :: Key Challenge -> Key Repo -> Channel -> Handler Bool
 checkRepoAvailibility challengeId repoId chan = do

config/models

@@ -47,6 +47,7 @@ Version
     major Int
     minor Int
     patch Int
+    UniqueVersionByCommit commit
     UniqueVersion commit major minor patch
     description Text
     stamp UTCTime default=now()

messages/en.msg

@@ -82,3 +82,4 @@ MajorChange: major change
 MinorChange: minor change
 Patch: patch
 ChangeType: change type
+Update: Update

templates/show-challenge.hamlet

@@ -10,7 +10,7 @@ $if (checkIfAdmin mUserEnt)
   $if (challengeArchived challenge /= Just True)
     <form method=post action=@{ArchiveR challengeId}#form enctype="text/plain">
       <button>Archive
-    <form method=post action=@{ChallengeUpdateR challengeId}#form enctype="text/plain">
+    <form method=get action=@{ChallengeUpdateR challengeId}#form enctype="text/plain">
       <button>Update
 
  $if (challengeArchived challenge == Just True)

templates/update-challenge.hamlet

@@ -4,4 +4,4 @@
   <form method=post action=@{ChallengeUpdateR challengeId}#form enctype=#{formEnctype}>
     ^{formWidget}
     <button .btn .btn-primary type="submit">
-       _{MsgAdd} <span class="glyphicon glyphicon-upload"></span>
+       _{MsgUpdate} <span class="glyphicon glyphicon-upload"></span>