From 7b7001845df65683c9892341c4d3bb1f96b81a21 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Filip=20Grali=C5=84ski?= Date: Wed, 27 Jun 2018 13:09:11 +0200 Subject: [PATCH] a submission can be removed now (actually hidden) --- Handler/EditSubmission.hs | 27 ++++++++++++++++++++++++++- Handler/MakePublic.hs | 2 +- Handler/ShowChallenge.hs | 5 +++-- Handler/Tables.hs | 27 ++++++++++++++++----------- config/models | 1 + config/routes | 2 ++ messages/en.msg | 2 ++ templates/edit-submission.hamlet | 10 ++++++++++ templates/submission-status.hamlet | 3 +++ 9 files changed, 64 insertions(+), 15 deletions(-) diff --git a/Handler/EditSubmission.hs b/Handler/EditSubmission.hs index 9ba137a..8685ea1 100644 --- a/Handler/EditSubmission.hs +++ b/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" diff --git a/Handler/MakePublic.hs b/Handler/MakePublic.hs index bac1fb2..4918252 100644 --- a/Handler/MakePublic.hs +++ b/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 diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index 2e1c939..9ebb06e 100644 --- a/Handler/ShowChallenge.hs +++ b/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 diff --git a/Handler/Tables.hs b/Handler/Tables.hs index dc55828..5cf4430 100644 --- a/Handler/Tables.hs +++ b/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 - where processEvaluationMap testId ((Entity _ s), (Entity ui u), m) = (ui, (u, case Map.lookup testId m of +getAuxSubmissions testId evaluationMaps = map processEvaluationMap evaluationMaps + 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 - where processEvaluationMap testId (s, (Entity ui u), m, _) = (ui, (u, case Map.lookup testId m of +getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluationMaps + 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 - let bestOne = DL.maximumBy (submissionComparator mainTest) ss +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 +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 diff --git a/config/models b/config/models index c054535..cc32007 100644 --- a/config/models +++ b/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 diff --git a/config/routes b/config/routes index 99964da..69bb216 100644 --- a/config/routes +++ b/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 diff --git a/messages/en.msg b/messages/en.msg index 6cc02a0..ae15c3c 100644 --- a/messages/en.msg +++ b/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 diff --git a/templates/edit-submission.hamlet b/templates/edit-submission.hamlet index d2c70a5..6faaab0 100644 --- a/templates/edit-submission.hamlet +++ b/templates/edit-submission.hamlet @@ -10,3 +10,13 @@