Integrate new migrations into the db layer on disk operations.

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

@@ -28,7 +28,7 @@
 
 module Cardano.DB.Sqlite
     ( SqliteContext (..)
-    , newSqliteContext
+    , newSqliteContextFile
     , newInMemorySqliteContext
     , ForeignKeysSetting (..)
 
@@ -83,7 +83,7 @@ import Data.Aeson
 import Data.Function
     ( (&) )
 import Data.Functor
-    ( (<&>) )
+    ( ($>), (<&>) )
 import Data.List
     ( isInfixOf )
 import Data.List.Split
@@ -119,9 +119,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
@@ -135,6 +135,14 @@ import UnliftIO.Exception
 import UnliftIO.MVar
     ( newMVar, withMVarMasked )
 
+import Cardano.Wallet.DB.Migration
+    ( ErrWrongVersion (..) )
+import Control.Lens
+    ( strict, view )
+import Control.Monad.Trans.Except
+import Data.Text.Lazy.Builder
+    ( toLazyText )
+
 import qualified Data.Aeson as Aeson
 import qualified Data.ByteString.Char8 as B8
 import qualified Data.Text as T
@@ -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,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 --------------------------------------------------------------
 --------------------------------------------------------------------------------

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

@@ -1,47 +1,88 @@
-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
             let backupFile = fp <> ".v" <> show v <> ".bak"
             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