Challenges can be archived

2019-03-20 16:31:08 +01:00 · 2019-03-20 16:31:08 +01:00 · 27efefeb13
commit 27efefeb13
parent 34394c072d
9 changed files with 68 additions and 16 deletions
--- a/Foundation.hs
+++ b/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
--- a/Handler/CreateChallenge.hs
+++ b/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 ()

--- a/Handler/ListChallenges.hs
+++ b/Handler/ListChallenges.hs
@ -3,8 +3,13 @@ module Handler.ListChallenges where
 import Import

 getListChallengesR :: Handler Html
-getListChallengesR = do
-  challenges <- runDB $ selectList [] [Desc ChallengeStarred, Desc ChallengeStamp]
+getListChallengesR = generalListChallenges [ChallengeArchived !=. Just True]
+
+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")
--- a/Handler/ShowChallenge.hs
+++ b/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
-                                                      challenge scheme
+  challengeLayout True challenge (showChallengeWidget mauth
+                                                      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
-                      -> Challenge
+showChallengeWidget :: Maybe (Entity User)
+                      -> Entity Challenge
                      -> RepoScheme
                      -> Repo
                      -> Repo
@ -98,8 +99,8 @@ showChallengeWidget :: Maybe UserId
                      -> [Text]
                      -> [Entity Test]
                      -> WidgetFor App ()
-showChallengeWidget muserId
-                    challenge
+showChallengeWidget mUserEnt
+                    (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,
-                                                                                     repoSpecGitAnnexRemote=mGitAnnexRemote}
+                                                                           repoSpecBranch=branch,
+                                                                           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
-  case maybeRepoKey of
+  challenge <- runDB $ get404 challengeId
+  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
--- a/config/models
+++ b/config/models
@ -39,6 +39,7 @@ Challenge
    stamp UTCTime default=now()
    image ByteString Maybe
    starred Bool
+    archived Bool Maybe
 Test
    challenge ChallengeId
    metric Metric
--- a/config/routes
+++ b/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
--- a/messages/en.msg
+++ b/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
--- a/templates/default-layout.hamlet
+++ b/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">
--- a/templates/show-challenge.hamlet
+++ b/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">