Integrate new migrations into the db layer on disk operations.

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,

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
 

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.

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

@@ -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

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) [] []