s464900/gonito
1
0
Fork 0
forked from filipg/gonito
Code Issues Pull Requests Projects Releases Wiki Activity

Merge branch 'speedup'

Browse Source
This commit is contained in:
Filip Gralinski 2020-01-04 22:34:34 +01:00
commit 763de554e5
9 changed files with 184 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Handler/Dashboard.hs
View File

@ -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'

5
Handler/Graph.hs
View File

@ -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

4
Handler/Presentation.hs
View File

@ -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

2
Handler/Query.hs
View File

@ -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

4
Handler/ShowChallenge.hs
View File

@ -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

78
Handler/Tables.hs
View File

@ -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
(evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos maxPriority condition (const True) challengeId
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

6
Handler/TagUtils.hs
View File

@ -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>

88
app/upgrade-to-0-2.hs Normal file
View File

@ -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

20
gonito.cabal
View File

@ -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