diff --git a/Foundation.hs b/Foundation.hs index eb96f1d..9b1bfc9 100644 --- a/Foundation.hs +++ b/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 diff --git a/Handler/Shared.hs b/Handler/Shared.hs index bf6a0b7..5b81c73 100644 --- a/Handler/Shared.hs +++ b/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 () diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index f0b51b8..52e3d77 100644 --- a/Handler/ShowChallenge.hs +++ b/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 diff --git a/config/routes b/config/routes index 3753dd0..658ffe3 100644 --- a/config/routes +++ b/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 diff --git a/messages/en.msg b/messages/en.msg index 1e0d53c..a2a83a9 100644 --- a/messages/en.msg +++ b/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 diff --git a/templates/show-challenge.hamlet b/templates/show-challenge.hamlet index b7c578e..18a7ed6 100644 --- a/templates/show-challenge.hamlet +++ b/templates/show-challenge.hamlet @@ -4,18 +4,23 @@ $maybe repoLink <- maybeRepoLink $nothing $if (challengeArchived challenge == Just True) -

This challenge is archived! +

_{MsgChallengeIsArchived} $if (checkIfAdmin mUserEnt) $if (challengeArchived challenge /= Just True)

-