From b8e7c2172bdd81005adc6d75b4f5c587f6758fce Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Fri, 14 Aug 2020 08:47:37 +0200 Subject: [PATCH] Ability to see analyses for other metrics --- Foundation.hs | 3 ++- Handler/Query.hs | 49 ++++++++++++++++++++++++++--------- config/models | 1 + config/routes | 1 + templates/view-output.hamlet | 2 +- templates/view-variant.hamlet | 2 +- 6 files changed, 43 insertions(+), 15 deletions(-) diff --git a/Foundation.hs b/Foundation.hs index 55825bc..cbf9136 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -152,7 +152,8 @@ instance Yesod App where isAuthorized QueryFormR _ = regularAuthorization isAuthorized (QueryResultsR _) _ = regularAuthorization isAuthorized ListChallengesR _ = regularAuthorization - isAuthorized (ViewVariantR _) _ = regularAuthorization + isAuthorized (ViewVariantR _ ) _ = regularAuthorization + isAuthorized (ViewVariantTestR _ _) _ = regularAuthorization isAuthorized TagsR _ = regularAuthorization isAuthorized AchievementsR _ = regularAuthorization diff --git a/Handler/Query.hs b/Handler/Query.hs index 0dd6ad1..37b459b 100644 --- a/Handler/Query.hs +++ b/Handler/Query.hs @@ -181,14 +181,16 @@ processQuery query = do setTitle "query results" $(widgetFile "query-results") - -getViewVariantR :: VariantId -> Handler Html -getViewVariantR variantId = do +getViewVariantTestR :: VariantId -> TestId -> Handler Html +getViewVariantTestR variantId testId = do mauthId <- maybeAuth variant <- runDB $ get404 variantId let theSubmissionId = variantSubmission variant theSubmission <- runDB $ get404 theSubmissionId + testSelected <- runDB $ get404 testId + let testSelectedEnt = Entity testId testSelected + ([entry], tests') <- runDB $ getChallengeSubmissionInfos 3 (\e -> entityKey e == theSubmissionId) (\e -> entityKey e == variantId) @@ -222,13 +224,28 @@ getViewVariantR variantId = do error "Cannot access this submission variant" -crossTableDefinition :: TableWithValues Text -> Table.Table App (Text, [Text]) -crossTableDefinition (TableWithValues (headerH : headerR) _) = mempty - ++ Table.text headerH fst - ++ mconcat (map (\(ix, h) -> Table.text h ((!! ix) . snd)) $ zip [0..] headerR) -crossTableDefinition _ = error $ "cross-tab of an unexpected size" +getViewVariantR :: VariantId -> Handler Html +getViewVariantR variantId = do + variant <- runDB $ get404 variantId + let theSubmissionId = variantSubmission variant + theSubmission <- runDB $ get404 theSubmissionId -crossTableBody :: TableWithValues Text -> [(Text, [Text])] + (_, tests') <- runDB $ getChallengeSubmissionInfos 3 + (\e -> entityKey e == theSubmissionId) + (\e -> entityKey e == variantId) + id + (submissionChallenge theSubmission) + let (mainTest:_) = sortBy (flip testComparator) tests' + getViewVariantTestR variantId (entityKey mainTest) + + +crossTableDefinition :: VariantId -> TableWithValues (Entity Test, Text) -> Table.Table App (Text, [(Entity Test, Text)]) +crossTableDefinition variantId (TableWithValues (headerH : headerR) _) = mempty + ++ Table.text headerH fst + ++ mconcat (map (\(ix, h) -> Table.linked h (snd . (!! ix) . snd) ((\(e, _) -> ViewVariantTestR variantId (entityKey e)) . (!! ix) . snd)) $ zip [0..] headerR) +crossTableDefinition _ _ = error $ "cross-tab of an unexpected size" + +crossTableBody :: TableWithValues (Entity Test, Text) -> [(Text, [(Entity Test, Text)])] crossTableBody (TableWithValues _ rows) = rows paramsTable :: Table.Table App Parameter @@ -238,12 +255,19 @@ paramsTable = mempty viewOutput :: TableEntry -> [Entity Test] -> (SHA1, Text) -> WidgetFor App () viewOutput entry tests (outputHash, testSet) = do + let (mainTest:_) = filter (\e -> (testName $ entityVal e) == testSet) tests + viewOutputWithNonDefaultTestSelected entry tests mainTest (outputHash, testSet) + +viewOutputWithNonDefaultTestSelected :: TableEntry -> [Entity Test] -> Entity Test -> (SHA1, Text) -> WidgetFor App () +viewOutputWithNonDefaultTestSelected entry tests mainTest (outputHash, testSet) = do + let tests' = filter (\e -> (testName $ entityVal e) == testSet) tests + mauthId <- maybeAuthId - let tests'@(mainTest:_) = filter (\e -> (testName $ entityVal e) == testSet) tests let outputSha1AsText = fromSHA1ToText $ outputHash let variant = variantName $ entityVal $ tableEntryVariant entry + let variantId = entityKey $ tableEntryVariant entry let theStamp = submissionStamp $ entityVal $ tableEntrySubmission entry isViewable <- handlerToWidget $ runDB $ checkWhetherVisible (entityVal $ tableEntrySubmission entry) mauthId @@ -256,8 +280,9 @@ viewOutput entry tests (outputHash, testSet) = do let testLabels = map (formatTestEvaluationScheme . entityVal) tests' let mapping = LM.fromList $ map (\test -> (formatTestEvaluationScheme $ entityVal test, - (formatTruncatedScore (testPrecision $ entityVal test) - $ extractScore (getTestReference test) entry))) tests' + (test, + (formatTruncatedScore (testPrecision $ entityVal test) + $ extractScore (getTestReference test) entry)))) tests' let crossTables = splitIntoTablesWithValues "Metric" "Score" mapping testLabels mResult <- diff --git a/config/models b/config/models index 80d7841..f531806 100644 --- a/config/models +++ b/config/models @@ -77,6 +77,7 @@ Test precision Int Maybe priority Int Maybe UniqueChallengeNameMetricChecksum challenge name metric checksum + deriving Show Submission repo RepoId commit SHA1 diff --git a/config/routes b/config/routes index 3516862..79c4377 100644 --- a/config/routes +++ b/config/routes @@ -41,6 +41,7 @@ /q/#Text QueryResultsR GET /view-variant/#VariantId ViewVariantR GET +/view-variant-test/#VariantId/#TestId ViewVariantTestR GET /api/txt/score/#Text ApiTxtScoreR GET diff --git a/templates/view-output.hamlet b/templates/view-output.hamlet index 4777c71..b9873da 100644 --- a/templates/view-output.hamlet +++ b/templates/view-output.hamlet @@ -6,7 +6,7 @@
#{testSet} / #{outputSha1AsText} $forall crossTable <- crossTables - ^{Table.buildBootstrap (crossTableDefinition crossTable) (crossTableBody crossTable)} + ^{Table.buildBootstrap (crossTableDefinition variantId crossTable) (crossTableBody crossTable)} $maybe result <- mResult

worst items ^{Table.buildBootstrap (lineByLineTable mainTest theStamp) result} diff --git a/templates/view-variant.hamlet b/templates/view-variant.hamlet index 3e5ea2d..e7d7b15 100644 --- a/templates/view-variant.hamlet +++ b/templates/view-variant.hamlet @@ -11,4 +11,4 @@ ^{Table.buildBootstrap paramsTable (map entityVal $ tableEntryParams entry)} $forall output <- outputs - ^{viewOutput entry tests output} + ^{viewOutputWithNonDefaultTestSelected entry tests testSelectedEnt output}