Handle metric priorities

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'
 

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
 

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

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 =

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

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

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