s464900
/
gonito
forked from filipg/gonito
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Shared params returned by the JSON end-point as well

This commit is contained in:
Filip Gralinski 2021-07-26 07:53:15 +02:00
parent 132b0f7ad9
commit 6dbe483333
1 changed files with 27 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
Handler/Query.hs
View File

@ -107,24 +107,28 @@ instance ToSchema VariantView where
data QueryResultView = QueryResultView { data QueryResultView = QueryResultView {
queryResultViewSubmissionInfo :: FullSubmissionInfo, queryResultViewSubmissionInfo :: FullSubmissionInfo,
queryResultViewVariants :: [VariantView] queryResultViewVariants :: [VariantView],
queryResultSharedParams :: [Parameter]
} }
instance ToJSON QueryResultView where instance ToJSON QueryResultView where
toJSON entry = object toJSON entry = object
[ "submissionInfo" .= queryResultViewSubmissionInfo entry, [ "submissionInfo" .= queryResultViewSubmissionInfo entry,
"variants" .= queryResultViewVariants entry "variants" .= queryResultViewVariants entry,
"sharedParams" .= queryResultSharedParams entry
] ]
instance ToSchema QueryResultView where instance ToSchema QueryResultView where
declareNamedSchema _ = do declareNamedSchema _ = do
submissionInfoSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy FullSubmissionInfo) submissionInfoSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy FullSubmissionInfo)
variantViewsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [VariantView])
return $ NamedSchema (Just "QueryResult") $ mempty return $ NamedSchema (Just "QueryResult") $ mempty
& type_ .~ SwaggerObject & type_ .~ SwaggerObject
& properties .~ & properties .~
fromList [ ("submissionInfo", submissionInfoSchema), fromList [ ("submissionInfo", submissionInfoSchema),
("variants", variantViewsSchema) ("variants", Inline $ toSchema (DPR.Proxy :: DPR.Proxy [VariantView])
& description .~ Just "A list of outputs (variants) associated with the given submission, usually one, but could be more"),
("sharedParams", Inline $ toSchema (DPR.Proxy :: DPR.Proxy [Parameter])
& description .~ Just "Parameters shared by all variants; if there is only one variant, all parameters will be given here")
] ]
& required .~ [ "submissionInfo", "variants" ] & required .~ [ "submissionInfo", "variants" ]
@ -167,10 +171,10 @@ fetchSubmissionByOut (Entity _ out) = do
getApiTxtScoreR :: Text -> Handler Text getApiTxtScoreR :: Text -> Handler Text
getApiTxtScoreR query = getApiTxtScoreR query =
if T.null post if T.null postT
then getApiTxtScore Nothing pre then getApiTxtScore Nothing preT
else getApiTxtScore (Just $ T.tail post) pre else getApiTxtScore (Just $ T.tail postT) preT
where (pre, post) = T.breakOn "-" query where (preT, postT) = T.breakOn "-" query
getApiTxtScore :: Maybe Text -> Text -> Handler Text getApiTxtScore :: Maybe Text -> Text -> Handler Text
getApiTxtScore mMetricName sha1Prefix = do getApiTxtScore mMetricName sha1Prefix = do
@ -223,18 +227,18 @@ doGetScoreForOut mMetricName submission sha1code = do
let submissionId = entityKey submission let submissionId = entityKey submission
evals <- runDB $ E.select evals <- runDB $ E.select
$ E.from $ \(out, evaluation, variant, test, version) -> do $ E.from $ \(out, evaluation, variant, test, theVersion) -> do
E.where_ (variant ^. VariantSubmission E.==. E.val submissionId E.where_ (variant ^. VariantSubmission E.==. E.val submissionId
E.&&. out ^. OutVariant E.==. variant ^. VariantId E.&&. out ^. OutVariant E.==. variant ^. VariantId
E.&&. out ^. OutTest E.==. test ^. TestId E.&&. out ^. OutTest E.==. test ^. TestId
E.&&. evaluation ^. EvaluationTest E.==. test ^. TestId E.&&. evaluation ^. EvaluationTest E.==. test ^. TestId
E.&&. out ^. OutChecksum E.==. evaluation ^. EvaluationChecksum E.&&. out ^. OutChecksum E.==. evaluation ^. EvaluationChecksum
E.&&. out ^. OutChecksum E.==. E.val sha1code E.&&. out ^. OutChecksum E.==. E.val sha1code
E.&&. (evaluation ^. EvaluationVersion E.==. version ^. VersionCommit)) E.&&. (evaluation ^. EvaluationVersion E.==. theVersion ^. VersionCommit))
E.orderBy [E.asc (test ^. TestPriority), E.orderBy [E.asc (test ^. TestPriority),
E.desc (version ^. VersionMajor), E.desc (theVersion ^. VersionMajor),
E.desc (version ^. VersionMinor), E.desc (theVersion ^. VersionMinor),
E.desc (version ^. VersionPatch)] E.desc (theVersion ^. VersionPatch)]
return (evaluation, test) return (evaluation, test)
let evalSelected = case evals of let evalSelected = case evals of
@ -288,7 +292,7 @@ toQueryResultView fsi = do
(const True) (const True)
id id
(submissionChallenge submission) (submissionChallenge submission)
let (commonParams, strippedTableEntries) = extractCommonParams tableEntries
let evaluations = map (\entry -> let evaluations = map (\entry ->
VariantView { VariantView {
@ -298,11 +302,12 @@ toQueryResultView fsi = do
variantViewEvaluations = catMaybes $ Import.map (convertEvaluationToView $ tableEntryMapping entry) tests, variantViewEvaluations = catMaybes $ Import.map (convertEvaluationToView $ tableEntryMapping entry) tests,
variantViewParams = Import.map entityVal $ tableEntryParams entry variantViewParams = Import.map entityVal $ tableEntryParams entry
}) tableEntries }) strippedTableEntries
return $ QueryResultView { return $ QueryResultView {
queryResultViewSubmissionInfo = fsi, queryResultViewSubmissionInfo = fsi,
queryResultViewVariants = evaluations } queryResultViewVariants = evaluations,
queryResultSharedParams = map entityVal commonParams }
getQueryJsonR :: Text -> Handler Value getQueryJsonR :: Text -> Handler Value
getQueryJsonR query = do getQueryJsonR query = do
@ -443,11 +448,11 @@ doViewVariantTestR variantId testId = do
$(widgetFile "view-variant") $(widgetFile "view-variant")
mergeEntryParams :: Diff [Parameter] -> [(Text, Diff Text)] mergeEntryParams :: Diff [Parameter] -> [(Text, Diff Text)]
mergeEntryParams (OneThing u) = map (\(Parameter _ name val) -> (name, OneThing val)) u mergeEntryParams (OneThing u) = map (\(Parameter _ pname pval) -> (pname, OneThing pval)) u
mergeEntryParams (TwoThings old new) = LM.toList $ diff ("", ()) oldMap newMap mergeEntryParams (TwoThings old new) = LM.toList $ diff ("", ()) oldMap newMap
where oldMap = mapify old where oldMap = mapify old
newMap = mapify new newMap = mapify new
mapify l = LM.fromList $ map (\(Parameter _ name val) -> (name, val)) l mapify l = LM.fromList $ map (\(Parameter _ pname pval) -> (pname, pval)) l
getViewVariantR :: VariantId -> Handler Html getViewVariantR :: VariantId -> Handler Html
getViewVariantR variantId = do getViewVariantR variantId = do
@ -476,10 +481,10 @@ getVariantTestLink (TwoThings old new) testId = ViewVariantDiffR old new testId
crossTableDefinition :: Diff VariantId -> TableWithValues (Entity Test, Diff Text) -> Table.Table App (Text, [(Entity Test, Diff Text)]) crossTableDefinition :: Diff VariantId -> TableWithValues (Entity Test, Diff Text) -> Table.Table App (Text, [(Entity Test, Diff Text)])
crossTableDefinition variantId (TableWithValues (headerH : headerR) _) = mempty crossTableDefinition variantId (TableWithValues (headerH : headerR) _) = mempty
++ Table.text headerH fst ++ Table.text headerH fst
++ mconcat (map (\(ix, h) -> linkedWithAnchor h ++ mconcat (map (\(i, h) -> linkedWithAnchor h
(snd . (!! ix) . snd) (snd . (!! i) . snd)
((\(e, _) -> getVariantTestLink variantId (entityKey e)) . (!! ix) . snd) ((\(e, _) -> getVariantTestLink variantId (entityKey e)) . (!! i) . snd)
(("worst-items-" <>) . testName . entityVal . fst . (!! ix) . snd)) (("worst-items-" <>) . testName . entityVal . fst . (!! i) . snd))
$ zip [0..] headerR) $ zip [0..] headerR)
crossTableDefinition _ _ = error $ "cross-tab of an unexpected size" crossTableDefinition _ _ = error $ "cross-tab of an unexpected size"