Merge #3985

3985: [ADP-3058] Integrate new migrations into the db layer on disk operations. r=paolino a=paolino

This is just a patch to #3977, where I just remembered that I needed to unstash the final commit.

ADP-3058


Co-authored-by: paolino <[email protected]>

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,

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
 

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.

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,14 +59,24 @@ 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.
 --
 -- This path contains migration steps between any two consecutive
 -- 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 --------------------------------------------------------------
 --------------------------------------------------------------------------------