Merge branch 'speedup'

Handler/Dashboard.hs

@@ -251,7 +251,7 @@ getOngoingTargets challengeId = do
                         return indicator
   indicatorEntries <- mapM indicatorToEntry indicators
   theNow <- liftIO $ getCurrentTime
-  (entries, _) <- runDB $ getChallengeSubmissionInfos 1 (const True) (const True) challengeId
+  (entries, _) <- runDB $ getChallengeSubmissionInfos 1 (const True) (const True) id 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 1 (const True) (const True) challengeId
+  (entries, _) <- runDB $ getChallengeSubmissionInfos 1 (const True) (const True) id challengeId
 
   let values = map (findParamValue paramName) entries
 
@@ -85,6 +85,7 @@ submissionsToJSON condition challengeName = do
 
   (entries, _) <- getLeaderboardEntriesByCriterion 1 challengeId
                                                   condition
+                                                  onlyTheBestVariant
                                                   (\entry -> [entityKey $ tableEntrySubmission entry])
 
 
@@ -162,7 +163,7 @@ getIndicatorGraphDataR indicatorId = do
   test <- runDB $ get404 testId
   let mPrecision = testPrecision test
 
-  (entries, _) <- runDB $ getChallengeSubmissionInfos 1 (const True) (const True) (testChallenge test)
+  (entries, _) <- runDB $ getChallengeSubmissionInfos 1 (const True) (const True) id (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 1 condition (const True) challengeId
+  (evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos 1 condition (const True) onlyTheBestVariant 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 1 condition (const True) challengeId
+  (evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos 1 condition (const True) onlyTheBestVariant challengeId
   let evaluationMaps = take 10 evaluationMaps'
 
   sampleLeaderboard <- getSampleLeaderboard sampleChallengeName

Handler/Query.hs

@@ -192,6 +192,7 @@ getViewVariantR variantId = do
   ([entry], tests') <- runDB $ getChallengeSubmissionInfos 3
                                                           (\e -> entityKey e == theSubmissionId)
                                                           (\e -> entityKey e == variantId)
+                                                          id
                                                           (submissionChallenge theSubmission)
   let tests = sortBy (flip testComparator) tests'
 
@@ -311,6 +312,7 @@ resultTable (Entity submissionId submission) = do
                           $ getChallengeSubmissionInfos 2
                                                         (\s -> entityKey s == submissionId)
                                                         (const True)
+                                                        id
                                                         (submissionChallenge submission)
   let paramNames =
         nub

Handler/ShowChallenge.hs

@@ -461,7 +461,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 1 (\(Entity sid _) -> sid == submissionId) (const True) challengeId
+  (entries, _) <- runDB $ getChallengeSubmissionInfos 1 (\(Entity sid _) -> sid == submissionId) (const True) id challengeId
   mapM_ (\t -> checkTarget theNow user submissionLink entries indicator t chan) (indicatorEntryTargets indicator)
 
 checkTarget :: UTCTime -> User -> Text -> [TableEntry] -> IndicatorEntry -> Entity Target -> Channel -> Handler ()
@@ -559,7 +559,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 1 condition (const True) challengeId
+  (evaluationMaps, tests') <- runDB $ getChallengeSubmissionInfos 1 condition (const True) id challengeId
   let tests = sortBy testComparator tests'
   mauth <- maybeAuth
   let muserId = (\(Entity uid _) -> uid) <$> mauth

Handler/Tables.hs

@@ -243,10 +243,11 @@ compareVersions (aM, aN, aP) (bM, bN, bP) = (aM `compare` bM)
 getLeaderboardEntriesByCriterion :: (Ord a) => Int
                                  -> Key Challenge
                                  -> ((Entity Submission) -> Bool)
+                                 -> ([(Int, (Entity Submission, Entity Variant))] -> [(Int, (Entity Submission, Entity Variant))])
                                  -> (TableEntry -> [a])
                                  -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
-getLeaderboardEntriesByCriterion maxPriority challengeId condition selector = do
+getLeaderboardEntriesByCriterion maxPriority challengeId condition preselector selector = do
-  (evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos maxPriority condition (const True) challengeId
+  (evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos maxPriority condition (const True) preselector challengeId
   let mainTests = getMainTests tests
   let mainTestEnt = getMainTest tests
   let mainTestRef = getTestReference mainTestEnt
@@ -320,11 +321,13 @@ getLeaderboardEntries maxPriority BySubmitter challengeId =
   getLeaderboardEntriesByCriterion maxPriority
                                    challengeId
                                    (const True)
+                                   onlyTheBestVariant
                                    (\entry -> [entityKey $ tableEntrySubmitter entry])
 getLeaderboardEntries maxPriority ByTag challengeId =
   getLeaderboardEntriesByCriterion maxPriority
                                    challengeId
                                    (const True)
+                                   onlyTheBestVariant
                                    (noEmptyList . (map (entityKey . fst)) . tableEntryTagsInfo)
   where noEmptyList [] = [Nothing]
         noEmptyList l = map Just l
@@ -335,6 +338,11 @@ compareResult _ (Just _) Nothing = GT
 compareResult _ Nothing (Just _) = LT
 compareResult _ Nothing Nothing = EQ
 
+onlyTheBestVariant :: [(Int, (Entity Submission, Entity Variant))] -> [(Int, (Entity Submission, Entity Variant))]
+onlyTheBestVariant = DL.nubBy (\(_, (Entity aid _, _)) (_, (Entity bid _, _)) -> aid == 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,
@@ -342,8 +350,10 @@ getChallengeSubmissionInfos :: (MonadIO m,
                               => Int
                                 -> (Entity Submission -> Bool)
                                 -> (Entity Variant -> Bool)
-                                -> Key Challenge -> ReaderT backend m ([TableEntry], [Entity Test])
+                                -> ([(Int, (Entity Submission, Entity Variant))] -> [(Int, (Entity Submission, Entity Variant))])
-getChallengeSubmissionInfos maxMetricPriority condition variantCondition challengeId = do
+                                -> Key Challenge
+                                -> ReaderT backend m ([TableEntry], [Entity Test])
+getChallengeSubmissionInfos maxMetricPriority condition variantCondition preselector challengeId = do
 
   challenge <- get404 challengeId
   let commit = challengeVersion challenge
@@ -364,13 +374,22 @@ getChallengeSubmissionInfos maxMetricPriority condition variantCondition challen
         sortBy (\(r1, (s1, _)) (r2, (s2, _)) -> (submissionStamp (entityVal s2) `compare` submissionStamp (entityVal s1))
                                                                                `thenCmp`
                                                                             (r2 `compare` r1))
+        $ preselector
         $ filter (\(_, (s, _)) -> condition s)
         $ map (\(rank, (_, sv)) -> (rank, sv))
         $ zip [1..]
         $ 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 +397,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 +415,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>

app/upgrade-to-0-2.hs

@@ -0,0 +1,88 @@
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-}
+{-# LANGUAGE GADTs, FlexibleContexts #-}
+{-# LANGUAGE Arrows, NoMonomorphismRestriction #-}
+{-# LANGUAGE MultiParamTypeClasses, PartialTypeSignatures #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, EmptyDataDecls #-}
+
+import Prelude hiding (FilePath)
+
+import Control.Monad.Reader (ReaderT)
+import Database.Persist
+import Database.Persist.Postgresql
+import Control.Monad.Logger (runNoLoggingT)
+import Control.Monad.Trans.Resource (runResourceT)
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.UTF8 as BSU
+
+import qualified Database.Esqueleto      as E
+import           Database.Esqueleto      ((^.))
+
+import Model
+--share [mkPersist sqlSettings, mkMigrate "migrateAll"]
+--    $(persistFileWith lowerCaseSettings "config/models")
+
+dbSpecification dbName = BS.concat ["host=localhost dbname=", BSU.fromString dbName]
+
+dbConnection dbName = withPostgresqlConn (dbSpecification dbName)
+
+runOnDb :: String -> ReaderT SqlBackend _ a -> IO a
+runOnDb dbName = runNoLoggingT . runResourceT . (dbConnection dbName) . runSqlConn
+
+process :: String -> IO ()
+process dbName = do
+  Prelude.putStrLn "Getting all variants…"
+  variants <- runOnDb dbName
+             $ E.select $ E.from $ \(challenge, submission, variant, test, out) -> do
+                          E.where_ (submission ^. SubmissionChallenge E.==. challenge ^. ChallengeId
+                                    E.&&. variant ^. VariantSubmission E.==. submission ^. SubmissionId
+                                    E.&&. test ^. TestChallenge E.==. challenge ^. ChallengeId
+                                    E.&&. out ^. OutTest E.==. test ^. TestId
+                                    E.&&. out ^. OutVariant E.==. variant ^. VariantId)
+                          return (variant, submission, out, test)
+
+  Prelude.putStrLn "Adding evaluations…"
+  _ <- mapM (processVariant dbName) variants
+
+  putStrLn "DELETING"
+  runOnDb dbName $ deleteWhere [EvaluationVersion ==. Nothing]
+
+  return ()
+
+processVariant :: String -> (Entity Variant, Entity Submission, Entity Out, Entity Test) -> IO ()
+processVariant dbName (variant, Entity _ submission, Entity _ out, Entity testId _) = do
+  Prelude.putStrLn (show $ entityKey variant)
+
+  evaluations <- runOnDb dbName
+                $ E.select $ E.from $ \evaluation -> do
+                             E.where_ (E.val (outChecksum out) 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.just (E.val (submissionVersion submission))
+                                              E.||. E.isNothing (evaluation ^. EvaluationVersion))
+                                       E.&&. evaluation ^. EvaluationTest E.==. E.val testId)
+                             E.orderBy [E.asc (E.isNothing (evaluation ^. EvaluationVersion))]
+                             return evaluation
+
+  case evaluations of
+    (Entity _ e:_) -> do
+      case evaluationVersion e of
+        Just _ -> putStrLn "OK found!"
+        Nothing -> do
+          putStrLn "NONE FOUND INSERTING"
+          _ <- runOnDb dbName $ insert $ Evaluation testId
+                                                   (outChecksum out)
+                                                   (evaluationScore e)
+                                                   (evaluationErrorMessage e)
+                                                   (evaluationStamp e)
+                                                   (Just $ submissionVersion submission)
+          return ()
+    [] -> do
+      putStrLn "MISSING EVALUATION"
+
+  return ()
+
+main :: IO ()
+main = do
+  let dbName = "gonito"
+  process dbName

gonito.cabal

@@ -170,6 +170,26 @@ executable         gonito-bin
 
     ghc-options:       -threaded -O2 -rtsopts -with-rtsopts=-N
 
+executable         upgrade-to-0-2
+    if flag(library-only)
+        Buildable: False
+
+    main-is:           upgrade-to-0-2.hs
+    hs-source-dirs:    app
+    build-depends:     base
+                       , gonito
+                       , esqueleto
+                       , text
+                       , monad-logger
+                       , persistent
+                       , persistent-postgresql
+                       , resourcet
+                       , bytestring
+                       , persistent-template
+                       , mtl
+                       , utf8-string
+
+    ghc-options:       -threaded -O2 -rtsopts -with-rtsopts=-N
 
 test-suite test
     type:              exitcode-stdio-1.0