Optimizing DB querying when a leaderboard is created

Handler/Tables.hs

@@ -370,7 +370,15 @@ getChallengeSubmissionInfos maxMetricPriority condition variantCondition challen
         $ sortBy (\(s1, _) (s2, _) -> compareResult (entityVal mainTest) s2 s1)
         $ zip scores allSubmissionsVariants
 
-  evaluationMaps' <- mapM getEvaluationMap allSubmissionsVariantsWithRanks
+  allTests <- selectList [] [Asc TestName]
+  let testsMap = Map.fromList $ map (\(ent@(Entity testId _)) -> (testId, getTestReference ent)) allTests
+
+  let allSubmissions = DL.nubBy (\(Entity a _) (Entity b _) -> a == b) $ map (\(_, (s, _)) -> s) allSubmissionsVariantsWithRanks
+  subs <- mapM getBasicSubmissionInfo allSubmissions
+  let submissionMap = Map.fromList subs
+  -- testsMap and submissionMap are created to speed up getEvaluationMap
+
+  evaluationMaps' <- mapM (getEvaluationMap testsMap submissionMap) allSubmissionsVariantsWithRanks
   let evaluationMaps = filter (variantCondition . tableEntryVariant) evaluationMaps'
   return (evaluationMaps, tests)
 
@@ -378,17 +386,15 @@ getScore :: (MonadIO m, BackendCompatible SqlBackend backend,
             PersistQueryRead backend, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend)
            => Key Test -> Key Variant -> ReaderT backend m (Maybe Double)
 getScore testId variantId = do
-  variant <- get404 variantId
+  evaluations <- E.select $ E.from $ \(out, evaluation, variant, submission) -> do
-  submission <- get404 $ variantSubmission variant
-  let version = submissionVersion submission
-
-  evaluations <- E.select $ E.from $ \(out, evaluation) -> do
                   E.where_ (out ^. OutVariant E.==. E.val variantId
+                            E.&&. variant ^. VariantId E.==. E.val variantId
+                            E.&&. submission ^. SubmissionId E.==. variant ^. VariantSubmission
                             E.&&. out ^. OutTest E.==. E.val testId
                             E.&&. out ^. OutChecksum E.==. evaluation ^. EvaluationChecksum
                             -- all this complication here and with orderBy due
                             -- to the legacy issue with evaluation version sometimes missing
-                            E.&&. (evaluation ^. EvaluationVersion E.==. E.val (Just version)
+                            E.&&. (evaluation ^. EvaluationVersion E.==. E.just (submission ^. SubmissionVersion)
                                    E.||. E.isNothing (evaluation ^. EvaluationVersion))
                             E.&&. evaluation ^. EvaluationTest E.==. E.val testId)
                   E.orderBy [E.desc (E.isNothing (evaluation ^. EvaluationVersion))]
@@ -398,24 +404,45 @@ getScore testId variantId = do
              [] -> Nothing
 
 
-getEvaluationMap :: (MonadIO m, PersistQueryRead backend, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend) => (Int, (Entity Submission, Entity Variant)) -> ReaderT backend m TableEntry
+data BasicSubmissionInfo = BasicSubmissionInfo {
-getEvaluationMap (rank, (s@(Entity submissionId submission), v@(Entity variantId _))) = do
+  basicSubmissionInfoUser :: User,
-  outs <- selectList [OutVariant ==. variantId] []
+  basicSubmissionInfoTagEnts :: [(Entity Tag, Entity SubmissionTag)],
+  basicSubmissionInfoVersion :: Version }
+
+getBasicSubmissionInfo :: (MonadIO m, PersistQueryRead backend,
+                          PersistUniqueRead backend,
+                          BaseBackend backend ~ SqlBackend)
+                         => Entity Submission -> ReaderT backend m (SubmissionId, BasicSubmissionInfo)
+getBasicSubmissionInfo (Entity submissionId submission) = do
   user <- get404 $ submissionSubmitter submission
+  tagEnts <- getTags submissionId
+  let versionHash = submissionVersion submission
+  (Entity _ version) <- getBy404 $ UniqueVersionByCommit versionHash
+  return $ (submissionId, BasicSubmissionInfo {
+               basicSubmissionInfoUser = user,
+               basicSubmissionInfoTagEnts = tagEnts,
+               basicSubmissionInfoVersion = version })
+
+getEvaluationMap :: (MonadIO m, PersistQueryRead backend, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend)
+                   => Map.Map TestId TestReference
+                     -> Map.Map SubmissionId BasicSubmissionInfo
+                     -> (Int, (Entity Submission, Entity Variant)) -> ReaderT backend m TableEntry
+getEvaluationMap testsMap submissionsMap (rank, (s@(Entity submissionId submission), v@(Entity variantId _))) = do
+  let submissionInfo = submissionsMap Map.! submissionId
+  let user = basicSubmissionInfoUser submissionInfo
+  let tagEnts = basicSubmissionInfoTagEnts submissionInfo
+  let version = basicSubmissionInfoVersion submissionInfo
+
+  outs <- selectList [OutVariant ==. variantId] []
   let versionHash = submissionVersion submission
   maybeEvaluations <- mapM (\(Entity _ o) -> fetchTheEvaluation o versionHash) outs
   let evaluations = catMaybes maybeEvaluations
   let pairs = map (\(Entity _ e) -> (evaluationTest e, e)) evaluations
-  pairs' <- mapM (\(testId, e) -> do
+  let pairs' = map (\(testId, e) -> (testsMap Map.! testId, e)) pairs
-                                 test <- get404 testId
-                                 let testRef = getTestReference (Entity testId test)
-                                 return (testRef, e)) pairs
   let m = Map.fromList pairs'
-  tagEnts <- getTags submissionId
 
   parameters <- selectList [ParameterVariant ==. variantId] [Asc ParameterName]
 
-  (Entity _ version) <- getBy404 $ UniqueVersionByCommit versionHash
   let major = versionMajor version
   let minor = versionMinor version
   let patch = versionPatch version

Handler/TagUtils.hs

@@ -3,9 +3,9 @@ module Handler.TagUtils where
 import Import
 import Yesod.Form.Bootstrap3 (bfs)
 
-import qualified Data.Set as S
+import Text.Blaze (ToMarkup)
 
-import Gonito.ExtractMetadata (parseTags)
+import qualified Data.Set as S
 
 getAvailableTagsAsJSON :: (BaseBackend backend ~ SqlBackend, MonadIO m, PersistQueryRead backend) => ReaderT backend m Value
 getAvailableTagsAsJSON = do
@@ -31,6 +31,7 @@ tagsAsTextToTagIds tags = do
   mTs <- mapM (\t -> getBy $ UniqueTagName t) newTags
   return $ Import.map entityKey $ Import.catMaybes mTs
 
+fragmentWithTags :: (Text.Blaze.ToMarkup a, Foldable t) => a -> t (Entity Tag) -> WidgetFor site ()
 fragmentWithTags t tagEnts = [whamlet|
 #{t}
 
@@ -38,6 +39,7 @@ $forall (Entity _ v) <- tagEnts
   \ <span class="label label-primary">#{tagName v}</span>
 |]
 
+fragmentWithSubmissionTags :: (Text.Blaze.ToMarkup a, Foldable t) => a -> Maybe (Route site) -> t (Entity Tag, Entity SubmissionTag) -> WidgetFor site ()
 fragmentWithSubmissionTags t mLink tagEnts = [whamlet|
 $maybe link <- mLink
   <a href="@{link}">#{t}</a>