From c0a06ae11215d75216b3d0982cd1613aec492cab Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Sat, 30 Nov 2019 11:04:52 +0100 Subject: [PATCH] First version of viewing a specific variant --- Handler/Dashboard.hs | 6 +++++- Handler/Graph.hs | 4 ++-- Handler/Presentation.hs | 4 ++-- Handler/Query.hs | 30 +++++++++++++++++++++++++----- Handler/ShowChallenge.hs | 6 +++--- Handler/Tables.hs | 13 +++++++------ templates/result-table.hamlet | 2 +- templates/view-output.hamlet | 3 ++- templates/view-variant.hamlet | 8 +++++++- 9 files changed, 54 insertions(+), 22 deletions(-) diff --git a/Handler/Dashboard.hs b/Handler/Dashboard.hs index 36372e1..08aecdf 100644 --- a/Handler/Dashboard.hs +++ b/Handler/Dashboard.hs @@ -19,6 +19,8 @@ import Handler.Tables (timestampCell) import GEval.Core (isBetter) import GEval.EvaluationScheme +import Text.Blaze + import qualified Database.Esqueleto as E import Database.Esqueleto ((^.)) @@ -93,6 +95,7 @@ postEditIndicatorR indicatorId = do doEditIndicator mUser indicatorId formWidget formEnctype +doEditIndicator :: (Text.Blaze.ToMarkup a1, ToWidget App a2) => Maybe (Entity User) -> Key Indicator -> a2 -> a1 -> HandlerT App IO Html doEditIndicator mUser indicatorId formWidget formEnctype = do (addTargetformWidget, addTargetFormEnctype) <- generateFormPost addTargetForm @@ -128,6 +131,7 @@ getDeleteTargetR targetId = do doEditIndicator mUser (targetIndicator target) formWidget formEnctype +doDashboard :: (Text.Blaze.ToMarkup a1, ToWidget App a2) => Maybe (Entity User) -> a2 -> a1 -> HandlerFor App Html doDashboard mUser formWidget formEnctype = do indicators <- runDB $ selectList [] [Asc IndicatorId] @@ -247,7 +251,7 @@ getOngoingTargets challengeId = do return indicator indicatorEntries <- mapM indicatorToEntry indicators theNow <- liftIO $ getCurrentTime - (entries, _) <- runDB $ getChallengeSubmissionInfos (const True) challengeId + (entries, _) <- runDB $ getChallengeSubmissionInfos (const True) (const True) challengeId let indicatorEntries' = map (onlyWithOngoingTargets theNow entries) indicatorEntries return indicatorEntries' diff --git a/Handler/Graph.hs b/Handler/Graph.hs index 0771998..dce9d1a 100644 --- a/Handler/Graph.hs +++ b/Handler/Graph.hs @@ -33,7 +33,7 @@ getChallengeParamGraphDataR challengeName testId paramName = do test <- runDB $ get404 testId let testRef = getTestReference (Entity testId test) - (entries, _) <- runDB $ getChallengeSubmissionInfos (const True) challengeId + (entries, _) <- runDB $ getChallengeSubmissionInfos (const True) (const True) challengeId let values = map (findParamValue paramName) entries @@ -162,7 +162,7 @@ getIndicatorGraphDataR indicatorId = do test <- runDB $ get404 testId let mPrecision = testPrecision test - (entries, _) <- runDB $ getChallengeSubmissionInfos (const True) (testChallenge test) + (entries, _) <- runDB $ getChallengeSubmissionInfos (const True) (const True) (testChallenge test) theNow <- liftIO $ getCurrentTime -- needed to draw the "now" vertical line diff --git a/Handler/Presentation.hs b/Handler/Presentation.hs index 40dfc9c..266db68 100644 --- a/Handler/Presentation.hs +++ b/Handler/Presentation.hs @@ -36,7 +36,7 @@ getPresentation4RealR = do (Just (Entity sampleUserId _)) <- runDB $ getBy $ UniqueUser sampleUserIdent let condition = (\(Entity _ submission) -> (submissionSubmitter submission == sampleUserId)) - (evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos condition challengeId + (evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos condition (const True) challengeId let evaluationMaps = take 10 evaluationMaps' sampleLeaderboard <- getSampleLeaderboard sampleChallengeName @@ -57,7 +57,7 @@ getPresentationPSNC2019R = do (Just (Entity sampleUserId _)) <- runDB $ getBy $ UniqueUser sampleUserIdent let condition = (\(Entity _ submission) -> (submissionSubmitter submission == sampleUserId)) - (evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos condition challengeId + (evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos condition (const True) challengeId let evaluationMaps = take 10 evaluationMaps' sampleLeaderboard <- getSampleLeaderboard sampleChallengeName diff --git a/Handler/Query.hs b/Handler/Query.hs index 3dc9360..b8ab176 100644 --- a/Handler/Query.hs +++ b/Handler/Query.hs @@ -100,6 +100,10 @@ getViewVariantR variantId = do let theSubmissionId = variantSubmission variant theSubmission <- runDB $ get404 theSubmissionId + ([entry], tests) <- runDB $ getChallengeSubmissionInfos (\e -> entityKey e == theSubmissionId) + (\e -> entityKey e == variantId) + (submissionChallenge theSubmission) + if submissionIsPublic theSubmission || Just (submissionSubmitter theSubmission) == (entityKey <$> mauthId) then do @@ -112,7 +116,6 @@ getViewVariantR variantId = do E.orderBy [] return (out, test) - let outputs = sortBy (\a b -> ((snd b) `compare` (snd a))) $ nub @@ -124,15 +127,32 @@ getViewVariantR variantId = do else error "Cannot access this submission variant" -viewOutput :: (SHA1, Text) -> WidgetFor App () -viewOutput (outputHash, test) = do + +outputEvaluationsTable :: TableEntry -> Table.Table App (Entity Test) +outputEvaluationsTable tableEntry = mempty + ++ Table.text "Metric" (formatTestEvaluationScheme . entityVal) + ++ Table.text "Score" (\test -> (formatTruncatedScore (testPrecision $ entityVal test) + $ extractScore (getTestReference test) tableEntry)) + + +paramsTable :: Table.Table App Parameter +paramsTable = mempty + ++ Table.text "Parameter" parameterName + ++ Table.text "Value" parameterValue + +viewOutput :: TableEntry -> [Entity Test] -> (SHA1, Text) -> WidgetFor App () +viewOutput entry tests (outputHash, testSet) = do + let tests' = filter (\e -> (testName $ entityVal e) == testSet) tests let outputSha1AsText = fromSHA1ToText $ outputHash $(widgetFile "view-output") resultTable :: Entity Submission -> WidgetFor App () resultTable (Entity submissionId submission) = do - (tableEntries, tests) <- handlerToWidget $ runDB $ getChallengeSubmissionInfos (\s -> entityKey s == submissionId) - (submissionChallenge submission) + (tableEntries, tests) <- handlerToWidget + $ runDB + $ getChallengeSubmissionInfos (\s -> entityKey s == submissionId) + (const True) + (submissionChallenge submission) let paramNames = nub $ map (parameterName . entityVal) diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index 90029ee..a301da3 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -174,7 +174,7 @@ idToBeShown _ maybeUser = defaultRepo :: RepoScheme -> Text -> Challenge -> Repo -> Maybe (Entity User) -> Text defaultRepo SelfHosted repoHost challenge _ maybeUser = repoHost ++ (idToBeShown challenge maybeUser) ++ "/" ++ (challengeName challenge) -defaultRepo Branches repoHost _ repo _ = repoUrl repo +defaultRepo Branches _ _ repo _ = repoUrl repo defaultBranch :: IsString a => RepoScheme -> Maybe a defaultBranch SelfHosted = Just "master" @@ -430,7 +430,7 @@ checkIndicators user challengeId submissionId submissionLink relevantIndicators checkIndicator :: UTCTime -> User -> ChallengeId -> SubmissionId -> Text -> IndicatorEntry -> Channel -> Handler () checkIndicator theNow user challengeId submissionId submissionLink indicator chan = do - (entries, _) <- runDB $ getChallengeSubmissionInfos (\(Entity sid _) -> sid == submissionId) challengeId + (entries, _) <- runDB $ getChallengeSubmissionInfos (\(Entity sid _) -> sid == submissionId) (const True) challengeId mapM_ (\t -> checkTarget theNow user submissionLink entries indicator t chan) (indicatorEntryTargets indicator) checkTarget :: UTCTime -> User -> Text -> [TableEntry] -> IndicatorEntry -> Entity Target -> Channel -> Handler () @@ -655,7 +655,7 @@ getChallengeAllSubmissionsR name = getChallengeSubmissions (\_ -> True) name getChallengeSubmissions :: ((Entity Submission) -> Bool) -> Text -> Handler Html getChallengeSubmissions condition name = do Entity challengeId challenge <- runDB $ getBy404 $ UniqueName name - (evaluationMaps, tests') <- runDB $ getChallengeSubmissionInfos condition challengeId + (evaluationMaps, tests') <- runDB $ getChallengeSubmissionInfos condition (const True) challengeId let tests = sortBy testComparator tests' mauth <- maybeAuth let muserId = (\(Entity uid _) -> uid) <$> mauth diff --git a/Handler/Tables.hs b/Handler/Tables.hs index 9bb1337..1137ba6 100644 --- a/Handler/Tables.hs +++ b/Handler/Tables.hs @@ -77,8 +77,8 @@ submissionsTable mauthId challengeName repoScheme challengeRepo tests = mempty entityKey $ tableEntrySubmitter tableEntry, mauthId)) -paramTable :: [Text] -> [Entity Test] -> Table App TableEntry -paramTable paramNames tests = mempty +variantTable :: [Text] -> [Entity Test] -> Table App TableEntry +variantTable paramNames tests = mempty ++ Table.int "#" tableEntryRank ++ mconcat (map paramExtractor paramNames) ++ mconcat (map (\e@(Entity _ t) -> resultCell t (extractScore $ getTestReference e)) tests) @@ -203,7 +203,7 @@ getLeaderboardEntriesByCriterion :: (Ord a) => Key Challenge -> (TableEntry -> [a]) -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test])) getLeaderboardEntriesByCriterion challengeId condition selector = do - (evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos condition challengeId + (evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos condition (const True) challengeId let mainTests = getMainTests tests let mainTestEnt = getMainTest tests let mainTestRef = getTestReference mainTestEnt @@ -290,8 +290,8 @@ compareResult _ (Just _) Nothing = GT compareResult _ Nothing (Just _) = LT compareResult _ Nothing Nothing = EQ -getChallengeSubmissionInfos :: (MonadIO m, PersistQueryRead backend, BackendCompatible SqlBackend backend, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend) => (Entity Submission -> Bool) -> Key Challenge -> ReaderT backend m ([TableEntry], [Entity Test]) -getChallengeSubmissionInfos condition challengeId = do +getChallengeSubmissionInfos :: (MonadIO m, PersistQueryRead backend, BackendCompatible SqlBackend backend, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend) => (Entity Submission -> Bool) -> (Entity Variant -> Bool) -> Key Challenge -> ReaderT backend m ([TableEntry], [Entity Test]) +getChallengeSubmissionInfos condition variantCondition challengeId = do challenge <- get404 challengeId let commit = challengeVersion challenge @@ -317,7 +317,8 @@ getChallengeSubmissionInfos condition challengeId = do $ sortBy (\(s1, _) (s2, _) -> compareResult (entityVal mainTest) s2 s1) $ zip scores allSubmissionsVariants - evaluationMaps <- mapM getEvaluationMap allSubmissionsVariantsWithRanks + evaluationMaps' <- mapM getEvaluationMap allSubmissionsVariantsWithRanks + let evaluationMaps = filter (variantCondition . tableEntryVariant) evaluationMaps' return (evaluationMaps, tests) getScore :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryRead backend, PersistUniqueRead backend) => Key Test -> Key Variant -> ReaderT backend m (Maybe Double) diff --git a/templates/result-table.hamlet b/templates/result-table.hamlet index 3a7da1a..a015f4c 100644 --- a/templates/result-table.hamlet +++ b/templates/result-table.hamlet @@ -2,4 +2,4 @@ $if null tableEntries

No results available. The submission is probably broken. $else - ^{Table.buildBootstrap (paramTable paramNames tests) tableEntries} + ^{Table.buildBootstrap (variantTable paramNames tests) tableEntries} diff --git a/templates/view-output.hamlet b/templates/view-output.hamlet index f22b46f..85244ea 100644 --- a/templates/view-output.hamlet +++ b/templates/view-output.hamlet @@ -4,4 +4,5 @@

-
#{test} / #{outputSha1AsText} +
#{testSet} / #{outputSha1AsText} + ^{Table.buildBootstrap (outputEvaluationsTable entry) tests'} diff --git a/templates/view-variant.hamlet b/templates/view-variant.hamlet index d6fe0d5..323939b 100644 --- a/templates/view-variant.hamlet +++ b/templates/view-variant.hamlet @@ -4,5 +4,11 @@
^{submissionHeader fullSubmissionInfo} + + $case tableEntryParams entry + $of [] + $of _ + ^{Table.buildBootstrap paramsTable (map entityVal $ tableEntryParams entry)} + $forall output <- outputs - ^{viewOutput output} + ^{viewOutput entry tests output}