diff --git a/Handler/Dashboard.hs b/Handler/Dashboard.hs
index e26e86e..8845f08 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 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'
diff --git a/Handler/Graph.hs b/Handler/Graph.hs
index 921a236..7f01015 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 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
diff --git a/Handler/Presentation.hs b/Handler/Presentation.hs
index 1a68e6d..0d80f03 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 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
diff --git a/Handler/Query.hs b/Handler/Query.hs
index e017686..3c9ab77 100644
--- a/Handler/Query.hs
+++ b/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
diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs
index b7e34e0..9def0cf 100644
--- a/Handler/ShowChallenge.hs
+++ b/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
diff --git a/Handler/Tables.hs b/Handler/Tables.hs
index 874b56f..f07cbea 100644
--- a/Handler/Tables.hs
+++ b/Handler/Tables.hs
@@ -241,12 +241,13 @@ compareVersions (aM, aN, aP) (bM, bN, bP) = (aM `compare` bM)
<> (aP `compare` bP)
getLeaderboardEntriesByCriterion :: (Ord a) => Int
- -> Key Challenge
- -> ((Entity Submission) -> Bool)
- -> (TableEntry -> [a])
- -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
-getLeaderboardEntriesByCriterion maxPriority challengeId condition selector = do
- (evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos maxPriority condition (const True) challengeId
+ -> 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 preselector selector = do
+ (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])
-getChallengeSubmissionInfos maxMetricPriority condition variantCondition challengeId = do
+ -> ([(Int, (Entity Submission, Entity Variant))] -> [(Int, (Entity Submission, Entity Variant))])
+ -> 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
- 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 +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
-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}
diff --git a/app/upgrade-to-0-2.hs b/app/upgrade-to-0-2.hs
new file mode 100644
index 0000000..e025e51
--- /dev/null
+++ b/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
diff --git a/gonito.cabal b/gonito.cabal
index b3b506f..3848e54 100644
--- a/gonito.cabal
+++ b/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