diff --git a/Handler/Tables.hs b/Handler/Tables.hs index 874b56f..72e01e1 100644 --- a/Handler/Tables.hs +++ b/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 - submission <- get404 $ variantSubmission variant - let version = submissionVersion submission - - evaluations <- E.select $ E.from $ \(out, evaluation) -> do + evaluations <- E.select $ E.from $ \(out, evaluation, variant, submission) -> 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 -getEvaluationMap (rank, (s@(Entity submissionId submission), v@(Entity variantId _))) = do - outs <- selectList [OutVariant ==. variantId] [] +data BasicSubmissionInfo = BasicSubmissionInfo { + basicSubmissionInfoUser :: User, + 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 - test <- get404 testId - let testRef = getTestReference (Entity testId test) - return (testRef, e)) pairs + let pairs' = map (\(testId, e) -> (testsMap Map.! testId, 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 diff --git a/Handler/TagUtils.hs b/Handler/TagUtils.hs index 951e2aa..80cddb2 100644 --- a/Handler/TagUtils.hs +++ b/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 \ #{tagName v} |] +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 #{t}