Switch to an incompatible DB scheme

Evaluation is uniquely identified by test, output checksum
and version checksum.
This commit is contained in:
Filip Gralinski 2021-02-27 11:48:30 +01:00
parent bf00151a5e
commit e185f9251b
8 changed files with 12 additions and 150 deletions

View File

@ -205,13 +205,7 @@ checkOrInsertEvaluation :: FilePath -> Bool -> Channel -> SHA1 -> Out -> Handler
checkOrInsertEvaluation repoDir forceEvaluation chan version out = do checkOrInsertEvaluation repoDir forceEvaluation chan version out = do
test <- runDB $ get404 $ outTest out test <- runDB $ get404 $ outTest out
challenge <- runDB $ get404 $ testChallenge test challenge <- runDB $ get404 $ testChallenge test
maybeEvaluation' <- runDB $ fetchTheEvaluation out version maybeEvaluation <- runDB $ fetchTheEvaluation out version
let maybeEvaluation = case maybeEvaluation' of
Just (Entity _ evaluation) -> case evaluationVersion evaluation of
Just _ -> maybeEvaluation'
Nothing -> Nothing
Nothing -> Nothing
if not forceEvaluation && isJust maybeEvaluation if not forceEvaluation && isJust maybeEvaluation
then then
@ -238,7 +232,7 @@ checkOrInsertEvaluation repoDir forceEvaluation chan version out = do
runDB $ deleteWhere [ runDB $ deleteWhere [
EvaluationTest ==. outTest out, EvaluationTest ==. outTest out,
EvaluationChecksum ==. outChecksum out, EvaluationChecksum ==. outChecksum out,
EvaluationVersion ==. Just version ] EvaluationVersion ==. version ]
else else
return () return ()
_ <- runDB $ insert $ let (pointResult, errorBound) = extractResult result _ <- runDB $ insert $ let (pointResult, errorBound) = extractResult result
@ -249,7 +243,7 @@ checkOrInsertEvaluation repoDir forceEvaluation chan version out = do
evaluationErrorBound=errorBound, evaluationErrorBound=errorBound,
evaluationErrorMessage=Nothing, evaluationErrorMessage=Nothing,
evaluationStamp=time, evaluationStamp=time,
evaluationVersion=Just version } evaluationVersion=version }
msg chan "Evaluation done" msg chan "Evaluation done"
Right (Right (_, Just _)) -> do Right (Right (_, Just _)) -> do
err chan "Unexpected multiple results (???)" err chan "Unexpected multiple results (???)"

View File

@ -230,7 +230,7 @@ doGetScoreForOut mMetricName submission sha1code = do
E.&&. evaluation ^. EvaluationTest E.==. test ^. TestId E.&&. evaluation ^. EvaluationTest E.==. test ^. TestId
E.&&. out ^. OutChecksum E.==. evaluation ^. EvaluationChecksum E.&&. out ^. OutChecksum E.==. evaluation ^. EvaluationChecksum
E.&&. out ^. OutChecksum E.==. E.val sha1code 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.orderBy [E.asc (test ^. TestPriority),
E.desc (version ^. VersionMajor), E.desc (version ^. VersionMajor),
E.desc (version ^. VersionMinor), E.desc (version ^. VersionMinor),
@ -637,7 +637,7 @@ lineByLineTable (Entity testId test) theStamp = mempty
evaluationErrorBound = Nothing, evaluationErrorBound = Nothing,
evaluationErrorMessage = Nothing, evaluationErrorMessage = Nothing,
evaluationStamp = theStamp, evaluationStamp = theStamp,
evaluationVersion = Nothing } evaluationVersion = undefined }
resultTable :: Entity Submission -> WidgetFor App () resultTable :: Entity Submission -> WidgetFor App ()
resultTable (Entity submissionId submission) = do resultTable (Entity submissionId submission) = do

View File

@ -602,25 +602,7 @@ checkWhetherGivenUserRepo userId submissionId = do
submission <- get404 submissionId submission <- get404 submissionId
return $ userId == submissionSubmitter submission 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)) => Out -> SHA1 -> ReaderT backend m (Maybe (Entity Evaluation))
fetchTheEvaluation out version = do fetchTheEvaluation out version =
-- It's complicated due to legacy issues - should be getBy $ UniqueEvaluationTestChecksumVersion (outTest out) (outChecksum out) version
-- 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))

View File

@ -721,8 +721,7 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do
E.&&. test ^. TestName E.==. E.val (testName mainTest) E.&&. test ^. TestName E.==. E.val (testName mainTest)
E.&&. test ^. TestMetric E.==. E.val (testMetric mainTest) E.&&. test ^. TestMetric E.==. E.val (testMetric mainTest)
E.&&. test ^. TestActive E.&&. test ^. TestActive
E.&&. (evaluation ^. EvaluationVersion E.==. E.just (theVersion ^. VersionCommit) E.&&. (evaluation ^. EvaluationVersion E.==. theVersion ^. VersionCommit)
E.||. E.isNothing (evaluation ^. EvaluationVersion))
E.&&. theVersion ^. VersionCommit E.==. test ^. TestCommit E.&&. theVersion ^. VersionCommit E.==. test ^. TestCommit
E.&&. theVersion ^. VersionMajor E.>=. E.val submittedMajorVersion) E.&&. theVersion ^. VersionMajor E.>=. E.val submittedMajorVersion)
E.orderBy [orderDirection (evaluation ^. EvaluationScore)] E.orderBy [orderDirection (evaluation ^. EvaluationScore)]

View File

@ -472,8 +472,7 @@ getScore testId variantId = do
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.just (submission ^. SubmissionVersion) E.&&. (evaluation ^. EvaluationVersion E.==. submission ^. SubmissionVersion)
E.||. E.isNothing (evaluation ^. EvaluationVersion))
E.&&. evaluation ^. EvaluationTest E.==. E.val testId) E.&&. evaluation ^. EvaluationTest E.==. E.val testId)
E.orderBy [E.asc (evaluation ^. EvaluationScore)] E.orderBy [E.asc (evaluation ^. EvaluationScore)]
return evaluation return evaluation

View File

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

View File

@ -129,7 +129,8 @@ Evaluation
errorMessage Text Maybe errorMessage Text Maybe
stamp UTCTime default=now() stamp UTCTime default=now()
-- Should be just SHA1 (without Maybe) - Maybe is just a legacy -- Should be just SHA1 (without Maybe) - Maybe is just a legacy
version SHA1 Maybe version SHA1
UniqueEvaluationTestChecksumVersion test checksum version
deriving Show deriving Show
Comment Comment
challenge ChallengeId challenge ChallengeId

View File

@ -181,27 +181,6 @@ 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
main-is: Spec.hs main-is: Spec.hs