filipg
/
gonito
1
0
Fork 1
Code Issues 1 Pull Requests Releases Wiki Activity

Ability to see analyses for other metrics

This commit is contained in:
Filip Gralinski 2020-08-14 08:47:37 +02:00
parent 55d06e3347
commit b8e7c2172b
6 changed files with 43 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Foundation.hs
View File

@ -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

49
Handler/Query.hs
View File

@ -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 <-

1
config/models
View File

@ -77,6 +77,7 @@ Test
precision Int Maybe
priority Int Maybe
UniqueChallengeNameMetricChecksum challenge name metric checksum
deriving Show
Submission
repo RepoId
commit SHA1

1
config/routes
View File

@ -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

2
templates/view-output.hamlet
View File

@ -6,7 +6,7 @@
<div class="media-heading">
<div .subm-commit>#{testSet} / #{outputSha1AsText}
$forall crossTable <- crossTables
^{Table.buildBootstrap (crossTableDefinition crossTable) (crossTableBody crossTable)}
^{Table.buildBootstrap (crossTableDefinition variantId crossTable) (crossTableBody crossTable)}
$maybe result <- mResult
<h4>worst items
^{Table.buildBootstrap (lineByLineTable mainTest theStamp) result}

2
templates/view-variant.hamlet
View File

@ -11,4 +11,4 @@
^{Table.buildBootstrap paramsTable (map entityVal $ tableEntryParams entry)}
$forall output <- outputs
^{viewOutput entry tests output}
^{viewOutputWithNonDefaultTestSelected entry tests testSelectedEnt output}