Merge branch 'speedup'

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

View File

@ -251,7 +251,7 @@ getOngoingTargets challengeId = do
return indicator return indicator
indicatorEntries <- mapM indicatorToEntry indicators indicatorEntries <- mapM indicatorToEntry indicators
theNow <- liftIO $ getCurrentTime 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 let indicatorEntries' = map (onlyWithOngoingTargets theNow entries) indicatorEntries
return indicatorEntries' return indicatorEntries'

View File

@ -33,7 +33,7 @@ getChallengeParamGraphDataR challengeName testId paramName = do
test <- runDB $ get404 testId test <- runDB $ get404 testId
let testRef = getTestReference (Entity testId test) 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 let values = map (findParamValue paramName) entries
@ -85,6 +85,7 @@ submissionsToJSON condition challengeName = do
(entries, _) <- getLeaderboardEntriesByCriterion 1 challengeId (entries, _) <- getLeaderboardEntriesByCriterion 1 challengeId
condition condition
onlyTheBestVariant
(\entry -> [entityKey $ tableEntrySubmission entry]) (\entry -> [entityKey $ tableEntrySubmission entry])
@ -162,7 +163,7 @@ getIndicatorGraphDataR indicatorId = do
test <- runDB $ get404 testId test <- runDB $ get404 testId
let mPrecision = testPrecision test 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 theNow <- liftIO $ getCurrentTime -- needed to draw the "now" vertical line

View File

@ -36,7 +36,7 @@ getPresentation4RealR = do
(Just (Entity sampleUserId _)) <- runDB $ getBy $ UniqueUser sampleUserIdent (Just (Entity sampleUserId _)) <- runDB $ getBy $ UniqueUser sampleUserIdent
let condition = (\(Entity _ submission) -> (submissionSubmitter submission == sampleUserId)) 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' let evaluationMaps = take 10 evaluationMaps'
sampleLeaderboard <- getSampleLeaderboard sampleChallengeName sampleLeaderboard <- getSampleLeaderboard sampleChallengeName
@ -57,7 +57,7 @@ getPresentationPSNC2019R = do
(Just (Entity sampleUserId _)) <- runDB $ getBy $ UniqueUser sampleUserIdent (Just (Entity sampleUserId _)) <- runDB $ getBy $ UniqueUser sampleUserIdent
let condition = (\(Entity _ submission) -> (submissionSubmitter submission == sampleUserId)) 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' let evaluationMaps = take 10 evaluationMaps'
sampleLeaderboard <- getSampleLeaderboard sampleChallengeName sampleLeaderboard <- getSampleLeaderboard sampleChallengeName

View File

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

View File

@ -461,7 +461,7 @@ checkIndicators user challengeId submissionId submissionLink relevantIndicators
checkIndicator :: UTCTime -> User -> ChallengeId -> SubmissionId -> Text -> IndicatorEntry -> Channel -> Handler () checkIndicator :: UTCTime -> User -> ChallengeId -> SubmissionId -> Text -> IndicatorEntry -> Channel -> Handler ()
checkIndicator theNow user challengeId submissionId submissionLink indicator chan = do 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) mapM_ (\t -> checkTarget theNow user submissionLink entries indicator t chan) (indicatorEntryTargets indicator)
checkTarget :: UTCTime -> User -> Text -> [TableEntry] -> IndicatorEntry -> Entity Target -> Channel -> Handler () 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 :: ((Entity Submission) -> Bool) -> Text -> Handler Html
getChallengeSubmissions condition name = do getChallengeSubmissions condition name = do
Entity challengeId challenge <- runDB $ getBy404 $ UniqueName name 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' let tests = sortBy testComparator tests'
mauth <- maybeAuth mauth <- maybeAuth
let muserId = (\(Entity uid _) -> uid) <$> mauth let muserId = (\(Entity uid _) -> uid) <$> mauth

View File

@ -241,12 +241,13 @@ compareVersions (aM, aN, aP) (bM, bN, bP) = (aM `compare` bM)
<> (aP `compare` bP) <> (aP `compare` bP)
getLeaderboardEntriesByCriterion :: (Ord a) => Int getLeaderboardEntriesByCriterion :: (Ord a) => Int
-> Key Challenge -> Key Challenge
-> ((Entity Submission) -> Bool) -> ((Entity Submission) -> Bool)
-> (TableEntry -> [a]) -> ([(Int, (Entity Submission, Entity Variant))] -> [(Int, (Entity Submission, Entity Variant))])
-> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test])) -> (TableEntry -> [a])
getLeaderboardEntriesByCriterion maxPriority challengeId condition selector = do -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
(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 mainTests = getMainTests tests
let mainTestEnt = getMainTest tests let mainTestEnt = getMainTest tests
let mainTestRef = getTestReference mainTestEnt let mainTestRef = getTestReference mainTestEnt
@ -320,11 +321,13 @@ getLeaderboardEntries maxPriority BySubmitter challengeId =
getLeaderboardEntriesByCriterion maxPriority getLeaderboardEntriesByCriterion maxPriority
challengeId challengeId
(const True) (const True)
onlyTheBestVariant
(\entry -> [entityKey $ tableEntrySubmitter entry]) (\entry -> [entityKey $ tableEntrySubmitter entry])
getLeaderboardEntries maxPriority ByTag challengeId = getLeaderboardEntries maxPriority ByTag challengeId =
getLeaderboardEntriesByCriterion maxPriority getLeaderboardEntriesByCriterion maxPriority
challengeId challengeId
(const True) (const True)
onlyTheBestVariant
(noEmptyList . (map (entityKey . fst)) . tableEntryTagsInfo) (noEmptyList . (map (entityKey . fst)) . tableEntryTagsInfo)
where noEmptyList [] = [Nothing] where noEmptyList [] = [Nothing]
noEmptyList l = map Just l noEmptyList l = map Just l
@ -335,6 +338,11 @@ compareResult _ (Just _) Nothing = GT
compareResult _ Nothing (Just _) = LT compareResult _ Nothing (Just _) = LT
compareResult _ Nothing Nothing = EQ 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, getChallengeSubmissionInfos :: (MonadIO m,
PersistQueryRead backend, PersistQueryRead backend,
BackendCompatible SqlBackend backend, BackendCompatible SqlBackend backend,
@ -342,8 +350,10 @@ getChallengeSubmissionInfos :: (MonadIO m,
=> Int => Int
-> (Entity Submission -> Bool) -> (Entity Submission -> Bool)
-> (Entity Variant -> 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 challenge <- get404 challengeId
let commit = challengeVersion challenge 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)) sortBy (\(r1, (s1, _)) (r2, (s2, _)) -> (submissionStamp (entityVal s2) `compare` submissionStamp (entityVal s1))
`thenCmp` `thenCmp`
(r2 `compare` r1)) (r2 `compare` r1))
$ preselector
$ filter (\(_, (s, _)) -> condition s) $ filter (\(_, (s, _)) -> condition s)
$ map (\(rank, (_, sv)) -> (rank, sv)) $ map (\(rank, (_, sv)) -> (rank, sv))
$ zip [1..] $ zip [1..]
$ sortBy (\(s1, _) (s2, _) -> compareResult (entityVal mainTest) s2 s1) $ sortBy (\(s1, _) (s2, _) -> compareResult (entityVal mainTest) s2 s1)
$ zip scores allSubmissionsVariants $ 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' let evaluationMaps = filter (variantCondition . tableEntryVariant) evaluationMaps'
return (evaluationMaps, tests) return (evaluationMaps, tests)
@ -378,17 +397,15 @@ getScore :: (MonadIO m, BackendCompatible SqlBackend backend,
PersistQueryRead backend, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend) PersistQueryRead backend, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend)
=> Key Test -> Key Variant -> ReaderT backend m (Maybe Double) => Key Test -> Key Variant -> ReaderT backend m (Maybe Double)
getScore testId variantId = do 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.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 ^. OutTest E.==. E.val testId
E.&&. out ^. OutChecksum E.==. evaluation ^. EvaluationChecksum E.&&. out ^. OutChecksum E.==. evaluation ^. EvaluationChecksum
-- all this complication here and with orderBy due -- all this complication here and with orderBy due
-- to the legacy issue with evaluation version sometimes missing -- 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.||. E.isNothing (evaluation ^. EvaluationVersion))
E.&&. evaluation ^. EvaluationTest E.==. E.val testId) E.&&. evaluation ^. EvaluationTest E.==. E.val testId)
E.orderBy [E.desc (E.isNothing (evaluation ^. EvaluationVersion))] E.orderBy [E.desc (E.isNothing (evaluation ^. EvaluationVersion))]
@ -398,24 +415,45 @@ getScore testId variantId = do
[] -> Nothing [] -> 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 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 let versionHash = submissionVersion submission
maybeEvaluations <- mapM (\(Entity _ o) -> fetchTheEvaluation o versionHash) outs maybeEvaluations <- mapM (\(Entity _ o) -> fetchTheEvaluation o versionHash) outs
let evaluations = catMaybes maybeEvaluations let evaluations = catMaybes maybeEvaluations
let pairs = map (\(Entity _ e) -> (evaluationTest e, e)) evaluations 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' let m = Map.fromList pairs'
tagEnts <- getTags submissionId
parameters <- selectList [ParameterVariant ==. variantId] [Asc ParameterName] parameters <- selectList [ParameterVariant ==. variantId] [Asc ParameterName]
(Entity _ version) <- getBy404 $ UniqueVersionByCommit versionHash
let major = versionMajor version let major = versionMajor version
let minor = versionMinor version let minor = versionMinor version
let patch = versionPatch version let patch = versionPatch version

View File

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

View File

@ -170,6 +170,26 @@ executable gonito-bin
ghc-options: -threaded -O2 -rtsopts -with-rtsopts=-N 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 test-suite test
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0