diff --git a/lib/wallet/src/Cardano/DB/Sqlite.hs b/lib/wallet/src/Cardano/DB/Sqlite.hs index e74eec43e01..22b04165c21 100644 --- a/lib/wallet/src/Cardano/DB/Sqlite.hs +++ b/lib/wallet/src/Cardano/DB/Sqlite.hs @@ -28,7 +28,6 @@ module Cardano.DB.Sqlite ( SqliteContext (..) - , newSqliteContext , newInMemorySqliteContext , ForeignKeysSetting (..) @@ -53,6 +52,7 @@ module Cardano.DB.Sqlite -- * Logging , DBLog (..) + , newSqliteContextFile ) where import Prelude @@ -83,7 +83,7 @@ import Data.Aeson import Data.Function ( (&) ) import Data.Functor - ( (<&>) ) + ( ($>), (<&>) ) import Data.List ( isInfixOf ) import Data.List.Split @@ -121,7 +121,7 @@ import Database.Persist.Sqlite import Database.Sqlite ( Connection, Error (ErrorConstraint), SqliteException (SqliteException) ) import Fmt - ( fmt, ordinalF, (+|), (+||), (|+), (||+) ) + ( Buildable (..), fmt, ordinalF, (+|), (+||), (|+), (||+) ) import GHC.Generics ( Generic ) import System.Environment @@ -135,6 +135,16 @@ import UnliftIO.Exception import UnliftIO.MVar ( newMVar, withMVarMasked ) +import Cardano.Wallet.DB.Migration + ( ErrWrongVersion (..) ) +import Control.Lens + ( strict, view ) +import Data.Text.Lazy.Builder + ( toLazyText ) + +-- import Persist.Sql as Persist + +import Control.Monad.Trans.Except import qualified Data.Aeson as Aeson import qualified Data.ByteString.Char8 as B8 import qualified Data.Text as T @@ -201,26 +211,16 @@ newInMemorySqliteContext tr manualMigrations autoMigration newMigrations -- | 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 @@ -232,13 +232,79 @@ 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 bc7d1207e4e..fba5f2b3964 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 ) @@ -218,12 +217,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 b72f4c2cc6a..3a49efbf45e 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 @@ -395,11 +394,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 + runOnDiskNewStyleMigrations + 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 e28a99a5b93..39aa2a6e4bf 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,7 +22,7 @@ module Cardano.Wallet.DB.Migration , VersionT -- * Run migrations - , Version + , Version (..) , MigrationInterface (..) , runMigrations , ErrWrongVersion (..) @@ -40,6 +43,8 @@ import Control.Monad.Reader ( ReaderT (runReaderT) ) import Data.Proxy ( Proxy (..) ) +import Fmt + ( Buildable (..) ) import GHC.Natural ( Natural ) import GHC.TypeNats @@ -53,7 +58,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. -- @@ -103,8 +112,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 +124,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 49d2601d4db..7d6fc72cd07 100644 --- a/lib/wallet/src/Cardano/Wallet/DB/Sqlite/MigrationNew.hs +++ b/lib/wallet/src/Cardano/Wallet/DB/Sqlite/MigrationNew.hs @@ -2,7 +2,7 @@ module Cardano.Wallet.DB.Sqlite.MigrationNew ( runInMemoryNewStyleMigrations - , newMigrationInterfaceFile + , runOnDiskNewStyleMigrations ) where import Prelude hiding @@ -11,7 +11,7 @@ import Prelude hiding import Cardano.DB.Sqlite ( DBLog, withConnectionPool ) import Cardano.Wallet.DB.Migration - ( Migration, MigrationInterface (..), Version, runMigrations ) + ( Migration, MigrationInterface (..), Version (..), runMigrations ) import Cardano.Wallet.DB.Sqlite.MigrationOld ( getSchemaVersion, putSchemaVersion ) import Control.Category @@ -54,10 +54,10 @@ newMigrationInterfaceFile tr = } 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 @@ -74,3 +74,10 @@ runInMemoryNewStyleMigrations conn = (newMigrationInterfaceInMemory conn) () noMigrations + +runOnDiskNewStyleMigrations :: Tracer IO DBLog -> FilePath -> IO () +runOnDiskNewStyleMigrations tr fp = + runMigrations + (newMigrationInterfaceFile tr) + fp + noMigrations diff --git a/lib/wallet/test/unit/Cardano/Wallet/DB/MigrationSpec.hs b/lib/wallet/test/unit/Cardano/Wallet/DB/MigrationSpec.hs index b6329b95fc2..a4d801d1332 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 () where - initialDatabase = Database v0 [] [] + initialDatabase = Database (Version v0) [] []