Add challenge healing

Foundation.hs

@@ -208,6 +208,7 @@ instance Yesod App where
     isAuthorized (ArchiveR _) _ = isAdmin
     isAuthorized (UnarchiveR _) _ = isAdmin
     isAuthorized (ChallengeUpdateR _) _ = isAdmin
+    isAuthorized (HealR _) _ = isAdmin
 
     isAuthorized MyScoreR _ = regularAuthorization
 

Handler/Shared.hs

@@ -15,8 +15,6 @@ import qualified Data.Text.Encoding as DTE
 
 import Database.Persist.Sql (fromSqlKey)
 
-import Data.Scientific
-
 import Control.Concurrent.Lifted (threadDelay)
 import Control.Concurrent (forkIO)
 
@@ -341,13 +339,19 @@ getStuffUsingGitAnnex tmpRepoDir (Just gitAnnexRemote) = do
 runGitAnnex :: FilePath -> [String] -> Runner ()
 runGitAnnex tmpRepoDir args = runProg (Just tmpRepoDir) gitPath ("annex":args)
 
+doesRepoExistsOnTheDisk :: RepoId -> Handler Bool
+doesRepoExistsOnTheDisk repoId = do
+  repoDir <- getRepoDir repoId
+  repoDirExists <- liftIO $ doesDirectoryExist repoDir
+  return repoDirExists
+
 -- Gets a directory for an already cloned repo (e.g. arena/r1234). If,
 -- for some reason, the directory does not exist (e.g. the database
 -- was recovered on a new computer), it will re-clone the repository.
 getRepoDirOrClone :: RepoId -> Channel -> Handler FilePath
 getRepoDirOrClone repoId chan = do
+  repoDirExists <- doesRepoExistsOnTheDisk repoId
   repoDir <- getRepoDir repoId
-  repoDirExists <- liftIO $ doesDirectoryExist repoDir
   if repoDirExists
     then
       return ()

Handler/ShowChallenge.hs

@@ -188,6 +188,9 @@ getShowChallengeR challengeName = do
   let leaderboardStyle = appLeaderboardStyle $ appSettings app
 
   challengeEnt@(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName challengeName
+
+  isHealthy <- isChallengeHealthy challenge
+
   Just repo <- runDB $ get $ challengePublicRepo challenge
   (leaderboard, (entries, tests)) <- getLeaderboardEntries 1 leaderboardStyle challengeId
 
@@ -218,7 +221,8 @@ getShowChallengeR challengeName = do
                                                       altLeaderboard
                                                       params
                                                       tests
-                                                      altTests)
+                                                      altTests
+                                                      isHealthy)
 
 hasMetricsOfSecondPriority :: (PersistQueryRead backend, MonadIO m, BaseBackend backend ~ SqlBackend) => Key Challenge -> ReaderT backend m Bool
 hasMetricsOfSecondPriority challengeId = do
@@ -265,6 +269,13 @@ challengeReadme challengeName = do
   theContents <- doChallengeReadmeContents challengeName
   return $ markdown def theContents
 
+-- Checks whether the directories with repos are available
+isChallengeHealthy :: Challenge -> Handler Bool
+isChallengeHealthy challenge = do
+  publicRepoDirExists <- doesRepoExistsOnTheDisk $ challengePublicRepo challenge
+  privateRepoDirExists <- doesRepoExistsOnTheDisk $ challengePrivateRepo challenge
+  return $ publicRepoDirExists && privateRepoDirExists
+
 doChallengeReadmeContents :: Text -> Handler TL.Text
 doChallengeReadmeContents challengeName = do
   (Entity _ challenge) <- runDB $ getBy404 $ UniqueName challengeName
@@ -284,6 +295,7 @@ showChallengeWidget :: Maybe (Entity User)
                       -> [Text]
                       -> [Entity Test]
                       -> (Maybe [Entity Test])
+                      -> Bool
                       -> WidgetFor App ()
 showChallengeWidget mUserEnt
                     (Entity challengeId challenge)
@@ -295,6 +307,7 @@ showChallengeWidget mUserEnt
                     params
                     tests
                     mAltTests
+                    isHealthy
   = $(widgetFile "show-challenge")
   where leaderboardWithRanks = zip [1..] leaderboard
         mAltLeaderboardWithRanks = zip [1..] <$> mAltLeaderboard
@@ -374,6 +387,15 @@ challengeHowTo challenge settings repo shownId isIDSet isSSHUploaded mAltRepoSch
           Just altRepoScheme -> encodeSlash (altRepoScheme <> (challengeName challenge))
           Nothing -> "URL_TO_YOUR_REPO"
 
+postHealR :: ChallengeId -> Handler TypedContent
+postHealR challengeId = runViewProgress $ doHeal challengeId
+
+doHeal challengeId chan = do
+  challenge <- runDB $ get404 challengeId
+  getRepoDirOrClone (challengePrivateRepo challenge) chan
+  getRepoDirOrClone (challengePublicRepo challenge) chan
+  return ()
+
 postArchiveR :: ChallengeId -> Handler Html
 postArchiveR challengeId = doSetArchive True challengeId
 

config/routes

@@ -66,6 +66,7 @@
 
 /challenge-archive/#ChallengeId ArchiveR POST
 /challenge-unarchive/#ChallengeId UnarchiveR POST
+/challenge-heal/#ChallengeId HealR POST
 
 /account YourAccountR GET POST
 /avatar/#UserId AvatarR GET

messages/en.msg

@@ -94,3 +94,8 @@ ShouldChallengeBeValidated: validate challenge (do not switch off unless you hav
 ShowAnnotations: show annotations
 Compare: Compare
 OutSha1: Output Sha1 hash
+ChallengeIsArchived: This challenge is archived!
+ChallengeNotHealthy: Something is wrong with the challenge data!
+Archive: Archive
+Unarchive: Unarchive
+Heal: Heal

templates/show-challenge.hamlet

@@ -4,18 +4,23 @@ $maybe repoLink  <- maybeRepoLink
 $nothing
 
 $if (challengeArchived challenge == Just True)
-  <p><b>This challenge is archived!
+  <p><b>_{MsgChallengeIsArchived}
 
 $if (checkIfAdmin mUserEnt)
   $if (challengeArchived challenge /= Just True)
     <form method=post action=@{ArchiveR challengeId}#form enctype="text/plain">
-      <button>Archive
+      <button>_{MsgArchive}
     <form method=get action=@{ChallengeUpdateR challengeId}#form enctype="text/plain">
-      <button>Update
+      <button>_{MsgUpdate}
 
  $if (challengeArchived challenge == Just True)
     <form method=post action=@{UnarchiveR challengeId}#form enctype="text/plain">
-      <button>Unarchive
+      <button>_{MsgUnarchive}
+
+ $if not isHealthy
+     _{MsgChallengeNotHealthy} <form method=post action=@{HealR challengeId}#form enctype="text/plain">
+         <button>_{MsgHeal}
+
 
 <h2>Leaderboard