From b2742f06e2f953286630aff09a28e75002c20445 Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Sat, 14 Dec 2019 22:24:22 +0100 Subject: [PATCH] Handle metric priorities --- Handler/Dashboard.hs | 2 +- Handler/Graph.hs | 4 ++-- Handler/Presentation.hs | 4 ++-- Handler/Query.hs | 6 ++++-- Handler/ShowChallenge.hs | 4 ++-- Handler/Tables.hs | 16 ++++++++++++---- gonito.cabal | 2 +- 7 files changed, 24 insertions(+), 14 deletions(-) diff --git a/Handler/Dashboard.hs b/Handler/Dashboard.hs index 08aecdf..e26e86e 100644 --- a/Handler/Dashboard.hs +++ b/Handler/Dashboard.hs @@ -251,7 +251,7 @@ getOngoingTargets challengeId = do return indicator indicatorEntries <- mapM indicatorToEntry indicators theNow <- liftIO $ getCurrentTime - (entries, _) <- runDB $ getChallengeSubmissionInfos (const True) (const True) challengeId + (entries, _) <- runDB $ getChallengeSubmissionInfos 1 (const True) (const True) challengeId let indicatorEntries' = map (onlyWithOngoingTargets theNow entries) indicatorEntries return indicatorEntries' diff --git a/Handler/Graph.hs b/Handler/Graph.hs index dce9d1a..ba1737c 100644 --- a/Handler/Graph.hs +++ b/Handler/Graph.hs @@ -33,7 +33,7 @@ getChallengeParamGraphDataR challengeName testId paramName = do test <- runDB $ get404 testId let testRef = getTestReference (Entity testId test) - (entries, _) <- runDB $ getChallengeSubmissionInfos (const True) (const True) challengeId + (entries, _) <- runDB $ getChallengeSubmissionInfos 1 (const True) (const True) challengeId let values = map (findParamValue paramName) entries @@ -162,7 +162,7 @@ getIndicatorGraphDataR indicatorId = do test <- runDB $ get404 testId let mPrecision = testPrecision test - (entries, _) <- runDB $ getChallengeSubmissionInfos (const True) (const True) (testChallenge test) + (entries, _) <- runDB $ getChallengeSubmissionInfos 1 (const True) (const True) (testChallenge test) theNow <- liftIO $ getCurrentTime -- needed to draw the "now" vertical line diff --git a/Handler/Presentation.hs b/Handler/Presentation.hs index 266db68..ea5580b 100644 --- a/Handler/Presentation.hs +++ b/Handler/Presentation.hs @@ -36,7 +36,7 @@ getPresentation4RealR = do (Just (Entity sampleUserId _)) <- runDB $ getBy $ UniqueUser sampleUserIdent let condition = (\(Entity _ submission) -> (submissionSubmitter submission == sampleUserId)) - (evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos condition (const True) challengeId + (evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos 1 condition (const True) challengeId let evaluationMaps = take 10 evaluationMaps' sampleLeaderboard <- getSampleLeaderboard sampleChallengeName @@ -57,7 +57,7 @@ getPresentationPSNC2019R = do (Just (Entity sampleUserId _)) <- runDB $ getBy $ UniqueUser sampleUserIdent let condition = (\(Entity _ submission) -> (submissionSubmitter submission == sampleUserId)) - (evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos condition (const True) challengeId + (evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos 1 condition (const True) challengeId let evaluationMaps = take 10 evaluationMaps' sampleLeaderboard <- getSampleLeaderboard sampleChallengeName diff --git a/Handler/Query.hs b/Handler/Query.hs index 4e0ca18..60f8267 100644 --- a/Handler/Query.hs +++ b/Handler/Query.hs @@ -186,7 +186,8 @@ getViewVariantR variantId = do let theSubmissionId = variantSubmission variant theSubmission <- runDB $ get404 theSubmissionId - ([entry], tests') <- runDB $ getChallengeSubmissionInfos (\e -> entityKey e == theSubmissionId) + ([entry], tests') <- runDB $ getChallengeSubmissionInfos 3 + (\e -> entityKey e == theSubmissionId) (\e -> entityKey e == variantId) (submissionChallenge theSubmission) let tests = sortBy (flip testComparator) tests' @@ -295,7 +296,8 @@ resultTable :: Entity Submission -> WidgetFor App () resultTable (Entity submissionId submission) = do (tableEntries, tests) <- handlerToWidget $ runDB - $ getChallengeSubmissionInfos (\s -> entityKey s == submissionId) + $ getChallengeSubmissionInfos 2 + (\s -> entityKey s == submissionId) (const True) (submissionChallenge submission) let paramNames = diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index e6f539d..697a91c 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -437,7 +437,7 @@ checkIndicators user challengeId submissionId submissionLink relevantIndicators checkIndicator :: UTCTime -> User -> ChallengeId -> SubmissionId -> Text -> IndicatorEntry -> Channel -> Handler () checkIndicator theNow user challengeId submissionId submissionLink indicator chan = do - (entries, _) <- runDB $ getChallengeSubmissionInfos (\(Entity sid _) -> sid == submissionId) (const True) challengeId + (entries, _) <- runDB $ getChallengeSubmissionInfos 1 (\(Entity sid _) -> sid == submissionId) (const True) challengeId mapM_ (\t -> checkTarget theNow user submissionLink entries indicator t chan) (indicatorEntryTargets indicator) checkTarget :: UTCTime -> User -> Text -> [TableEntry] -> IndicatorEntry -> Entity Target -> Channel -> Handler () @@ -535,7 +535,7 @@ getChallengeAllSubmissionsR name = getChallengeSubmissions (\_ -> True) name getChallengeSubmissions :: ((Entity Submission) -> Bool) -> Text -> Handler Html getChallengeSubmissions condition name = do Entity challengeId challenge <- runDB $ getBy404 $ UniqueName name - (evaluationMaps, tests') <- runDB $ getChallengeSubmissionInfos condition (const True) challengeId + (evaluationMaps, tests') <- runDB $ getChallengeSubmissionInfos 1 condition (const True) challengeId let tests = sortBy testComparator tests' mauth <- maybeAuth let muserId = (\(Entity uid _) -> uid) <$> mauth diff --git a/Handler/Tables.hs b/Handler/Tables.hs index 5ba3b39..42e87fc 100644 --- a/Handler/Tables.hs +++ b/Handler/Tables.hs @@ -224,7 +224,7 @@ getLeaderboardEntriesByCriterion :: (Ord a) => Key Challenge -> (TableEntry -> [a]) -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test])) getLeaderboardEntriesByCriterion challengeId condition selector = do - (evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos condition (const True) challengeId + (evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos 1 condition (const True) challengeId let mainTests = getMainTests tests let mainTestEnt = getMainTest tests let mainTestRef = getTestReference mainTestEnt @@ -311,13 +311,21 @@ compareResult _ (Just _) Nothing = GT compareResult _ Nothing (Just _) = LT compareResult _ Nothing Nothing = EQ -getChallengeSubmissionInfos :: (MonadIO m, PersistQueryRead backend, BackendCompatible SqlBackend backend, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend) => (Entity Submission -> Bool) -> (Entity Variant -> Bool) -> Key Challenge -> ReaderT backend m ([TableEntry], [Entity Test]) -getChallengeSubmissionInfos condition variantCondition challengeId = do +getChallengeSubmissionInfos :: (MonadIO m, + PersistQueryRead backend, + BackendCompatible SqlBackend backend, + PersistUniqueRead backend, BaseBackend backend ~ SqlBackend) + => Int + -> (Entity Submission -> Bool) + -> (Entity Variant -> Bool) + -> Key Challenge -> ReaderT backend m ([TableEntry], [Entity Test]) +getChallengeSubmissionInfos maxMetricPriority condition variantCondition challengeId = do challenge <- get404 challengeId let commit = challengeVersion challenge - 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 mainTest = getMainTest tests allSubmissionsVariants <- E.select $ E.from $ \(submission, variant) -> do diff --git a/gonito.cabal b/gonito.cabal index b011165..56c857a 100644 --- a/gonito.cabal +++ b/gonito.cabal @@ -128,7 +128,7 @@ library , filemanip , cryptohash , markdown - , geval >= 1.21.1.0 && < 1.25 + , geval >= 1.24 && < 1.25 , filepath , yesod-table , regex-tdfa