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

Correctly show the results for older submissions

Browse Source
This commit is contained in:
Filip Gralinski 2021-10-29 17:45:55 +02:00
parent 1e56ee14c0
commit 5100518095
2 changed files with 74 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
Handler/Query.hs
View File

@ -308,12 +308,17 @@ toQueryResultView :: FullSubmissionInfo -> Handler QueryResultView
toQueryResultView fsi = do toQueryResultView fsi = do
let submissionId = fsiSubmissionId fsi let submissionId = fsiSubmissionId fsi
let submission = fsiSubmission fsi let submission = fsiSubmission fsi
theVersion <- realSubmissionVersion $ Entity submissionId submission
(tableEntries, tests) <- runDB (tableEntries, tests) <- runDB
$ getChallengeSubmissionInfos 2 $ getChallengeSubmissionInfosForVersion 2
(\s -> entityKey s == submissionId) (\s -> entityKey s == submissionId)
(const True) (const True)
id id
(submissionChallenge submission) (submissionChallenge submission)
theVersion
let (commonParams, strippedTableEntries) = extractCommonParams tableEntries let (commonParams, strippedTableEntries) = extractCommonParams tableEntries
let evaluations = map (\entry -> let evaluations = map (\entry ->
@ -386,17 +391,37 @@ data ViewVariantData = ViewVariantData {
viewVariantDataOuts :: [(SHA1, Text)] viewVariantDataOuts :: [(SHA1, Text)]
} }
-- Return the submission version for which the tests are available.
-- It should be simply submissionVersion but the problem is that
-- we change the update the change version when updating a challenge
-- (if the test did not change), and we are left sometimes with dangling
-- versions for which no tests are available.
realSubmissionVersion :: Entity Submission -> Handler SHA1
realSubmissionVersion (Entity submissionId _) = do
testOutputs <- runDB $ E.select
$ E.from $ \(variant, out, test) -> do
E.where_ (variant ^. VariantSubmission E.==. E.val submissionId
E.&&. out ^. OutVariant E.==. variant ^. VariantId
E.&&. out ^. OutTest E.==. test ^. TestId)
E.orderBy []
return test
let (t:_) = testOutputs
return $ testCommit $ entityVal t
fetchViewVariantData :: VariantId -> Handler ViewVariantData fetchViewVariantData :: VariantId -> Handler ViewVariantData
fetchViewVariantData variantId = do fetchViewVariantData variantId = do
variant <- runDB $ get404 variantId variant <- runDB $ get404 variantId
let theSubmissionId = variantSubmission variant let theSubmissionId = variantSubmission variant
theSubmission <- runDB $ get404 theSubmissionId theSubmission <- runDB $ get404 theSubmissionId
([entry], tests') <- runDB $ getChallengeSubmissionInfos priorityLimitForViewVariant theVersion <- realSubmissionVersion $ Entity theSubmissionId theSubmission
(\e -> entityKey e == theSubmissionId)
(\e -> entityKey e == variantId) ([entry], tests') <- runDB $ getChallengeSubmissionInfosForVersion priorityLimitForViewVariant
id (\e -> entityKey e == theSubmissionId)
(submissionChallenge theSubmission) (\e -> entityKey e == variantId)
id
(submissionChallenge theSubmission)
theVersion
let tests = sortBy (flip testComparator) tests' let tests = sortBy (flip testComparator) tests'
let isViewable = True let isViewable = True
@ -483,11 +508,14 @@ getViewVariantR variantId = do
let theSubmissionId = variantSubmission variant let theSubmissionId = variantSubmission variant
theSubmission <- runDB $ get404 theSubmissionId theSubmission <- runDB $ get404 theSubmissionId
(_, tests') <- runDB $ getChallengeSubmissionInfos priorityLimitForViewVariant theVersion <- realSubmissionVersion $ Entity theSubmissionId theSubmission
(\e -> entityKey e == theSubmissionId)
(\e -> entityKey e == variantId) (_, tests') <- runDB $ getChallengeSubmissionInfosForVersion priorityLimitForViewVariant
id (\e -> entityKey e == theSubmissionId)
(submissionChallenge theSubmission) (\e -> entityKey e == variantId)
id
(submissionChallenge theSubmission)
theVersion
let (mainTest:_) = sortBy (flip testComparator) tests' let (mainTest:_) = sortBy (flip testComparator) tests'
getViewVariantTestR variantId (entityKey mainTest) getViewVariantTestR variantId (entityKey mainTest)
@ -700,14 +728,17 @@ lineByLineTable (Entity testId test) theVersion theStamp = mempty
evaluationVersion = theVersion } evaluationVersion = theVersion }
resultTable :: Entity Submission -> WidgetFor App () resultTable :: Entity Submission -> WidgetFor App ()
resultTable (Entity submissionId submission) = do resultTable entSubmission@(Entity submissionId submission) = do
theVersion <- handlerToWidget $ realSubmissionVersion entSubmission
(tableEntries, tests') <- handlerToWidget (tableEntries, tests') <- handlerToWidget
$ runDB $ runDB
$ getChallengeSubmissionInfos 2 $ getChallengeSubmissionInfosForVersion 2
(\s -> entityKey s == submissionId) (\s -> entityKey s == submissionId)
(const True) (const True)
id id
(submissionChallenge submission) (submissionChallenge submission)
theVersion
let (commonParams', strippedTableEntries) = extractCommonParams tableEntries let (commonParams', strippedTableEntries) = extractCommonParams tableEntries
let commonParams = map (\(Entity _ p) -> (parameterName p, OneThing $ parameterValue p)) commonParams' let commonParams = map (\(Entity _ p) -> (parameterName p, OneThing $ parameterValue p)) commonParams'

24
Handler/Tables.hs
View File

@ -475,6 +475,8 @@ onlyTheBestVariant = DL.nubBy (\(_, (Entity aid _, _)) (_, (Entity bid _, _)) ->
. (sortBy (\(r1, (_, Entity _ va)) (r2, (_, Entity _ vb)) -> (r1 `compare` r2) . (sortBy (\(r1, (_, Entity _ va)) (r2, (_, Entity _ vb)) -> (r1 `compare` r2)
`thenCmp` `thenCmp`
((variantName va) `compare` (variantName vb)))) ((variantName va) `compare` (variantName vb))))
getChallengeSubmissionInfos :: (MonadIO m, getChallengeSubmissionInfos :: (MonadIO m,
PersistQueryRead backend, PersistQueryRead backend,
BackendCompatible SqlBackend backend, BackendCompatible SqlBackend backend,
@ -486,9 +488,27 @@ getChallengeSubmissionInfos :: (MonadIO m,
-> Key Challenge -> Key Challenge
-> ReaderT backend m ([TableEntry], [Entity Test]) -> ReaderT backend m ([TableEntry], [Entity Test])
getChallengeSubmissionInfos maxMetricPriority condition variantCondition preselector challengeId = do getChallengeSubmissionInfos maxMetricPriority condition variantCondition preselector challengeId = do
challenge <- get404 challengeId challenge <- get404 challengeId
let commit = challengeVersion challenge let versionCommit = challengeVersion challenge
getChallengeSubmissionInfosForVersion maxMetricPriority
condition
variantCondition
preselector
challengeId
versionCommit
getChallengeSubmissionInfosForVersion :: (MonadIO m,
PersistQueryRead backend,
BackendCompatible SqlBackend backend,
PersistUniqueRead backend, BaseBackend backend ~ SqlBackend)
=> Int
-> (Entity Submission -> Bool)
-> (Entity Variant -> Bool)
-> ([(Int, (Entity Submission, Entity Variant))] -> [(Int, (Entity Submission, Entity Variant))])
-> ChallengeId
-> SHA1
-> ReaderT backend m ([TableEntry], [Entity Test])
getChallengeSubmissionInfosForVersion maxMetricPriority condition variantCondition preselector challengeId commit = do
tests' <- selectList [TestChallenge ==. challengeId, TestActive ==. True, TestCommit ==. commit] [] tests' <- selectList [TestChallenge ==. challengeId, TestActive ==. True, TestCommit ==. commit] []
let tests = filter (\t -> (evaluationSchemePriority $ testMetric $ entityVal t) <= maxMetricPriority) tests' let tests = filter (\t -> (evaluationSchemePriority $ testMetric $ entityVal t) <= maxMetricPriority) tests'