forked from filipg/gonito
Switch to an incompatible DB scheme
Evaluation is uniquely identified by test, output checksum and version checksum.
This commit is contained in:
parent
bf00151a5e
commit
e185f9251b
@ -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 (???)"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
21
gonito.cabal
21
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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user