From e185f9251b1c51061ab61322d7c1bbc3f7c38b38 Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Sat, 27 Feb 2021 11:48:30 +0100 Subject: [PATCH] Switch to an incompatible DB scheme Evaluation is uniquely identified by test, output checksum and version checksum. --- Handler/Evaluate.hs | 12 ++---- Handler/Query.hs | 4 +- Handler/Shared.hs | 24 ++--------- Handler/ShowChallenge.hs | 3 +- Handler/Tables.hs | 3 +- app/upgrade-to-0-2.hs | 92 ---------------------------------------- config/models | 3 +- gonito.cabal | 21 --------- 8 files changed, 12 insertions(+), 150 deletions(-) delete mode 100644 app/upgrade-to-0-2.hs diff --git a/Handler/Evaluate.hs b/Handler/Evaluate.hs index 9594a6d..bd2e281 100644 --- a/Handler/Evaluate.hs +++ b/Handler/Evaluate.hs @@ -205,13 +205,7 @@ checkOrInsertEvaluation :: FilePath -> Bool -> Channel -> SHA1 -> Out -> Handler checkOrInsertEvaluation repoDir forceEvaluation chan version out = do test <- runDB $ get404 $ outTest out challenge <- runDB $ get404 $ testChallenge test - maybeEvaluation' <- runDB $ fetchTheEvaluation out version - - let maybeEvaluation = case maybeEvaluation' of - Just (Entity _ evaluation) -> case evaluationVersion evaluation of - Just _ -> maybeEvaluation' - Nothing -> Nothing - Nothing -> Nothing + maybeEvaluation <- runDB $ fetchTheEvaluation out version if not forceEvaluation && isJust maybeEvaluation then @@ -238,7 +232,7 @@ checkOrInsertEvaluation repoDir forceEvaluation chan version out = do runDB $ deleteWhere [ EvaluationTest ==. outTest out, EvaluationChecksum ==. outChecksum out, - EvaluationVersion ==. Just version ] + EvaluationVersion ==. version ] else return () _ <- runDB $ insert $ let (pointResult, errorBound) = extractResult result @@ -249,7 +243,7 @@ checkOrInsertEvaluation repoDir forceEvaluation chan version out = do evaluationErrorBound=errorBound, evaluationErrorMessage=Nothing, evaluationStamp=time, - evaluationVersion=Just version } + evaluationVersion=version } msg chan "Evaluation done" Right (Right (_, Just _)) -> do err chan "Unexpected multiple results (???)" diff --git a/Handler/Query.hs b/Handler/Query.hs index e1dc389..d4fc908 100644 --- a/Handler/Query.hs +++ b/Handler/Query.hs @@ -230,7 +230,7 @@ doGetScoreForOut mMetricName submission sha1code = do E.&&. evaluation ^. EvaluationTest E.==. test ^. TestId E.&&. out ^. OutChecksum E.==. evaluation ^. EvaluationChecksum E.&&. out ^. OutChecksum E.==. E.val sha1code - E.&&. (evaluation ^. EvaluationVersion E.==. E.just (version ^. VersionCommit))) + E.&&. (evaluation ^. EvaluationVersion E.==. version ^. VersionCommit)) E.orderBy [E.asc (test ^. TestPriority), E.desc (version ^. VersionMajor), E.desc (version ^. VersionMinor), @@ -637,7 +637,7 @@ lineByLineTable (Entity testId test) theStamp = mempty evaluationErrorBound = Nothing, evaluationErrorMessage = Nothing, evaluationStamp = theStamp, - evaluationVersion = Nothing } + evaluationVersion = undefined } resultTable :: Entity Submission -> WidgetFor App () resultTable (Entity submissionId submission) = do diff --git a/Handler/Shared.hs b/Handler/Shared.hs index 5b81c73..03fe643 100644 --- a/Handler/Shared.hs +++ b/Handler/Shared.hs @@ -602,25 +602,7 @@ checkWhetherGivenUserRepo userId submissionId = do submission <- get404 submissionId return $ userId == submissionSubmitter submission -fetchTheEvaluation :: (PersistQueryRead backend, MonadIO m, BaseBackend backend ~ SqlBackend) +fetchTheEvaluation :: (MonadIO m, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend) => Out -> SHA1 -> ReaderT backend m (Maybe (Entity Evaluation)) -fetchTheEvaluation out version = do - -- It's complicated due to legacy issues - should be - -- done by simply running UniqueEvaluationTestChecksumVersion - - evals <- selectList [EvaluationTest ==. outTest out, - EvaluationChecksum ==. outChecksum out, - EvaluationVersion ==. Just version] [] - case evals of - [eval] -> return $ Just eval - [] -> do - evals' <- selectList [EvaluationTest ==. outTest out, - EvaluationChecksum ==. outChecksum out, - EvaluationVersion ==. Nothing] [] - case evals' of - [eval] -> return $ Just eval - [] -> return Nothing - _ -> error ("More than 1 evaluation for the same test and version!" ++ (show evals)) - (eval:_) -> return $ Just eval - --- -> error ("More than 1 evaluation for the same test, checksum and version!" ++ (show evals)) +fetchTheEvaluation out version = + getBy $ UniqueEvaluationTestChecksumVersion (outTest out) (outChecksum out) version diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index 1eb6723..951a9ca 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -721,8 +721,7 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do E.&&. test ^. TestName E.==. E.val (testName mainTest) E.&&. test ^. TestMetric E.==. E.val (testMetric mainTest) E.&&. test ^. TestActive - E.&&. (evaluation ^. EvaluationVersion E.==. E.just (theVersion ^. VersionCommit) - E.||. E.isNothing (evaluation ^. EvaluationVersion)) + E.&&. (evaluation ^. EvaluationVersion E.==. theVersion ^. VersionCommit) E.&&. theVersion ^. VersionCommit E.==. test ^. TestCommit E.&&. theVersion ^. VersionMajor E.>=. E.val submittedMajorVersion) E.orderBy [orderDirection (evaluation ^. EvaluationScore)] diff --git a/Handler/Tables.hs b/Handler/Tables.hs index aa0f94f..362c7b6 100644 --- a/Handler/Tables.hs +++ b/Handler/Tables.hs @@ -472,8 +472,7 @@ getScore testId variantId = do 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.just (submission ^. SubmissionVersion) - E.||. E.isNothing (evaluation ^. EvaluationVersion)) + E.&&. (evaluation ^. EvaluationVersion E.==. submission ^. SubmissionVersion) E.&&. evaluation ^. EvaluationTest E.==. E.val testId) E.orderBy [E.asc (evaluation ^. EvaluationScore)] return evaluation diff --git a/app/upgrade-to-0-2.hs b/app/upgrade-to-0-2.hs deleted file mode 100644 index e137ff7..0000000 --- a/app/upgrade-to-0-2.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# 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…" - let total = length variants - putStrLn $ "TOTAL " ++ (show total) - _ <- mapM (\(v, ix) -> processVariant total ix dbName v) $ zip variants [1..] - - putStrLn "DELETING" - runOnDb dbName $ deleteWhere [EvaluationVersion ==. Nothing] - - return () - -processVariant :: Int -> Int -> String -> (Entity Variant, Entity Submission, Entity Out, Entity Test) -> IO () -processVariant total ix dbName (variant, Entity _ submission, Entity _ out, Entity testId _) = do - Prelude.putStrLn (show $ entityKey variant) - Prelude.putStrLn ((show ix) ++ "/" ++ (show total)) - - 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.desc (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) - (evaluationErrorBound 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/config/models b/config/models index 8407532..9573f44 100644 --- a/config/models +++ b/config/models @@ -129,7 +129,8 @@ Evaluation errorMessage Text Maybe stamp UTCTime default=now() -- Should be just SHA1 (without Maybe) - Maybe is just a legacy - version SHA1 Maybe + version SHA1 + UniqueEvaluationTestChecksumVersion test checksum version deriving Show Comment challenge ChallengeId diff --git a/gonito.cabal b/gonito.cabal index 79fb7ce..59edae1 100644 --- a/gonito.cabal +++ b/gonito.cabal @@ -181,27 +181,6 @@ 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 main-is: Spec.hs