[ADP-3214] Put responsibility for migrations into `withLoadDBLayerFro…

…mFile` (#4230)

In order to improve the database initialization logic, this pull request
refactors the `withLoadDBLayerFromFile` function to take full
responsibility for running migrations on the database file.

- [x] A function `migrateDBFile` does what its name suggests.
- [x] `withLoadDBLayerFromFile ` calls `withSqliteContextFile` with
empty migrations
- [x] The new-style migrations are removed from `withSqliteContextFile`

As the auto-migrations are no longer run when loading a database, we
also need to adjust the `Migrations.Old` to explicitly create tables and
columns in order to migrate a pre-version database to `SchemaVersion 1`.

As a result of these changes, we can make the migration from
`SchemaVersion 2` to `SchemaVersion 3` more strict — it will now fail if
a table that should be present in `SchemaVersion 2` cannot be found.

### Comments

* In a future pull request, `withBootDBLayerFromFile` and
`newBootDBLayerInMemory` need to be adjusted as well, so that they call
`withSqliteContextFile` with empty migrations.

### Issue

ADP-3214

lib/wallet/cardano-wallet.cabal

@@ -257,6 +257,7 @@ library
     Cardano.Wallet.DB.Pure.Layer
     Cardano.Wallet.DB.Sqlite.Migration.New
     Cardano.Wallet.DB.Sqlite.Migration.Old
+    Cardano.Wallet.DB.Sqlite.Migration.SchemaVersion1
     Cardano.Wallet.DB.Sqlite.Schema
     Cardano.Wallet.DB.Sqlite.Types
     Cardano.Wallet.DB.Store.Checkpoints.Store

lib/wallet/src/Cardano/DB/Sqlite.hs

@@ -36,6 +36,10 @@ module Cardano.DB.Sqlite
     , dbFile
     , dbBackend
 
+      -- * Migrations
+    , runManualOldMigrations
+    , matchWrongVersionError
+
       -- * Helpers
     , chunkSize
     , dbChunked
@@ -86,6 +90,9 @@ import Control.Monad.Logger
 import Control.Monad.Reader
     ( ReaderT
     )
+import Control.Monad.Trans.Class
+    ( lift
+    )
 import Control.Monad.Trans.Except
     ( ExceptT (..)
     , runExceptT
@@ -247,29 +254,26 @@ withSqliteContextFile
     -- ^ Manual migrations
     -> Migration
     -- ^ Auto migration
-    -> (Tracer IO DBLog -> FilePath -> IO ())
-    -- ^ New style migrations
     -> (SqliteContext -> IO a)
     -> IO (Either MigrationError a)
-withSqliteContextFile tr fp old auto new action = do
-    migrationResult <- runAllMigrations tr fp old auto new
-    case migrationResult of
-        Left e -> pure $ Left e
-        Right{} -> do
-            lock <- newMVar ()
-            withDBHandle tr fp $ \DBHandle{dbBackend} ->
-                let
-                    -- Run a query on the open database,
-                    -- but retry on busy.
-                    runQuery :: SqlPersistT IO a -> IO a
-                    runQuery cmd =
-                        observe
-                            . retryOnBusy tr retryOnBusyTimeout
-                            $ withMVar lock
-                            $ const
-                            $ runSqlConn cmd dbBackend
-                in
-                    Right <$> action (SqliteContext{runQuery})
+withSqliteContextFile tr fp old auto action = runExceptT $ do
+    ExceptT $ withDBHandle tr fp $ runManualOldMigrations tr old
+    ExceptT $ withDBHandle tr fp $ runAutoMigration tr auto
+    lift $ do
+        lock <- newMVar ()
+        withDBHandle tr fp $ \DBHandle{dbBackend} ->
+            let
+                -- Run a query on the open database,
+                -- but retry on busy.
+                runQuery :: SqlPersistT IO a -> IO a
+                runQuery cmd =
+                    observe
+                        . retryOnBusy tr retryOnBusyTimeout
+                        $ withMVar lock
+                        $ const
+                        $ runSqlConn cmd dbBackend
+            in
+                action (SqliteContext{runQuery})
   where
     observe :: IO a -> IO a
     observe = bracketTracer (contramap MsgRun tr)
@@ -456,15 +460,6 @@ runManualOldMigrations tr manualMigration DBHandle{dbConn} = do
         $ Right
             <$> (`executeManualMigration` dbConn) manualMigration
 
-runManualNewMigrations
-    :: Tracer IO DBLog
-    -> FilePath
-    -> (Tracer IO DBLog -> FilePath -> IO ())
-    -> IO (Either MigrationError ())
-runManualNewMigrations tr fp newMigrations =
-    newMigrations tr fp
-        & tryJust matchWrongVersionError
-
 matchWrongVersionError :: ErrWrongVersion -> Maybe MigrationError
 matchWrongVersionError =
     Just
@@ -473,18 +468,6 @@ matchWrongVersionError =
         . toLazyText
         . build
 
-runAllMigrations
-    :: Tracer IO DBLog
-    -> FilePath
-    -> ManualMigration
-    -> Migration
-    -> (Tracer IO DBLog -> FilePath -> IO ())
-    -> IO (Either MigrationError ())
-runAllMigrations tr fp old auto new = runExceptT $ do
-    ExceptT $ withDBHandle tr fp $ runManualOldMigrations tr old
-    ExceptT $ withDBHandle tr fp $ runAutoMigration tr auto
-    ExceptT $ runManualNewMigrations tr fp new
-
 {-------------------------------------------------------------------------------
                                     Logging
 -------------------------------------------------------------------------------}

lib/wallet/src/Cardano/Pool/DB/Layer.hs

@@ -282,12 +282,10 @@ withDecoratedDBLayer dbDecorator tr mDatabaseDir ti action = do
                     fp
                     createViews
                     migrateAll
-                    newMigrations
                     $ action . decorateDBLayer dbDecorator . newDBLayer tr ti
             either throwIO pure res
   where
     tr' = contramap MsgGeneric tr
-    newMigrations _ _ = pure ()
 
 -- | Sets up a connection to the SQLite database.
 --

lib/wallet/src/Cardano/Wallet/DB/Layer.hs

@@ -53,7 +53,10 @@ import Cardano.DB.Sqlite
     ( DBLog (..)
     , ForeignKeysSetting (ForeignKeysEnabled)
     , SqliteContext (..)
+    , matchWrongVersionError
     , newInMemorySqliteContext
+    , runManualOldMigrations
+    , withDBHandle
     , withSqliteContextFile
     )
 import Cardano.DB.Sqlite.Delete
@@ -65,6 +68,7 @@ import Cardano.DB.Sqlite.Delete
     )
 import Cardano.DB.Sqlite.Migration.Old
     ( ManualMigration (..)
+    , MigrationError
     , noManualMigration
     )
 import Cardano.Slotting.Slot
@@ -186,6 +190,7 @@ import Control.DeepSeq
     )
 import Control.Exception
     ( evaluate
+    , onException
     , throw
     )
 import Control.Monad
@@ -195,6 +200,10 @@ import Control.Monad
 import Control.Monad.IO.Class
     ( MonadIO (..)
     )
+import Control.Monad.Trans.Except
+    ( ExceptT (..)
+    , runExceptT
+    )
 import Control.Tracer
     ( Tracer
     , contramap
@@ -215,7 +224,7 @@ import Data.Generics.Internal.VL.Lens
 import Data.Maybe
     ( catMaybes
     , fromMaybe
-    , isJust
+    , isNothing
     )
 import Data.Store
     ( Store (..)
@@ -259,6 +268,7 @@ import UnliftIO.Exception
     ( Exception
     , bracket
     , throwIO
+    , tryJust
     )
 import UnliftIO.MVar
     ( modifyMVar
@@ -481,6 +491,40 @@ readWalletId = do
                 Right w -> Just w
         _ -> Nothing
 
+{-------------------------------------------------------------------------------
+    DB migration and creation
+-------------------------------------------------------------------------------}
+-- | Run migrations on a database file.
+-- This will modify the file and may create backup files.
+migrateDBFile
+    :: Tracer IO DBLog
+        -- ^ Tracer for logging
+    -> WalletFlavorS s
+        -- ^ Flavor of the wallet contained in the database file.
+    -> Maybe DefaultFieldValues
+        -- ^ Default database field values, used during old migration.
+    -> FilePath
+        -- ^ Path of the @.sqlite@ file to migrate.
+    -> IO (Either MigrationError ())
+migrateDBFile tr walletF defaultFieldValues fp = runExceptT $ do
+    ExceptT $ withDBHandle tr fp $ runManualOldMigrations tr oldMigrations
+    ExceptT
+        $ tryJust matchWrongVersionError
+        $ runNewStyleMigrations tr fp
+  where
+    trMigrations = contramap MsgMigrationOld tr
+    oldMigrations =
+        maybe
+            noManualMigration
+            (migrateManually trMigrations $ keyOfWallet walletF)
+            defaultFieldValues
+
+noAutoMigrations :: Sqlite.Migration
+noAutoMigrations = pure ()
+
+throwMigrationError :: Either MigrationError a -> IO a
+throwMigrationError = either throwIO pure
+
 {-------------------------------------------------------------------------------
     DBLayer
 -------------------------------------------------------------------------------}
@@ -506,29 +550,19 @@ withLoadDBLayerFromFile
     -> (DBLayer IO s -> IO a)
        -- ^ Action to run.
     -> IO a
-withLoadDBLayerFromFile wF tr ti wid defaultFieldValues dbFile action =
-  do
+withLoadDBLayerFromFile wF tr ti wid defaultFieldValues dbFile action = do
     let trDB = contramap MsgDB tr
-        trManualMigrations = contramap MsgMigrationOld trDB
-    let manualMigrations =
-            maybe
-                createSchemaVersionTableIfMissing'
-                (migrateManually trManualMigrations $ keyOfWallet wF)
-                defaultFieldValues
-    let autoMigrations = migrateAll
-    res <-
-        withSqliteContextFile
-            trDB
-            dbFile
-            manualMigrations
-            autoMigrations
-            runNewStyleMigrations
-            $ \ctx -> do
-                e <- loadDBLayerFromSqliteContext wF ti wid ctx
-                case e of
-                    Left err -> throw err
-                    Right dblayer -> action dblayer
-    either throwIO pure res
+    migrateDBFile trDB wF defaultFieldValues dbFile
+        >>= throwMigrationError
+    res <- withSqliteContextFile
+        trDB
+        dbFile
+        noManualMigration
+        noAutoMigrations
+        $ \ctx -> do
+            dblayer <- loadDBLayerFromSqliteContext wF ti wid ctx
+            action dblayer
+    throwMigrationError res
 
 -- | Create a 'DBLayer' in a file.
 --
@@ -558,20 +592,15 @@ withBootDBLayerFromFile
 withBootDBLayerFromFile wF tr ti wid _defaultFieldValues params dbFile action =
   do
     let trDB = contramap MsgDB tr
-        noNewStyleMigrations _ _ = pure ()
-    res <-
-        withSqliteContextFile
-            trDB
-            dbFile
-            createSchemaVersionTableIfMissing'
-            migrateAll
-            noNewStyleMigrations
-            $ \ctx -> do
-                e <- bootDBLayerFromSqliteContext wF ti wid params ctx
-                case e of
-                    Left err -> throw err
-                    Right dblayer -> action dblayer
-    either throwIO pure res
+    res <- withSqliteContextFile
+        trDB
+        dbFile
+        createSchemaVersionTableIfMissing'
+        migrateAll
+        $ \ctx -> do
+            dblayer <- bootDBLayerFromSqliteContext wF ti wid params ctx
+            action dblayer
+    throwMigrationError res
 
 -- | Create a 'DBLayer' in memory.
 --
@@ -600,13 +629,9 @@ newBootDBLayerInMemory wF tr ti wid params = do
             migrateAll
             ForeignKeysEnabled
 
-    e <- bootDBLayerFromSqliteContext wF ti wid params ctx
-    case e of
-        Left err -> do
-            destroy
-            throw err
-        Right dblayer ->
-            pure (destroy, dblayer)
+    db <- bootDBLayerFromSqliteContext wF ti wid params ctx
+        `onException` destroy
+    pure (destroy, db)
 
 -- | Create a 'DBLayer' in memory.
 --
@@ -640,7 +665,7 @@ bootDBLayerFromSqliteContext
     -> W.WalletId
     -> DBLayerParams s
     -> SqliteContext
-    -> IO (Either ErrWalletAlreadyInitialized (DBLayer IO s))
+    -> IO (DBLayer IO s)
 bootDBLayerFromSqliteContext wF ti wid params SqliteContext{runQuery} = do
     let cp = dBLayerParamsState params
     case fromGenesis cp
@@ -653,16 +678,14 @@ bootDBLayerFromSqliteContext wF ti wid params SqliteContext{runQuery} = do
                 $ ErrNotGenesisBlockHeader
                 $ cp ^. #currentTip
         Just wallet -> do
-            present <- atomically_ hasWalletId
-            if present
-                then pure $ Left ErrWalletAlreadyInitialized
-                else do
-                    r@DBLayer{transactionsStore, atomically}
-                        <- atomically_ $ mkDBLayer <$> initDBVar store wallet
-                    atomically $ updateS transactionsStore Nothing
-                        $ ExpandTxWalletsHistory wid
-                        $ dBLayerParamsHistory params
-                    pure $ Right r
+            atomically_ $ guardWalletDoesNotExist wid
+            dblayer@DBLayer{transactionsStore, atomically}
+                <- atomically_ $ mkDBLayer <$> initDBVar store wallet
+            atomically
+                $ updateS transactionsStore Nothing
+                $ ExpandTxWalletsHistory wid
+                $ dBLayerParamsHistory params
+            pure dblayer
   where
     store = mkStoreWallet wF wid
 
@@ -681,15 +704,12 @@ loadDBLayerFromSqliteContext
     -> TimeInterpreter IO
     -> W.WalletId
     -> SqliteContext
-    -> IO (Either ErrWalletNotInitialized (DBLayer IO s))
+    -> IO (DBLayer IO s)
 loadDBLayerFromSqliteContext wF ti wid SqliteContext{runQuery} =
     atomically_ $ do
-        present <- hasWalletId
-        if present
-            then do
-                walletState <- loadDBVar store
-                pure $ Right $ mkDBLayer walletState
-            else pure $ Left ErrWalletNotInitialized
+        guardWalletExists wid
+        walletState <- loadDBVar store
+        pure $ mkDBLayer walletState
   where
     store = mkStoreWallet wF wid
 
@@ -700,8 +720,15 @@ loadDBLayerFromSqliteContext wF ti wid SqliteContext{runQuery} =
         mkDBLayerFromParts ti wid
         $ mkDBLayerCollection ti wid atomically_ walletState
 
-hasWalletId :: SqlPersistT IO Bool
-hasWalletId = isJust <$> readWalletId
+guardWalletExists :: W.WalletId -> SqlPersistT IO ()
+guardWalletExists wid = do
+    mwid <- readWalletId
+    unless (mwid == Just wid) $ liftIO $ throwIO ErrWalletNotInitialized
+
+guardWalletDoesNotExist :: W.WalletId -> SqlPersistT IO ()
+guardWalletDoesNotExist _wid = do
+    mwid <- readWalletId
+    unless (isNothing mwid) $ liftIO $ throwIO ErrWalletAlreadyInitialized
 
 {-------------------------------------------------------------------------------
     DBLayerCollection
@@ -842,7 +869,6 @@ withTestLoadDBLayerFromFile tr ti dbFile action = do
             dbFile
             noManualMigration
             noMigration
-            noNewStyleMigrations
             (`runQuery` readWalletId)
     case mwid of
         Nothing -> fail "No wallet id found in database"
@@ -857,7 +883,6 @@ withTestLoadDBLayerFromFile tr ti dbFile action = do
                 action
   where
     noMigration = pure ()
-    noNewStyleMigrations _ _ = pure ()
 
 -- | Default field values used when testing,
 -- in the context of 'withLoadDBLayerFromFile'.