s464900/gonito
1
0
Fork 0
forked from filipg/gonito
Code Issues Pull Requests Projects 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

41
Handler/Query.hs
View File

@ -308,12 +308,17 @@ toQueryResultView :: FullSubmissionInfo -> Handler QueryResultView
toQueryResultView fsi = do
let submissionId = fsiSubmissionId fsi
let submission = fsiSubmission fsi
theVersion <- realSubmissionVersion $ Entity submissionId submission
(tableEntries, tests) <- runDB
$ getChallengeSubmissionInfos 2
$ getChallengeSubmissionInfosForVersion 2
(\s -> entityKey s == submissionId)
(const True)
id
(submissionChallenge submission)
theVersion
let (commonParams, strippedTableEntries) = extractCommonParams tableEntries
let evaluations = map (\entry ->
@ -386,17 +391,37 @@ data ViewVariantData = ViewVariantData {
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 = do
variant <- runDB $ get404 variantId
let theSubmissionId = variantSubmission variant
theSubmission <- runDB $ get404 theSubmissionId
([entry], tests') <- runDB $ getChallengeSubmissionInfos priorityLimitForViewVariant
theVersion <- realSubmissionVersion $ Entity theSubmissionId theSubmission
([entry], tests') <- runDB $ getChallengeSubmissionInfosForVersion priorityLimitForViewVariant
(\e -> entityKey e == theSubmissionId)
(\e -> entityKey e == variantId)
id
(submissionChallenge theSubmission)
theVersion
let tests = sortBy (flip testComparator) tests'
let isViewable = True
@ -483,11 +508,14 @@ getViewVariantR variantId = do
let theSubmissionId = variantSubmission variant
theSubmission <- runDB $ get404 theSubmissionId
(_, tests') <- runDB $ getChallengeSubmissionInfos priorityLimitForViewVariant
theVersion <- realSubmissionVersion $ Entity theSubmissionId theSubmission
(_, tests') <- runDB $ getChallengeSubmissionInfosForVersion priorityLimitForViewVariant
(\e -> entityKey e == theSubmissionId)
(\e -> entityKey e == variantId)
id
(submissionChallenge theSubmission)
theVersion
let (mainTest:_) = sortBy (flip testComparator) tests'
getViewVariantTestR variantId (entityKey mainTest)
@ -700,14 +728,17 @@ lineByLineTable (Entity testId test) theVersion theStamp = mempty
evaluationVersion = theVersion }
resultTable :: Entity Submission -> WidgetFor App ()
resultTable (Entity submissionId submission) = do
resultTable entSubmission@(Entity submissionId submission) = do
theVersion <- handlerToWidget $ realSubmissionVersion entSubmission
(tableEntries, tests') <- handlerToWidget
$ runDB
$ getChallengeSubmissionInfos 2
$ getChallengeSubmissionInfosForVersion 2
(\s -> entityKey s == submissionId)
(const True)
id
(submissionChallenge submission)
theVersion
let (commonParams', strippedTableEntries) = extractCommonParams tableEntries
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)
`thenCmp`
((variantName va) `compare` (variantName vb))))
getChallengeSubmissionInfos :: (MonadIO m,
PersistQueryRead backend,
BackendCompatible SqlBackend backend,
@ -486,9 +488,27 @@ getChallengeSubmissionInfos :: (MonadIO m,
-> Key Challenge
-> ReaderT backend m ([TableEntry], [Entity Test])
getChallengeSubmissionInfos maxMetricPriority condition variantCondition preselector challengeId = do
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] []
let tests = filter (\t -> (evaluationSchemePriority $ testMetric $ entityVal t) <= maxMetricPriority) tests'