From 2416dacffb3e9f8539a95fcadb0034eac2d30fac Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Sat, 3 Nov 2018 21:37:44 +0100 Subject: [PATCH] Description is clickable --- Handler/Tables.hs | 37 ++++++++++++++++++++++++++----------- Handler/TagUtils.hs | 7 +++++-- 2 files changed, 31 insertions(+), 13 deletions(-) diff --git a/Handler/Tables.hs b/Handler/Tables.hs index b0c3971..1a0d68a 100644 --- a/Handler/Tables.hs +++ b/Handler/Tables.hs @@ -54,15 +54,16 @@ submissionsTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> [Entity Test] submissionsTable mauthId challengeName repoScheme challengeRepo tests = mempty ++ Table.text "submitter" (formatSubmitter . (\(TableEntry _ _ (Entity _ submitter) _ _ _) -> submitter)) ++ timestampCell "when" (submissionStamp . (\(TableEntry (Entity _ s) _ _ _ _ _) -> s)) - ++ descriptionCell + ++ descriptionCell mauthId ++ mconcat (map (\(Entity k t) -> resultCell t (extractScore k)) tests) ++ statusCell challengeName repoScheme challengeRepo (\(TableEntry (Entity submissionId submission) (Entity variantId variant) (Entity userId _) _ _ _) -> (submissionId, submission, variantId, variant, userId, mauthId)) -descriptionCell :: Table site TableEntry -descriptionCell = Table.widget "description" ( - \(TableEntry (Entity _ s) (Entity _ v) _ _ tagEnts paramEnts) -> fragmentWithSubmissionTags - (descriptionToBeShown s v (map entityVal paramEnts)) - tagEnts) +descriptionCell :: Maybe UserId -> Table App TableEntry +descriptionCell mauthId = Table.widget "description" ( + \(TableEntry (Entity _ s) (Entity _ v) (Entity u _) _ tagEnts paramEnts) -> fragmentWithSubmissionTags + (descriptionToBeShown s v (map entityVal paramEnts)) + (getInfoLink s u mauthId) + tagEnts) descriptionToBeShown :: Submission -> Variant -> [Parameter] -> Text @@ -83,7 +84,7 @@ leaderboardTable mauthId challengeName repoScheme challengeRepo tests = mempty ++ Table.int "#" fst ++ Table.text "submitter" (formatSubmitter . leaderboardUser . snd) ++ timestampCell "when" (submissionStamp . leaderboardBestSubmission . snd) - ++ leaderboardDescriptionCell + ++ leaderboardDescriptionCell mauthId ++ mconcat (map (\(Entity k t) -> resultCell t (extractScoreFromLeaderboardEntry k . snd)) tests) ++ Table.int "×" (leaderboardNumberOfSubmissions . snd) ++ statusCell challengeName repoScheme challengeRepo (\(_, e) -> (leaderboardBestSubmissionId e, @@ -96,11 +97,14 @@ leaderboardTable mauthId challengeName repoScheme challengeRepo tests = mempty extractScoreFromLeaderboardEntry :: Key Test -> LeaderboardEntry -> Maybe Evaluation extractScoreFromLeaderboardEntry k entry = lookup k (leaderboardEvaluationMap entry) -leaderboardDescriptionCell :: Table site (a, LeaderboardEntry) -leaderboardDescriptionCell = Table.widget "description" ( +leaderboardDescriptionCell :: Maybe UserId -> Table App (a, LeaderboardEntry) +leaderboardDescriptionCell mauthId = Table.widget "description" ( \(_,entry) -> fragmentWithSubmissionTags (descriptionToBeShown (leaderboardBestSubmission entry) (leaderboardBestVariant entry) (leaderboardParams entry)) + (getInfoLink (leaderboardBestSubmission entry) + (leaderboardUserId entry) + mauthId) (leaderboardTags entry) ) @@ -120,12 +124,12 @@ statusCell challengeName repoScheme challengeRepo fun = Table.widget "" (statusC resultCell :: Test -> (a -> Maybe Evaluation) -> Table App a resultCell test fun = hoverTextCell (formatTestForHtml test) (formatTruncatedScore (testPrecision test) . fun) (formatFullScore . fun) -statusCellWidget :: Eq a => Text -> RepoScheme -> Repo -> (SubmissionId, Submission, VariantId, Variant, a, Maybe a) -> WidgetFor App () +statusCellWidget :: Text -> RepoScheme -> Repo -> (SubmissionId, Submission, VariantId, Variant, UserId, Maybe UserId) -> WidgetFor App () statusCellWidget challengeName repoScheme challengeRepo (submissionId, submission, variantId, _, userId, mauthId) = $(widgetFile "submission-status") where commitHash = fromSHA1ToText $ submissionCommit submission isPublic = submissionIsPublic submission isOwner = (mauthId == Just userId) - isVisible = isPublic || isOwner + isVisible = checkWhetherVisible submission userId mauthId publicSubmissionBranch = getPublicSubmissionBranch submissionId maybeBrowsableUrl = if isPublic then @@ -133,6 +137,17 @@ statusCellWidget challengeName repoScheme challengeRepo (submissionId, submissio else Nothing +getInfoLink :: Submission -> UserId -> Maybe UserId -> Maybe (Route App) +getInfoLink submission userId mauthId = if checkWhetherVisible submission userId mauthId + then Just $ QueryResultsR commitHash + else Nothing + where commitHash = fromSHA1ToText $ submissionCommit submission + +checkWhetherVisible :: Submission -> UserId -> Maybe UserId -> Bool +checkWhetherVisible submission userId mauthId = isPublic || isOwner + where isPublic = submissionIsPublic submission + isOwner = (mauthId == Just userId) + getAuxSubmissionEnts :: Key Test -> [TableEntry] -> [(Key User, (User, [(Entity Submission, Entity Variant, Evaluation)]))] getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluationMaps where processEvaluationMap (TableEntry s v (Entity ui u) m _ _) = (ui, (u, case Map.lookup testId m of diff --git a/Handler/TagUtils.hs b/Handler/TagUtils.hs index 40a3bfa..951e2aa 100644 --- a/Handler/TagUtils.hs +++ b/Handler/TagUtils.hs @@ -38,8 +38,11 @@ $forall (Entity _ v) <- tagEnts \ #{tagName v} |] -fragmentWithSubmissionTags t tagEnts = [whamlet| -#{t} +fragmentWithSubmissionTags t mLink tagEnts = [whamlet| +$maybe link <- mLink + #{t} +$nothing + #{t} $forall ((Entity _ v), (Entity sid s)) <- tagEnts \ #{tagName v}