Add helper program for migrating DB for the future version

This commit is contained in:
Filip Gralinski 2020-01-04 20:52:57 +01:00
parent 00f2c4567a
commit f7895f46b4
2 changed files with 108 additions and 0 deletions

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