Challenges can be archived

Foundation.hs

@@ -163,6 +163,10 @@ instance Yesod App where
     isAuthorized CreateResetLinkR _ = isAdmin
     isAuthorized (ScoreR _) _ = isAdmin
 
+    isAuthorized ListArchivedChallengesR _ = isAdmin
+    isAuthorized (ArchiveR _) _ = isAdmin
+    isAuthorized (UnarchiveR _) _ = isAdmin
+
     isAuthorized MyScoreR _ = return Authorized
 
     isAuthorized (ResetPasswordR _) _ = return Authorized

Handler/CreateChallenge.hs

@@ -120,7 +120,8 @@ addChallenge name publicRepoId privateRepoId chan = do
     challengeDescription=(T.pack $ description),
     challengeStamp=time,
     challengeImage=mImage,
-    challengeStarred=False}
+    challengeStarred=False,
+    challengeArchived=Just False}
   updateTests challengeId chan
   return ()
 

Handler/ListChallenges.hs

@@ -3,8 +3,13 @@ module Handler.ListChallenges where
 import Import
 
 getListChallengesR :: Handler Html
-getListChallengesR = do
+getListChallengesR = generalListChallenges [ChallengeArchived !=. Just True]
-  challenges <- runDB $ selectList [] [Desc ChallengeStarred, Desc ChallengeStamp]
+
+getListArchivedChallengesR :: Handler Html
+getListArchivedChallengesR = generalListChallenges [ChallengeArchived ==. Just True]
+
+generalListChallenges filterExpr = do
+  challenges <- runDB $ selectList filterExpr [Desc ChallengeStarred, Desc ChallengeStamp]
   defaultLayout $ do
     setTitle "List challenges"
     $(widgetFile "list-challenges")

Handler/ShowChallenge.hs

@@ -18,6 +18,7 @@ import Handler.Tables
 import Handler.TagUtils
 import Handler.MakePublic
 import Handler.Dashboard
+import Handler.Common
 
 import Gonito.ExtractMetadata (ExtractionOptions(..),
                                extractMetadataFromRepoDir,
@@ -54,11 +55,10 @@ getShowChallengeR name = do
   app <- getYesod
   let leaderboardStyle = appLeaderboardStyle $ appSettings app
 
-  (Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
+  challengeEnt@(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
   Just repo <- runDB $ get $ challengePublicRepo challenge
   (leaderboard, (entries, tests)) <- getLeaderboardEntries leaderboardStyle challengeId
   mauth <- maybeAuth
-  let muserId = (\(Entity uid _) -> uid) <$> mauth
 
   let params = getNumericalParams entries
 
@@ -66,8 +66,9 @@ getShowChallengeR name = do
 
   challengeRepo <- runDB $ get404 $ challengePublicRepo challenge
 
-  challengeLayout True challenge (showChallengeWidget muserId
+  challengeLayout True challenge (showChallengeWidget mauth
-                                                      challenge scheme
+                                                      challengeEnt
+                                                      scheme
                                                       challengeRepo
                                                       repo
                                                       leaderboard
@@ -89,8 +90,8 @@ challengeReadme name = do
   contents <- liftIO $ System.IO.readFile readmeFilePath
   return $ markdown def $ TL.pack contents
 
-showChallengeWidget :: Maybe UserId
+showChallengeWidget :: Maybe (Entity User)
-                      -> Challenge
+                      -> Entity Challenge
                       -> RepoScheme
                       -> Repo
                       -> Repo
@@ -98,8 +99,8 @@ showChallengeWidget :: Maybe UserId
                       -> [Text]
                       -> [Entity Test]
                       -> WidgetFor App ()
-showChallengeWidget muserId
+showChallengeWidget mUserEnt
-                    challenge
+                    (Entity challengeId challenge)
                     scheme
                     challengeRepo
                     repo
@@ -111,6 +112,7 @@ showChallengeWidget muserId
         maybeRepoLink = getRepoLink repo
         delta = Number 4
         higherTheBetterArray = getIsHigherTheBetterArray $ map entityVal tests
+        mUserId = entityKey <$> mUserEnt
 
 getRepoLink :: Repo -> Maybe Text
 getRepoLink repo
@@ -180,6 +182,22 @@ challengeHowTo challenge settings repo shownId isIDSet isSSHUploaded mToken = $(
           SelfHosted -> "master" :: Text
           _ -> "my-brilliant-branch"
 
+postArchiveR :: ChallengeId -> Handler Html
+postArchiveR challengeId = doSetArchive True challengeId
+
+postUnarchiveR :: ChallengeId -> Handler Html
+postUnarchiveR challengeId = doSetArchive False challengeId
+
+doSetArchive :: Bool -> ChallengeId -> Handler Html
+doSetArchive status challengeId = do
+  runDB $ update challengeId [ChallengeArchived =. Just status]
+  challenge <- runDB $ get404 challengeId
+  getShowChallengeR $ challengeName challenge
+
+
+archiveForm :: ChallengeId -> Form ChallengeId
+archiveForm challengeId = renderBootstrap3 BootstrapBasicForm $ areq hiddenField "" (Just challengeId)
+
 getChallengeSubmissionR :: Text -> Handler Html
 getChallengeSubmissionR name = do
    (Entity _ challenge) <- runDB $ getBy404 $ UniqueName name
@@ -235,14 +253,20 @@ trigger userId challengeName url mBranch mGitAnnexRemote = do
     Just (Entity challengeId _) -> runOpenViewProgress $ doCreateSubmission userId challengeId
                                                                            Nothing Nothing
                                                                            RepoSpec {repoSpecUrl=url,
-                                                                                     repoSpecBranch=branch,
+                                                                           repoSpecBranch=branch,
-                                                                                     repoSpecGitAnnexRemote=mGitAnnexRemote}
+                                                                           repoSpecGitAnnexRemote=mGitAnnexRemote}
     Nothing -> return $ toTypedContent (("Unknown challenge `" ++ (Data.Text.unpack challengeName) ++ "`. Cannot be triggered, must be submitted manually at Gonito.net!\n") :: String)
 
 doCreateSubmission :: UserId -> Key Challenge -> Maybe Text -> Maybe Text -> RepoSpec -> Channel -> Handler ()
 doCreateSubmission userId challengeId mDescription mTags repoSpec chan = do
-  maybeRepoKey <- getSubmissionRepo userId challengeId repoSpec chan
+  challenge <- runDB $ get404 challengeId
-  case maybeRepoKey of
+  doCreateSubmission' (challengeArchived challenge) userId challengeId mDescription mTags repoSpec chan
+
+doCreateSubmission' :: Maybe Bool -> UserId -> Key Challenge -> Maybe Text -> Maybe Text -> RepoSpec -> Channel -> Handler ()
+doCreateSubmission' (Just True) _ _ _ _ _ chan = msg chan "This challenge is archived, you cannot submit to it. Ask the site admin to unarchive it."
+doCreateSubmission' _ userId challengeId mDescription mTags repoSpec chan = do
+   maybeRepoKey <- getSubmissionRepo userId challengeId repoSpec chan
+   case maybeRepoKey of
     Just repoId -> do
 
       challenge <- runDB $ get404 challengeId

config/models

@@ -39,6 +39,7 @@ Challenge
     stamp UTCTime default=now()
     image ByteString Maybe
     starred Bool
+    archived Bool Maybe
 Test
     challenge ChallengeId
     metric Metric

config/routes

@@ -10,6 +10,7 @@
 /view-progress/#Int ViewProgressR GET
 /open-view-progress/#Int OpenViewProgressR GET
 /list-challenges ListChallengesR GET
+/list-archived-challenges ListArchivedChallengesR GET
 /challenge-image/#ChallengeId ChallengeImageR GET
 
 /challenge/#Text ShowChallengeR GET
@@ -36,6 +37,9 @@
 /hide-submission/#SubmissionId HideSubmissionR GET
 /restore-submission/#SubmissionId RestoreSubmissionR GET
 
+/challenge-archive/#ChallengeId ArchiveR POST
+/challenge-unarchive/#ChallengeId UnarchiveR POST
+
 /account YourAccountR GET POST
 /avatar/#UserId AvatarR GET
 /create-reset-link CreateResetLinkR GET POST

messages/en.msg

@@ -76,3 +76,4 @@ TargetValue: target value to be reached before the target date
 Test: test
 Dashboard: dashboard
 TargetName: target name
+ShowArchivedChallenges: show archived challenges

templates/default-layout.hamlet

@@ -27,6 +27,7 @@
                             <li><a href="@{CreateChallengeR}">_{MsgCreateChallenge}</a>
                             <li><a href="@{CreateResetLinkR}">_{MsgCreateResetLink}</a>
                             <li><a href="@{ExtraPointsR}">_{MsgAddExtraPoints}</a>
+                            <li><a href="@{ListArchivedChallengesR}">_{MsgShowArchivedChallenges}</a>
 
           <ul class="nav navbar-nav navbar-collapse collapse navbar-right">
             <li class="dropdown">

templates/show-challenge.hamlet

@@ -3,9 +3,20 @@ $maybe repoLink  <- maybeRepoLink
   (Browse at <tt><a href="#{repoLink}">#{repoLink}</a></tt>)
 $nothing
 
+$if (challengeArchived challenge == Just True)
+  <p><b>This challenge is archived!
+
+$if (checkIfAdmin mUserEnt)
+  $if (challengeArchived challenge /= Just True)
+    <form method=post action=@{ArchiveR challengeId}#form enctype="text/plain">
+      <button>Archive
+  $if (challengeArchived challenge == Just True)
+    <form method=post action=@{UnarchiveR challengeId}#form enctype="text/plain">
+      <button>Unarchive
+
 <h2>Leaderboard
 
-^{Table.buildBootstrap (leaderboardTable muserId (challengeName challenge) scheme challengeRepo tests) leaderboardWithRanks}
+^{Table.buildBootstrap (leaderboardTable mUserId (challengeName challenge) scheme challengeRepo tests) leaderboardWithRanks}
 
 <div id="graph-container">