From 1ae3fe1d36b7b165f8857e1cd200f3c0b2345f73 Mon Sep 17 00:00:00 2001 From: paolino Date: Tue, 6 Jun 2023 11:02:42 +0000 Subject: [PATCH] Integrate new migrations into the db layer on disk operations. --- lib/wallet/src/Cardano/DB/Sqlite.hs | 114 ++++++++++++++---- lib/wallet/src/Cardano/Pool/DB/Sqlite.hs | 15 ++- lib/wallet/src/Cardano/Wallet/DB/Layer.hs | 15 +-- lib/wallet/src/Cardano/Wallet/DB/Migration.hs | 30 ++++- .../Cardano/Wallet/DB/Sqlite/MigrationNew.hs | 61 ++++++++-- .../test/unit/Cardano/Pool/DB/SqliteSpec.hs | 2 +- .../unit/Cardano/Wallet/DB/MigrationSpec.hs | 4 +- 7 files changed, 183 insertions(+), 58 deletions(-) diff --git a/lib/wallet/src/Cardano/DB/Sqlite.hs b/lib/wallet/src/Cardano/DB/Sqlite.hs index 287c7c33b68..b11b3473829 100644 --- a/lib/wallet/src/Cardano/DB/Sqlite.hs +++ b/lib/wallet/src/Cardano/DB/Sqlite.hs @@ -28,7 +28,7 @@ module Cardano.DB.Sqlite ( SqliteContext (..) - , newSqliteContext + , newSqliteContextFile , newInMemorySqliteContext , ForeignKeysSetting (..) @@ -61,14 +61,20 @@ import Cardano.BM.Data.Severity ( Severity (..) ) import Cardano.BM.Data.Tracer ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) ) +import Cardano.Wallet.DB.Migration + ( ErrWrongVersion (..) ) import Cardano.Wallet.Logging ( BracketLog, bracketTracer ) +import Control.Lens + ( strict, view ) import Control.Monad ( join, void, when ) import Control.Monad.IO.Unlift ( MonadUnliftIO (..) ) import Control.Monad.Logger ( LogLevel (..) ) +import Control.Monad.Trans.Except + ( ExceptT (..), runExceptT ) import Control.Retry ( RetryStatus (..) , constantDelay @@ -83,7 +89,7 @@ import Data.Aeson import Data.Function ( (&) ) import Data.Functor - ( (<&>) ) + ( ($>), (<&>) ) import Data.List ( isInfixOf ) import Data.List.Split @@ -96,6 +102,8 @@ import Data.Text ( Text ) import Data.Text.Class ( ToText (..) ) +import Data.Text.Lazy.Builder + ( toLazyText ) import Data.Time.Clock ( NominalDiffTime ) import Database.Persist.EntityDef @@ -119,9 +127,9 @@ import Database.Persist.Sql import Database.Persist.Sqlite ( SqlBackend, wrapConnection ) import Database.Sqlite - ( Error (ErrorConstraint), SqliteException (SqliteException) ) + ( Connection, Error (ErrorConstraint), SqliteException (SqliteException) ) import Fmt - ( fmt, ordinalF, (+|), (+||), (|+), (||+) ) + ( Buildable (..), fmt, ordinalF, (+|), (+||), (|+), (||+) ) import GHC.Generics ( Generic ) import System.Environment @@ -198,26 +206,16 @@ newInMemorySqliteContext tr manualMigrations autoMigration disableFK = do -- | Sets up query logging and timing, runs schema migrations if necessary and -- provide a safe 'SqliteContext' for interacting with the database. -newSqliteContext - :: Tracer IO DBLog - -> ConnectionPool - -> [ManualMigration] - -> Migration +newSqliteContextFile + :: Tracer IO DBLog -- ^ Logging + -> FilePath -- ^ Database file + -> [ManualMigration] -- ^ Manual migrations + -> Migration -- ^ Auto migration + -> (Tracer IO DBLog -> FilePath -> IO ()) -- ^ New style migrations -> IO (Either MigrationError SqliteContext) -newSqliteContext tr pool manualMigrations autoMigration = do - migrationResult <- withResource pool $ \(backend, conn) -> do - let executeAutoMigration = runSqlConn - (runMigrationUnsafeQuiet autoMigration) - backend - migrationResult <- withForeignKeysDisabled tr conn $ do - mapM_ (`executeManualMigration` conn) manualMigrations - executeAutoMigration - & tryJust (matchMigrationError @PersistException) - & tryJust (matchMigrationError @SqliteException) - & fmap join - traceWith tr $ MsgMigrations $ fmap length migrationResult - return migrationResult - return $ case migrationResult of +newSqliteContextFile tr fp old auto new = do + migrationResult <- runAllMigrations tr fp old auto new + pure $ case migrationResult of Left e -> Left e Right{} -> let observe :: IO a -> IO a @@ -229,13 +227,77 @@ newSqliteContext tr pool manualMigrations autoMigration = do -- asynchronous exception occurs (or actually any exception), the -- resource is NOT placed back in the pool. runQuery :: SqlPersistT IO a -> IO a - runQuery cmd = withResource pool $ - observe + runQuery cmd = runDBAction tr fp $ + observe . retryOnBusy tr retryOnBusyTimeout . runSqlConn cmd . fst - in Right $ SqliteContext { runQuery } +matchWrongVersionError :: ErrWrongVersion -> Maybe MigrationError +matchWrongVersionError = + Just + . MigrationError + . view strict + . toLazyText + . build + +type DBAction a = (SqlBackend, Connection) -> IO a + +runDBAction + :: Tracer IO DBLog + -> FilePath + -> DBAction a + -- ^ New style migrations + -> IO a +runDBAction trDB dbFile action = + withConnectionPool trDB dbFile $ \pool -> + withResource pool action + +runAutoMigration + :: Tracer IO DBLog + -> Migration + -> DBAction (Either MigrationError ()) +runAutoMigration tr autoMigration (backend, conn) = do + let executeAutoMigration = + runSqlConn + (runMigrationUnsafeQuiet autoMigration) + backend + migrationResult <- withForeignKeysDisabled tr conn $ do + executeAutoMigration + & tryJust (matchMigrationError @PersistException) + & tryJust (matchMigrationError @SqliteException) + & fmap join + traceWith tr $ MsgMigrations $ length <$> migrationResult + return $ migrationResult $> () + +runManualOldMigrations + :: Tracer IO DBLog + -> [ManualMigration] + -> DBAction (Either MigrationError ()) +runManualOldMigrations tr manualMigration (_backend, conn) = do + withForeignKeysDisabled tr conn $ Right <$> + mapM_ (`executeManualMigration` conn) manualMigration + +runManualNewMigrations + :: Tracer IO DBLog + -> FilePath + -> (Tracer IO DBLog -> FilePath -> IO ()) + -> IO (Either MigrationError ()) +runManualNewMigrations tr fp newMigrations = + newMigrations tr fp + & tryJust matchWrongVersionError + +runAllMigrations :: Tracer IO DBLog + -> FilePath + -> [ManualMigration] + -> Migration + -> (Tracer IO DBLog -> FilePath -> IO ()) + -> IO (Either MigrationError ()) +runAllMigrations tr fp old auto new = runExceptT $ do + ExceptT $ runDBAction tr fp $ runManualOldMigrations tr old + ExceptT $ runDBAction tr fp $ runAutoMigration tr auto + ExceptT $ runManualNewMigrations tr fp new + -- | Finalize database statements and close the database connection. -- -- If the database connection is still in use, it will retry for up to a minute, diff --git a/lib/wallet/src/Cardano/Pool/DB/Sqlite.hs b/lib/wallet/src/Cardano/Pool/DB/Sqlite.hs index f713e9ae70d..0c0928c0104 100644 --- a/lib/wallet/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/wallet/src/Cardano/Pool/DB/Sqlite.hs @@ -45,9 +45,8 @@ import Cardano.DB.Sqlite , fieldName , handleConstraint , newInMemorySqliteContext - , newSqliteContext + , newSqliteContextFile , tableName - , withConnectionPool ) import Cardano.Pool.DB ( DBLayer (..), ErrPointAlreadyExists (..), determinePoolLifeCycleStatus ) @@ -213,12 +212,12 @@ withDecoratedDBLayer dbDecorator tr mDatabaseDir ti action = do fst (action . decorateDBLayer dbDecorator . newDBLayer tr ti . snd) - Just fp -> handlingPersistError tr fp $ - withConnectionPool tr' fp $ \pool -> do - ctx <- newSqliteContext tr' pool createViews migrateAll - ctx & either - throwIO - (action . decorateDBLayer dbDecorator . newDBLayer tr ti) + Just fp -> handlingPersistError tr fp $ do + ctx <- newSqliteContextFile tr' fp createViews migrateAll + $ \_ _ -> pure () + ctx & either + throwIO + (action . decorateDBLayer dbDecorator . newDBLayer tr ti) where tr' = contramap MsgGeneric tr diff --git a/lib/wallet/src/Cardano/Wallet/DB/Layer.hs b/lib/wallet/src/Cardano/Wallet/DB/Layer.hs index b817c501635..89f9d01b361 100644 --- a/lib/wallet/src/Cardano/Wallet/DB/Layer.hs +++ b/lib/wallet/src/Cardano/Wallet/DB/Layer.hs @@ -50,8 +50,7 @@ import Cardano.DB.Sqlite , ForeignKeysSetting (ForeignKeysEnabled) , SqliteContext (..) , newInMemorySqliteContext - , newSqliteContext - , withConnectionPool + , newSqliteContextFile ) import Cardano.DB.Sqlite.Delete ( DeleteSqliteDatabaseLog @@ -206,6 +205,8 @@ import UnliftIO.Exception import UnliftIO.MVar ( modifyMVar, modifyMVar_, newMVar, readMVar, withMVar ) +import Cardano.Wallet.DB.Sqlite.MigrationNew + ( runNewStyleMigrations ) import qualified Cardano.Wallet.Primitive.Model as W import qualified Cardano.Wallet.Primitive.Types as W import qualified Cardano.Wallet.Primitive.Types.Coin as Coin @@ -394,11 +395,11 @@ withDBOpenFromFile walletF tr defaultFieldValues dbFile action = do maybe [] (migrateManually trDB $ keyOfWallet walletF) defaultFieldValues let autoMigrations = migrateAll - withConnectionPool trDB dbFile $ \pool -> do - res <- newSqliteContext trDB pool manualMigrations autoMigrations - case res of - Left err -> throwIO err - Right sqliteContext -> action =<< newQueryLock sqliteContext + res <- newSqliteContextFile trDB dbFile manualMigrations autoMigrations + runNewStyleMigrations + case res of + Left err -> throwIO err + Right sqliteContext -> action =<< newQueryLock sqliteContext -- | Open an SQLite database in-memory. diff --git a/lib/wallet/src/Cardano/Wallet/DB/Migration.hs b/lib/wallet/src/Cardano/Wallet/DB/Migration.hs index a8121fc013c..3bbea7a5114 100644 --- a/lib/wallet/src/Cardano/Wallet/DB/Migration.hs +++ b/lib/wallet/src/Cardano/Wallet/DB/Migration.hs @@ -1,10 +1,13 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} -- | -- Copyright: © 2023 IOHK @@ -19,10 +22,11 @@ module Cardano.Wallet.DB.Migration , VersionT -- * Run migrations - , Version + , Version (..) , MigrationInterface (..) , runMigrations , ErrWrongVersion (..) + , hoistMigration ) where import Prelude hiding @@ -40,6 +44,8 @@ import Control.Monad.Reader ( ReaderT (runReaderT) ) import Data.Proxy ( Proxy (..) ) +import Fmt + ( Buildable (..) ) import GHC.Natural ( Natural ) import GHC.TypeNats @@ -53,7 +59,11 @@ import GHC.TypeNats type VersionT = Nat -- | A version number at value level. -type Version = Natural +newtype Version = Version Natural + deriving newtype (Show, Eq, Enum, Num, Ord) + +instance Buildable Version where + build = build . show -- | A migration path between two database versions. -- @@ -61,6 +71,12 @@ type Version = Natural -- versions in the range @from@ @to@. newtype Migration m (from :: VersionT) (to :: VersionT) = Migration [m ()] +hoistMigration + :: (forall x. m x -> n x) + -> Migration m from to + -> Migration n from to +hoistMigration f (Migration steps) = Migration (fmap f steps) + -- | A migration path between two consecutive versions. mkMigration :: forall v m. m () -> Migration m v (v + 1) mkMigration m = Migration [m] @@ -103,8 +119,8 @@ runMigrations -- @vtarget@ is the version to which the database is migrated. -> m () runMigrations interface filepath (Migration steps) = do - let nfrom = natVal (Proxy :: Proxy vmin) - nto = natVal (Proxy :: Proxy vtarget) + let nfrom = Version $ natVal (Proxy :: Proxy vmin) + nto = Version $ natVal (Proxy :: Proxy vtarget) forM_ (zip [nfrom .. nto] steps) $ uncurry (runMigrationStep interface filepath) @@ -115,6 +131,12 @@ data ErrWrongVersion = ErrWrongVersion } deriving (Show, Eq, Exception) +instance Buildable ErrWrongVersion where + build (ErrWrongVersion expected actual) = "Expected database version " + <> build expected + <> ", but found " + <> build actual + <> "." -------------------------------------------------------------------------------- ------- internal -------------------------------------------------------------- -------------------------------------------------------------------------------- diff --git a/lib/wallet/src/Cardano/Wallet/DB/Sqlite/MigrationNew.hs b/lib/wallet/src/Cardano/Wallet/DB/Sqlite/MigrationNew.hs index 2d1c938de22..222723c5428 100644 --- a/lib/wallet/src/Cardano/Wallet/DB/Sqlite/MigrationNew.hs +++ b/lib/wallet/src/Cardano/Wallet/DB/Sqlite/MigrationNew.hs @@ -1,26 +1,56 @@ -module Cardano.Wallet.DB.Sqlite.MigrationNew (newMigrationInterface) where +{-# LANGUAGE DataKinds #-} -import Prelude +module Cardano.Wallet.DB.Sqlite.MigrationNew + ( runNewStyleMigrations + , DBHandle(..)) where + +import Prelude hiding + ( id, (.) ) import Cardano.DB.Sqlite ( DBLog, withConnectionPool ) import Cardano.Wallet.DB.Migration - ( MigrationInterface (..), Version ) + ( Migration + , MigrationInterface (..) + , Version (..) + , hoistMigration + , runMigrations + ) import Cardano.Wallet.DB.Sqlite.MigrationOld ( getSchemaVersion, putSchemaVersion ) +import Control.Category + ( Category (id), (.) ) +import Control.Monad.Reader + ( withReaderT ) +import Control.Monad.Trans.Reader + ( ReaderT ) import Control.Tracer ( Tracer ) import Data.Pool ( withResource ) +import Database.Persist.Sql + ( SqlBackend ) +import Database.Persist.Sqlite + ( SqlPersistT ) +import Database.Sqlite + ( Connection ) import System.Directory ( copyFile ) import qualified Cardano.Wallet.DB.Sqlite.MigrationOld as MigrateOld import qualified Database.Sqlite as Sqlite +data DBHandle = DBHandle + { dbConn :: Connection + , dbBackend :: SqlBackend + } + +mkDBHandle :: (SqlBackend, Connection) -> DBHandle +mkDBHandle (backend, conn) = DBHandle conn backend + newMigrationInterface :: Tracer IO DBLog - -> MigrationInterface IO Sqlite.Connection + -> MigrationInterface IO DBHandle newMigrationInterface tr = MigrationInterface { backupDatabaseFile = \fp v -> do @@ -28,20 +58,31 @@ newMigrationInterface tr = copyFile fp backupFile , withDatabaseFile = \fp f -> do withConnectionPool tr fp $ \pool -> - withResource pool $ \(_, conn) -> do - f conn - , getVersion = getVersionNew - , setVersion = setVersionNew + withResource pool $ f . mkDBHandle + , getVersion = getVersionNew . dbConn + , setVersion = setVersionNew . dbConn } oldToNewSchemaVersion :: MigrateOld.SchemaVersion -> Version -oldToNewSchemaVersion (MigrateOld.SchemaVersion v) = v +oldToNewSchemaVersion (MigrateOld.SchemaVersion v) = Version v newToOldSchemaVersion :: Version -> MigrateOld.SchemaVersion -newToOldSchemaVersion = MigrateOld.SchemaVersion +newToOldSchemaVersion (Version v) = MigrateOld.SchemaVersion v getVersionNew :: Sqlite.Connection -> IO Version getVersionNew = fmap oldToNewSchemaVersion . getSchemaVersion setVersionNew :: Sqlite.Connection -> Version -> IO () setVersionNew conn = putSchemaVersion conn . newToOldSchemaVersion + +noMigrations :: Migration m 2 2 +noMigrations = id + +_useSqlBackend + :: Migration (SqlPersistT m) from to + -> Migration (ReaderT DBHandle m) from to +_useSqlBackend = hoistMigration $ withReaderT dbBackend + +runNewStyleMigrations :: Tracer IO DBLog -> FilePath -> IO () +runNewStyleMigrations tr fp = runMigrations (newMigrationInterface tr) fp + noMigrations diff --git a/lib/wallet/test/unit/Cardano/Pool/DB/SqliteSpec.hs b/lib/wallet/test/unit/Cardano/Pool/DB/SqliteSpec.hs index ea3c60ae363..ad0beba97bc 100644 --- a/lib/wallet/test/unit/Cardano/Pool/DB/SqliteSpec.hs +++ b/lib/wallet/test/unit/Cardano/Pool/DB/SqliteSpec.hs @@ -70,7 +70,7 @@ test_migrationFromv20191216 = let databaseResetMsg = filter (== MsgGeneric MsgDatabaseReset) logs let migrationErrMsg = filter isMsgMigrationError logs - length databaseConnMsg `shouldBe` 3 + length databaseConnMsg `shouldBe` 6 length databaseResetMsg `shouldBe` 1 length migrationErrMsg `shouldBe` 1 diff --git a/lib/wallet/test/unit/Cardano/Wallet/DB/MigrationSpec.hs b/lib/wallet/test/unit/Cardano/Wallet/DB/MigrationSpec.hs index d17e4a7bb85..3acfffcc5a8 100644 --- a/lib/wallet/test/unit/Cardano/Wallet/DB/MigrationSpec.hs +++ b/lib/wallet/test/unit/Cardano/Wallet/DB/MigrationSpec.hs @@ -15,7 +15,7 @@ import Cardano.Wallet.DB.Migration ( ErrWrongVersion (ErrWrongVersion) , Migration , MigrationInterface (..) - , Version + , Version (..) , mkMigration , runMigrations ) @@ -137,4 +137,4 @@ runTestMigrations v0 = runMonadDatabase initialDatabase . runMigrations mkMigrationInterface "filepath" where - initialDatabase = Database v0 [] [] + initialDatabase = Database (Version v0) [] []