a submission can be removed now (actually hidden)

Handler/EditSubmission.hs

@@ -8,6 +8,7 @@ import Handler.SubmissionView
 import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs)
 
 import Handler.TagUtils
+import Handler.MakePublic
 
 import Data.Text as T
 
@@ -45,6 +46,7 @@ postEditSubmissionR submissionId = do
   getEditSubmissionR submissionId
 
 
+getPossibleAchievements :: (BaseBackend backend ~ SqlBackend, PersistUniqueRead backend, PersistQueryRead backend, MonadIO m) => Key User -> Key Submission -> ReaderT backend m [(Entity Achievement, Key WorkingOn)]
 getPossibleAchievements userId submissionId = do
   (Just submission) <- get submissionId
   let challengeId = submissionChallenge submission
@@ -60,7 +62,7 @@ doEditSubmission formWidget formEnctype submissionId = do
 
   tagsAvailableAsJSON <- runDB $ getAvailableTagsAsJSON
 
-  (Entity userId user) <- requireAuth
+  (Entity userId _) <- requireAuth
 
   achievements <- runDB $ getPossibleAchievements userId submissionId
 
@@ -72,3 +74,26 @@ editSubmissionForm :: Text -> Maybe Text -> Form (Text, Maybe Text)
 editSubmissionForm description mTags = renderBootstrap3 BootstrapBasicForm $ (,)
     <$> areq textField (bfs MsgSubmissionDescription) (Just description)
     <*> aopt textField (tagsfs MsgSubmissionTags) (Just mTags)
+
+
+getHideSubmissionR :: SubmissionId -> Handler Html
+getHideSubmissionR submissionId = changeSubmissionVisibility False submissionId
+
+getRestoreSubmissionR :: SubmissionId -> Handler Html
+getRestoreSubmissionR submissionId = changeSubmissionVisibility True submissionId
+
+
+changeSubmissionVisibility :: Bool -> SubmissionId -> Handler Html
+changeSubmissionVisibility status submissionId =
+ do
+  isOwner <- checkWhetherUserRepo submissionId
+  if isOwner
+    then
+     do
+      runDB $ update submissionId [SubmissionIsHidden =. Just (not status)]
+      setMessage $ toHtml (("Submission " :: Text) ++ (verb status))
+    else
+      setMessage $ toHtml ("Only owner can edit a submission!!!" :: Text)
+  getEditSubmissionR submissionId
+  where verb True = "restored"
+        verb False = "removed"

Handler/MakePublic.hs

@@ -40,7 +40,7 @@ doMakePublic submissionId chan = do
 
 pushRepo :: String -> SHA1 -> String -> String -> Channel -> Handler ()
 pushRepo repoDir commit targetRepoUrl targetBranchName chan = do
-  (exitCode, _) <- runProgram (Just repoDir) gitPath [
+  (_, _) <- runProgram (Just repoDir) gitPath [
     "push",
     targetRepoUrl,
     (T.unpack $ fromSHA1ToText commit) ++ ":refs/heads/" ++ targetBranchName] chan

Handler/ShowChallenge.hs

@@ -215,7 +215,8 @@ getSubmission userId repoId commit challengeId description chan = do
         submissionDescription=description,
         submissionStamp=time,
         submissionSubmitter=userId,
-        submissionIsPublic=False }
+        submissionIsPublic=False,
+        submissionIsHidden=Just False }
 
 parseCommitMessage :: Maybe Text -> (Maybe Text, Maybe Text)
 parseCommitMessage Nothing = (Nothing, Nothing)
@@ -425,7 +426,7 @@ getChallengeAllSubmissionsR name = getChallengeSubmissions (\_ -> True) name
 
 getChallengeSubmissions :: ((Entity Submission) -> Bool) -> Text -> Handler Html
 getChallengeSubmissions condition name = do
-  challengeEnt@(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
+  Entity challengeId challenge <- runDB $ getBy404 $ UniqueName name
   (evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId
   mauth <- maybeAuth
   let muserId = (\(Entity uid _) -> uid) <$> mauth

Handler/Tables.hs

@@ -20,7 +20,6 @@ import qualified Data.List as DL
 
 import GEval.Core
 
-import Text.Printf
 
 data LeaderboardEntry = LeaderboardEntry {
   leaderboardUser :: User,
@@ -40,6 +39,7 @@ submissionsTable mauthId challengeName repoScheme challengeRepo tests = mempty
   ++ mconcat (map (\(Entity k t) -> resultCell t (extractScore k)) tests)
   ++ statusCell challengeName repoScheme challengeRepo (\(Entity submissionId submission, Entity userId _, _, _) -> (submissionId, submission, userId, mauthId))
 
+descriptionCell :: Foldable t => Table site (Entity Submission, b, c, t (Entity Tag, Entity SubmissionTag))
 descriptionCell = Table.widget "description" (
   \(Entity _ s, _, _ ,tagEnts) -> fragmentWithSubmissionTags (submissionDescription s) tagEnts)
 
@@ -59,6 +59,7 @@ leaderboardTable mauthId challengeName repoScheme challengeRepo test = mempty
                                        leaderboardUserId e,
                                        mauthId))
 
+leaderboardDescriptionCell :: Table site (a, LeaderboardEntry)
 leaderboardDescriptionCell = Table.widget "description" (
   \(_,entry) -> fragmentWithSubmissionTags (submissionDescription $ leaderboardBestSubmission entry) (leaderboardTags entry))
 
@@ -78,6 +79,7 @@ statusCell challengeName repoScheme challengeRepo fun = Table.widget "" (statusC
 resultCell :: Test -> (a -> Maybe Evaluation) -> Table App a
 resultCell test fun = hoverTextCell ((testName test) ++ "/" ++ (Data.Text.pack $ show $ testMetric test)) (formatTruncatedScore (testPrecision test) . fun) (formatFullScore . fun)
 
+statusCellWidget :: Eq a => Text -> RepoScheme -> Repo -> (SubmissionId, Submission, a, Maybe a) -> WidgetFor App ()
 statusCellWidget challengeName repoScheme challengeRepo (submissionId, submission, userId, mauthId) = $(widgetFile "submission-status")
     where commitHash = fromSHA1ToText $ submissionCommit submission
           isPublic = submissionIsPublic submission
@@ -91,15 +93,15 @@ statusCellWidget challengeName repoScheme challengeRepo (submissionId, submissio
                                   Nothing
 
 getAuxSubmissions :: Key Test -> [(Entity Submission, Entity User, Map (Key Test) Evaluation)] -> [(Key User, (User, [(Submission, Evaluation)]))]
-getAuxSubmissions testId evaluationMaps = map (processEvaluationMap testId) evaluationMaps
+getAuxSubmissions testId evaluationMaps = map processEvaluationMap evaluationMaps
-   where processEvaluationMap testId ((Entity _ s), (Entity ui u), m) = (ui, (u, case Map.lookup testId m of
+   where processEvaluationMap ((Entity _ s), (Entity ui u), m) = (ui, (u, case Map.lookup testId m of
                                                                                        Just e -> [(s, e)]
                                                                                        Nothing -> []))
 
 
 getAuxSubmissionEnts :: Key Test -> [(Entity Submission, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)])] -> [(Key User, (User, [((Entity Submission), Evaluation)]))]
-getAuxSubmissionEnts testId evaluationMaps = map (processEvaluationMap testId) evaluationMaps
+getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluationMaps
-   where processEvaluationMap testId (s, (Entity ui u), m, _) = (ui, (u, case Map.lookup testId m of
+   where processEvaluationMap (s, (Entity ui u), m, _) = (ui, (u, case Map.lookup testId m of
                                                                                        Just e -> [(s, e)]
                                                                                        Nothing -> []))
 
@@ -114,25 +116,28 @@ getLeaderboardEntries challengeId = do
   let auxSubmissions = getAuxSubmissionEnts mainTestId evaluationMaps
   let submissionsByUser = Map.fromListWith (\(u1, l1) (_, l2) -> (u1, l1++l2)) auxSubmissions
   let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluation a) (evaluationScore $ leaderboardEvaluation b)
-  entries' <- mapM (toEntry mainTest) $ filter (\(_, (_, s)) -> not (null s)) $ Map.toList submissionsByUser
+  entries' <- mapM (toEntry challengeId mainTest) $ filter (\(_, (_, s)) -> not (null s)) $ Map.toList submissionsByUser
   let entries = sortBy (flip entryComparator) entries'
   return (mainTest, entries)
 
 
-toEntry mainTest (ui, (u, ss)) = do
+toEntry :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistQueryRead (YesodPersistBackend site), YesodPersist site, Foldable t) => Key Challenge -> Test -> (Key User, (User, t (Entity Submission, Evaluation))) -> HandlerFor site LeaderboardEntry
-  let bestOne = DL.maximumBy (submissionComparator mainTest) ss
+toEntry challengeId mainTest (ui, (u, ss)) = do
+  let bestOne = DL.maximumBy submissionComparator ss
   let submissionId = entityKey $ fst bestOne
   tagEnts <- runDB $ getTags submissionId
+  -- get all user submissions, including hidden ones
+  allUserSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId, SubmissionSubmitter ==. ui] [Desc SubmissionStamp]
   return $ LeaderboardEntry {
               leaderboardUser = u,
               leaderboardUserId = ui,
               leaderboardBestSubmission = (\(Entity _ s) -> s) $ fst bestOne,
               leaderboardBestSubmissionId = (\(Entity si _) -> si) $ fst bestOne,
               leaderboardEvaluation = snd bestOne,
-              leaderboardNumberOfSubmissions = length ss,
+              leaderboardNumberOfSubmissions = length allUserSubmissions,
               leaderboardTags = tagEnts
               }
-     where submissionComparator mainTest (_, e1) (_, e2) = (compareResult mainTest) (evaluationScore e1) (evaluationScore e2)
+     where submissionComparator (_, e1) (_, e2) = (compareResult mainTest) (evaluationScore e1) (evaluationScore e2)
 
 
 compareResult :: Test -> Maybe Double -> Maybe Double -> Ordering
@@ -147,7 +152,7 @@ compareFun TheHigherTheBetter = compare
 
 getChallengeSubmissionInfos :: ((Entity Submission) -> Bool) -> Key Challenge -> Handler ([(Entity Submission, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)])], [Entity Test])
 getChallengeSubmissionInfos condition challengeId = do
-  allSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId] [Desc SubmissionStamp]
+  allSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId, SubmissionIsHidden !=. Just True] [Desc SubmissionStamp]
   let submissions = filter condition allSubmissions
   tests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] []
   evaluationMaps <- mapM getEvaluationMap submissions

config/models

@@ -57,6 +57,7 @@ Submission
     stamp UTCTime default=now()
     submitter UserId
     isPublic Bool default=False
+    isHidden Bool Maybe
     UniqueSubmissionRepoCommitChallenge repo commit challenge
 Fork
     source SubmissionId

config/routes

@@ -30,6 +30,8 @@
 /api/txt/score/#Text ApiTxtScoreR GET
 
 /make-public/#SubmissionId MakePublicR GET
+/hide-submission/#SubmissionId HideSubmissionR GET
+/restore-submission/#SubmissionId RestoreSubmissionR GET
 
 /account YourAccountR GET POST
 /avatar/#UserId AvatarR GET

messages/en.msg

@@ -60,3 +60,5 @@ Presentation: presentation
 GonitoInClass: Gonito in class
 GitAnnexRemote: git-annex remote (if needed)
 SubmissionGitAnnexRemote: git-annex remote specification (if needed)
+RemoveSubmission: remove submission
+RestoreSubmission: restore submission

templates/edit-submission.hamlet

@@ -10,3 +10,13 @@
 <ul>
  $forall (achievement, workingOnId) <- achievements
   <li><a href=@{SubmissionForAchievementR submissionId workingOnId}>send to review for #{achievementName $ entityVal achievement} achievement
+
+<h4>
+
+$if submissionIsHidden submission == Just True
+  <p>Submission is hidden!
+  <p>
+    <a href=@{RestoreSubmissionR submissionId}>_{MsgRestoreSubmission}
+$else
+  <p>
+    <a href=@{HideSubmissionR submissionId}>_{MsgRemoveSubmission}

templates/submission-status.hamlet

@@ -2,6 +2,9 @@ $if isOwner
   <a href="@{EditSubmissionR submissionId}">
     <span class="glyphicon glyphicon-pencil" title="click to edit the submission" aria-hidden="true">
 
+  <a href="@{HideSubmissionR submissionId}">
+    <span class="glyphicon glyphicon-remove" title="click to remove the submission" aria-hidden="true">
+
 $if isVisible
   <a href="@{QueryResultsR commitHash}">
     <span class="glyphicon glyphicon-info-sign" title="click to see the detailed information" aria-hidden="true">