From bcec1b9173d0e5931181965c7752d3218cb777c9 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Wed, 19 Aug 2020 04:58:00 +0000 Subject: [PATCH] Provide database-schema-specific logging types. In response to review feedback: https://github.com/input-output-hk/cardano-wallet/pull/2038#discussion_r471935694 --- lib/core/src/Cardano/DB/Sqlite.hs | 51 +++++++++++------ lib/core/src/Cardano/Pool/DB/Sqlite.hs | 55 ++++++++++++++++-- lib/core/src/Cardano/Wallet/DB/Sqlite.hs | 57 ++++++++++++++++--- lib/core/test/bench/db/Main.hs | 18 +++--- .../test/unit/Cardano/Pool/DB/Properties.hs | 5 +- .../test/unit/Cardano/Pool/DB/SqliteSpec.hs | 10 +++- .../test/unit/Cardano/Wallet/DB/SqliteSpec.hs | 21 +++---- .../src/Cardano/Wallet/Jormungandr.hs | 8 ++- lib/shelley/src/Cardano/Wallet/Shelley.hs | 8 ++- 9 files changed, 173 insertions(+), 60 deletions(-) diff --git a/lib/core/src/Cardano/DB/Sqlite.hs b/lib/core/src/Cardano/DB/Sqlite.hs index e2074d63516..8af6fdd51ef 100644 --- a/lib/core/src/Cardano/DB/Sqlite.hs +++ b/lib/core/src/Cardano/DB/Sqlite.hs @@ -9,6 +9,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -23,7 +24,8 @@ -- An implementation of the DBLayer which uses Persistent and SQLite. module Cardano.DB.Sqlite - ( SqliteContext (..) + ( Schema (..) + , SqliteContext (..) , chunkSize , dbChunked , destroyDBLayer @@ -120,15 +122,19 @@ import qualified Database.Sqlite as Sqlite Sqlite connection set up -------------------------------------------------------------------------------} +-- | Provides types that are specific to a particular database schema. +class Schema schema where + type SchemaSpecificLog schema + -- | Context for the SQLite 'DBLayer'. -data SqliteContext = SqliteContext +data SqliteContext schema = SqliteContext { getSqlBackend :: SqlBackend -- ^ A handle to the Persistent SQL backend. , runQuery :: forall a. SqlPersistT IO a -> IO a -- ^ 'safely' run a query with logging and lock-protection , dbFile :: Maybe FilePath -- ^ The actual database file, if any. If none, runs in-memory - , trace :: Tracer IO DBLog + , trace :: Tracer IO (DBLog schema) -- ^ A 'Tracer' for logging } @@ -142,10 +148,10 @@ instance Exception MigrationError -- | Run a raw query from the outside using an instantiate DB layer. This is -- completely unsafe because it breaks the abstraction boundary and can have -- disastrous results on the database consistency. -unsafeRunQuery :: SqliteContext -> SqlPersistT IO a -> IO a +unsafeRunQuery :: SqliteContext schema -> SqlPersistT IO a -> IO a unsafeRunQuery = runQuery -queryLogFunc :: Tracer IO DBLog -> LogFunc +queryLogFunc :: Tracer IO (DBLog schema) -> LogFunc queryLogFunc tr _loc _source level str = traceWith tr (MsgQuery msg sev) where -- Filter out parameters which appear after the statement semicolon. @@ -176,7 +182,7 @@ handleConstraint e = handleJust select handler . fmap Right -- This function is idempotent: if the database connection has already been -- closed, calling this function will exit without doing anything. -- -destroyDBLayer :: SqliteContext -> IO () +destroyDBLayer :: SqliteContext schema -> IO () destroyDBLayer (SqliteContext {getSqlBackend, trace, dbFile}) = do traceWith trace (MsgClosing dbFile) recovering pol [const $ Handler isBusy] (const $ close' getSqlBackend) @@ -212,9 +218,9 @@ destroyDBLayer (SqliteContext {getSqlBackend, trace, dbFile}) = do startSqliteBackend :: ManualMigration -> Migration - -> Tracer IO DBLog + -> Tracer IO (DBLog schema) -> Maybe FilePath - -> IO (Either MigrationError SqliteContext) + -> IO (Either MigrationError (SqliteContext schema)) startSqliteBackend manualMigration autoMigration tr fp = do (unsafeBackend, connection) <- createSqliteBackend tr fp manualMigration (queryLogFunc tr) @@ -242,7 +248,7 @@ startSqliteBackend manualMigration autoMigration tr fp = do -- /temporarily disabled/, before re-enabling them. -- withForeignKeysDisabled - :: Tracer IO DBLog + :: Tracer IO (DBLog schema) -> Sqlite.Connection -> IO a -> IO a @@ -290,7 +296,7 @@ readForeignKeysSetting connection = do -- | Update the current value of the Sqlite 'foreign_keys' setting. -- updateForeignKeysSetting - :: Tracer IO DBLog + :: Tracer IO (DBLog schema) -> Sqlite.Connection -> ForeignKeysSetting -> IO () @@ -339,7 +345,7 @@ newtype ManualMigration = ManualMigration { executeManualMigration :: Sqlite.Connection -> IO () } createSqliteBackend - :: Tracer IO DBLog + :: Tracer IO (DBLog schema) -> Maybe FilePath -> ManualMigration -> LogFunc @@ -359,8 +365,9 @@ sqliteConnStr = maybe ":memory:" T.pack Logging -------------------------------------------------------------------------------} -data DBLog - = MsgMigrations (Either MigrationError Int) +data DBLog schema + = MsgSchemaSpecificLogEntry (SchemaSpecificLog schema) + | MsgMigrations (Either MigrationError Int) | MsgQuery Text Severity | MsgRun BracketLog | MsgConnStr Text @@ -379,8 +386,11 @@ data DBLog | MsgUpdatingForeignKeysSetting ForeignKeysSetting | MsgFoundDatabase FilePath Text | MsgUnknownDBFile FilePath - deriving (Generic, Show, Eq, ToJSON) + deriving Generic +deriving instance Eq (SchemaSpecificLog schema) => Eq (DBLog schema) +deriving instance Show (SchemaSpecificLog schema) => Show (DBLog schema) +deriving instance ToJSON (SchemaSpecificLog schema) => ToJSON (DBLog schema) {------------------------------------------------------------------------------- Logging @@ -432,9 +442,13 @@ instance Eq DBField where instance ToJSON DBField where toJSON = Aeson.String . fieldName -instance HasPrivacyAnnotation DBLog -instance HasSeverityAnnotation DBLog where +instance HasPrivacyAnnotation (DBLog schema) + +instance HasSeverityAnnotation (SchemaSpecificLog schema) + => HasSeverityAnnotation (DBLog schema) + where getSeverityAnnotation ev = case ev of + MsgSchemaSpecificLogEntry e -> getSeverityAnnotation e MsgMigrations (Right 0) -> Debug MsgMigrations (Right _) -> Notice MsgMigrations (Left _) -> Error @@ -457,8 +471,11 @@ instance HasSeverityAnnotation DBLog where MsgFoundDatabase _ _ -> Info MsgUnknownDBFile _ -> Notice -instance ToText DBLog where +instance ToText (SchemaSpecificLog schema) + => ToText (DBLog schema) + where toText = \case + MsgSchemaSpecificLogEntry e -> toText e MsgMigrations (Right 0) -> "No database migrations were necessary." MsgMigrations (Right n) -> diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs index 5f533a70494..1c3ea5b5d4d 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -1,6 +1,9 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE EmptyDataDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -27,15 +30,22 @@ module Cardano.Pool.DB.Sqlite , withDBLayer , defaultFilePath , DatabaseView (..) + + -- * Schema-specific types + , PoolDb + , PoolDbLog ) where import Prelude +import Cardano.BM.Data.Tracer + ( HasSeverityAnnotation (..) ) import Cardano.DB.Sqlite ( DBField (..) , DBLog (..) , ManualMigration (..) , MigrationError (..) + , Schema (..) , SqliteContext (..) , destroyDBLayer , fieldName @@ -61,6 +71,8 @@ import Cardano.Wallet.Primitive.Types ) import Cardano.Wallet.Unsafe ( unsafeMkPercentage ) +import Control.DeepSeq + ( NFData ) import Control.Exception ( bracket, throwIO ) import Control.Monad @@ -88,7 +100,7 @@ import Data.String.QQ import Data.Text ( Text ) import Data.Text.Class - ( toText ) + ( ToText (..), toText ) import Data.Time.Clock ( UTCTime, addUTCTime, getCurrentTime ) import Data.Word @@ -113,6 +125,8 @@ import Database.Persist.Sql ) import Database.Persist.Sqlite ( SqlPersistT ) +import GHC.Generics + ( Generic ) import System.Directory ( removeFile ) import System.FilePath @@ -127,6 +141,22 @@ import qualified Data.Text as T import qualified Data.Text.Class as T import qualified Database.Sqlite as Sqlite +{------------------------------------------------------------------------------- + DB Schema +-------------------------------------------------------------------------------} + +data PoolDb + deriving (Eq, Generic, Show) + +instance NFData PoolDb + +instance Schema PoolDb where + type SchemaSpecificLog PoolDb = PoolDbLog + +{------------------------------------------------------------------------------- + DB Construction +-------------------------------------------------------------------------------} + -- | Return the preferred @FilePath@ for the stake pool .sqlite file, given a -- parent directory. defaultFilePath @@ -142,7 +172,7 @@ defaultFilePath = ( "stake-pools.sqlite") -- If the given file path does not exist, it will be created by the sqlite -- library. withDBLayer - :: Tracer IO DBLog + :: Tracer IO (DBLog PoolDb) -- ^ Logging object -> Maybe FilePath -- ^ Database file location, or Nothing for in-memory database @@ -168,12 +198,12 @@ withDBLayer trace fp timeInterpreter action = do -- should be closed with 'destroyDBLayer'. If you use 'withDBLayer' then both of -- these things will be handled for you. newDBLayer - :: Tracer IO DBLog + :: Tracer IO (DBLog PoolDb) -- ^ Logging object -> Maybe FilePath -- ^ Database file location, or Nothing for in-memory database -> TimeInterpreter IO - -> IO (SqliteContext, DBLayer IO) + -> IO (SqliteContext PoolDb, DBLayer IO) newDBLayer trace fp timeInterpreter = do let io = startSqliteBackend (migrateManually trace) @@ -482,7 +512,7 @@ newDBLayer trace fp timeInterpreter = do pure (cpt, cert) migrateManually - :: Tracer IO DBLog + :: Tracer IO (DBLog PoolDb) -> ManualMigration migrateManually _tr = ManualMigration $ \conn -> @@ -558,7 +588,7 @@ activePoolRetirements = DatabaseView "active_pool_retirements" [s| -- with ugly work-around we can, at least for now, reset it semi-manually when -- needed to keep things tidy here. handlingPersistError - :: Tracer IO DBLog + :: Tracer IO (DBLog PoolDb) -- ^ Logging object -> Maybe FilePath -- ^ Database file location, or Nothing for in-memory database @@ -669,3 +699,16 @@ fromPoolMeta meta = (poolMetadataHash meta,) $ , description = poolMetadataDescription meta , homepage = poolMetadataHomepage meta } + +{------------------------------------------------------------------------------- + DB Logging +-------------------------------------------------------------------------------} + +data PoolDbLog + deriving (Eq, Show) + +instance HasSeverityAnnotation PoolDbLog where + getSeverityAnnotation = \case {} + +instance ToText PoolDbLog where + toText = \case {} diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs index e5236a1a8c2..b4490cc6af9 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs @@ -1,6 +1,9 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE EmptyDataDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -32,16 +35,23 @@ module Cardano.Wallet.DB.Sqlite -- * Migration Support , DefaultFieldValues (..) + + -- * Schema-specific types + , WalletDb + , WalletDbLog ) where import Prelude import Cardano.Address.Derivation ( XPrv, XPub ) +import Cardano.BM.Data.Tracer + ( HasSeverityAnnotation (..) ) import Cardano.DB.Sqlite ( DBField (..) , DBLog (..) , ManualMigration (..) + , Schema (..) , SqliteContext (..) , chunkSize , dbChunked @@ -105,6 +115,8 @@ import Cardano.Wallet.Primitive.Slotting ( TimeInterpreter, epochOf, firstSlotInEpoch, startTime ) import Control.Concurrent.MVar ( modifyMVar, modifyMVar_, newMVar, readMVar ) +import Control.DeepSeq + ( NFData ) import Control.Exception ( Exception, bracket, throwIO ) import Control.Monad @@ -180,6 +192,8 @@ import Database.Persist.Types ( PersistValue (PersistText), fromPersistValueText ) import Fmt ( pretty ) +import GHC.Generics + ( Generic ) import Numeric.Natural ( Natural ) import System.Directory @@ -196,6 +210,22 @@ import qualified Data.Map as Map import qualified Data.Text as T import qualified Database.Sqlite as Sqlite +{------------------------------------------------------------------------------- + DB Schema +-------------------------------------------------------------------------------} + +data WalletDb + deriving (Eq, Generic, Show) + +instance NFData WalletDb + +instance Schema WalletDb where + type SchemaSpecificLog WalletDb = WalletDbLog + +{------------------------------------------------------------------------------- + DB Construction +-------------------------------------------------------------------------------} + -- | Runs an action with a connection to the SQLite database. -- -- Database migrations are run to create tables if necessary. @@ -207,14 +237,14 @@ withDBLayer ( PersistState s , PersistPrivateKey (k 'RootK) ) - => Tracer IO DBLog + => Tracer IO (DBLog WalletDb) -- ^ Logging object -> DefaultFieldValues -- ^ Default database field values, used during migration. -> Maybe FilePath -- ^ Path to database directory, or Nothing for in-memory database -> TimeInterpreter IO - -> ((SqliteContext, DBLayer IO s k) -> IO a) + -> ((SqliteContext WalletDb, DBLayer IO s k) -> IO a) -- ^ Action to run. -> IO a withDBLayer trace defaultFieldValues mDatabaseDir timeInterpreter = @@ -230,7 +260,7 @@ newDBFactory , PersistPrivateKey (k 'RootK) , WalletKey k ) - => Tracer IO DBLog + => Tracer IO (DBLog WalletDb) -- ^ Logging object -> DefaultFieldValues -- ^ Default database field values, used during migration. @@ -299,7 +329,7 @@ newDBFactory tr defaultFieldValues timeInterpreter = \case -- specified directory. findDatabases :: forall k. WalletKey k - => Tracer IO DBLog + => Tracer IO (DBLog WalletDb) -> FilePath -> IO [W.WalletId] findDatabases tr dir = do @@ -330,7 +360,7 @@ data SqlColumnStatus -- startup. -- migrateManually - :: Tracer IO DBLog + :: Tracer IO (DBLog WalletDb) -> DefaultFieldValues -> ManualMigration migrateManually tr defaultFieldValues = @@ -546,14 +576,14 @@ newDBLayer ( PersistState s , PersistPrivateKey (k 'RootK) ) - => Tracer IO DBLog + => Tracer IO (DBLog WalletDb) -- ^ Logging object -> DefaultFieldValues -- ^ Default database field values, used during migration. -> Maybe FilePath -- ^ Path to database file, or Nothing for in-memory database -> TimeInterpreter IO - -> IO (SqliteContext, DBLayer IO s k) + -> IO (SqliteContext WalletDb, DBLayer IO s k) newDBLayer trace defaultFieldValues mDatabaseFile timeInterpreter = do ctx@SqliteContext{runQuery} <- either throwIO pure =<< @@ -1637,3 +1667,16 @@ selectRndStatePending wid = do where assocFromEntity (RndStatePendingAddress _ accIx addrIx addr) = ((W.Index accIx, W.Index addrIx), addr) + +{------------------------------------------------------------------------------- + DB Logging +-------------------------------------------------------------------------------} + +data WalletDbLog + deriving (Eq, Show) + +instance HasSeverityAnnotation WalletDbLog where + getSeverityAnnotation = \case {} + +instance ToText WalletDbLog where + toText = \case {} diff --git a/lib/core/test/bench/db/Main.hs b/lib/core/test/bench/db/Main.hs index 3fd688e01ee..88ca98a3ec3 100644 --- a/lib/core/test/bench/db/Main.hs +++ b/lib/core/test/bench/db/Main.hs @@ -61,7 +61,7 @@ import Cardano.Startup import Cardano.Wallet.DB ( DBLayer (..), PrimaryKey (..), cleanDB ) import Cardano.Wallet.DB.Sqlite - ( DefaultFieldValues (..), PersistState, newDBLayer ) + ( DefaultFieldValues (..), PersistState, WalletDb, newDBLayer ) import Cardano.Wallet.DummyTarget.Primitive.Types ( block0, dummyGenesisParameters, dummyProtocolParameters, mkTxId ) import Cardano.Wallet.Logging @@ -573,7 +573,7 @@ withDB ( PersistState s , PersistPrivateKey (k 'RootK) ) - => Tracer IO DBLog + => Tracer IO (DBLog WalletDb) -> (DBLayer IO s k -> Benchmark) -> Benchmark withDB tr bm = envWithCleanup (setupDB tr) cleanupDB (\ ~(_, _, db) -> bm db) @@ -583,8 +583,8 @@ setupDB ( PersistState s , PersistPrivateKey (k 'RootK) ) - => Tracer IO DBLog - -> IO (FilePath, SqliteContext, DBLayer IO s k) + => Tracer IO (DBLog WalletDb) + -> IO (FilePath, SqliteContext WalletDb, DBLayer IO s k) setupDB tr = do f <- emptySystemTempFile "bench.db" (ctx, db) <- newDBLayer tr defaultFieldValues (Just f) ti @@ -608,7 +608,7 @@ defaultFieldValues = DefaultFieldValues -- NOTE value in the genesis when at the time this migration was needed. } -cleanupDB :: (FilePath, SqliteContext, DBLayer IO s k) -> IO () +cleanupDB :: (FilePath, SqliteContext schema, DBLayer IO s k) -> IO () cleanupDB (db, ctx, _) = do handle (\SqliteException{} -> pure ()) $ destroyDBLayer ctx mapM_ remove [db, db <> "-shm", db <> "-wal"] @@ -655,7 +655,7 @@ walletFixtureByron db@DBLayer{..} = do -- These are not proper criterion benchmarks but use the benchmark test data to -- measure size on disk of the database and its temporary files. -utxoDiskSpaceTests :: Tracer IO DBLog -> IO () +utxoDiskSpaceTests :: Tracer IO (DBLog WalletDb) -> IO () utxoDiskSpaceTests tr = do putStrLn "Database disk space usage tests for UTxO\n" sequence_ @@ -678,7 +678,7 @@ utxoDiskSpaceTests tr = do walletFixture db benchPutUTxO n s db -txHistoryDiskSpaceTests :: Tracer IO DBLog -> IO () +txHistoryDiskSpaceTests :: Tracer IO (DBLog WalletDb) -> IO () txHistoryDiskSpaceTests tr = do putStrLn "Database disk space usage tests for TxHistory\n" sequence_ @@ -698,7 +698,7 @@ txHistoryDiskSpaceTests tr = do walletFixture db benchPutTxHistory n i o [1..100] db -benchDiskSize :: Tracer IO DBLog -> (DBLayerBench -> IO ()) -> IO () +benchDiskSize :: Tracer IO (DBLog WalletDb) -> (DBLayerBench -> IO ()) -> IO () benchDiskSize tr action = bracket (setupDB tr) cleanupDB $ \(f, ctx, db) -> do action db mapM_ (printFileSize "") [f, f <> "-shm", f <> "-wal"] @@ -735,7 +735,7 @@ type WalletBenchByron = Wallet (RndState 'Mainnet) instance NFData (DBLayer m s k) where rnf _ = () -instance NFData SqliteContext where +instance NFData schema => NFData (SqliteContext schema) where rnf _ = () testCp :: WalletBench diff --git a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs index 92d6d85026b..2b4ed21ee90 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs @@ -35,7 +35,7 @@ import Cardano.Pool.DB.Arbitrary , serializeLists ) import Cardano.Pool.DB.Sqlite - ( newDBLayer ) + ( PoolDb, newDBLayer ) import Cardano.Wallet.DummyTarget.Primitive.Types ( dummyTimeInterpreter ) import Cardano.Wallet.Primitive.Slotting @@ -138,7 +138,8 @@ withDB create = beforeAll create . beforeWith newMemoryDBLayer :: IO (DBLayer IO) newMemoryDBLayer = snd . snd <$> newMemoryDBLayer' -newMemoryDBLayer' :: IO (TVar [DBLog], (SqliteContext, DBLayer IO)) +newMemoryDBLayer' + :: IO (TVar [DBLog PoolDb], (SqliteContext PoolDb, DBLayer IO)) newMemoryDBLayer' = do logVar <- newTVarIO [] (logVar, ) <$> newDBLayer (traceInTVarIO logVar) Nothing ti diff --git a/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs b/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs index e49c4d75637..6e09eff1b32 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs @@ -56,7 +56,7 @@ test_migrationFromv20191216 = withDBLayer tr (Just path) ti $ \_ -> pure () let databaseConnMsg = filter isMsgConnStr logs - let databaseResetMsg = filter (== MsgDatabaseReset) logs + let databaseResetMsg = filter isMsgDatabaseReset logs let migrationErrMsg = filter isMsgMigrationError logs length databaseConnMsg `shouldBe` 3 @@ -64,10 +64,14 @@ test_migrationFromv20191216 = length migrationErrMsg `shouldBe` 1 -isMsgConnStr :: DBLog -> Bool +isMsgConnStr :: DBLog schema -> Bool isMsgConnStr (MsgConnStr _) = True isMsgConnStr _ = False -isMsgMigrationError :: DBLog -> Bool +isMsgDatabaseReset :: DBLog schema -> Bool +isMsgDatabaseReset MsgDatabaseReset = True +isMsgDatabaseReset _ = False + +isMsgMigrationError :: DBLog schema -> Bool isMsgMigrationError (MsgMigrations (Left _)) = True isMsgMigrationError _ = False diff --git a/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs b/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs index 69377d53167..142291fd92a 100644 --- a/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs @@ -60,6 +60,7 @@ import Cardano.Wallet.DB.Properties import Cardano.Wallet.DB.Sqlite ( DefaultFieldValues (..) , PersistState + , WalletDb , newDBFactory , newDBLayer , withDBLayer @@ -312,7 +313,7 @@ testMigrationPassphraseScheme = do -- account public key), so it should still have NO scheme. (passphraseScheme <$> passphraseInfo d) `shouldBe` Nothing where - isMsgManualMigration :: DBLog -> Bool + isMsgManualMigration :: DBLog WalletDb -> Bool isMsgManualMigration = \case MsgManualMigrationNeeded field _ -> fieldName field == @@ -376,7 +377,7 @@ newMemoryDBLayer' :: ( PersistState s , PersistPrivateKey (k 'RootK) ) - => IO (TVar [DBLog], (SqliteContext, DBLayer IO s k)) + => IO (TVar [DBLog WalletDb], (SqliteContext WalletDb, DBLayer IO s k)) newMemoryDBLayer' = do logVar <- newTVarIO [] (logVar, ) <$> @@ -388,7 +389,7 @@ withLoggingDB :: ( PersistState s , PersistPrivateKey (k 'RootK) ) - => SpecWith (IO [DBLog], DBLayer IO s k) + => SpecWith (IO [DBLog WalletDb], DBLayer IO s k) -> Spec withLoggingDB = beforeAll newMemoryDBLayer' . beforeWith clean where @@ -397,18 +398,18 @@ withLoggingDB = beforeAll newMemoryDBLayer' . beforeWith clean TVar.atomically $ writeTVar logs [] pure (readTVarIO logs, db) -shouldHaveMsgQuery :: [DBLog] -> Text -> Expectation +shouldHaveMsgQuery :: [DBLog WalletDb] -> Text -> Expectation shouldHaveMsgQuery msgs str = unless (any match msgs) $ fail $ "Did not find DB query " ++ T.unpack str ++ " within " ++ show msgs where match = maybe False (str `T.isInfixOf`) . getMsgQuery -getMsgQuery :: DBLog -> Maybe Text +getMsgQuery :: DBLog WalletDb -> Maybe Text getMsgQuery (MsgQuery msg _) = Just msg getMsgQuery _ = Nothing -findObserveDiffs :: [DBLog] -> [DBLog] +findObserveDiffs :: [DBLog WalletDb] -> [DBLog WalletDb] findObserveDiffs = filter isObserveDiff where isObserveDiff (MsgRun _) = True @@ -731,7 +732,7 @@ withTestDBFile action expectations = do inMemoryDBLayer :: PersistState s - => IO (SqliteContext, DBLayer IO s JormungandrKey) + => IO (SqliteContext WalletDb, DBLayer IO s JormungandrKey) inMemoryDBLayer = newDBLayer' Nothing temporaryDBFile :: IO FilePath @@ -748,7 +749,7 @@ defaultFieldValues = DefaultFieldValues newDBLayer' :: PersistState s => Maybe FilePath - -> IO (SqliteContext, DBLayer IO s JormungandrKey) + -> IO (SqliteContext WalletDb, DBLayer IO s JormungandrKey) newDBLayer' fp = newDBLayer nullTracer defaultFieldValues fp ti where ti = dummyTimeInterpreter @@ -756,8 +757,8 @@ newDBLayer' fp = newDBLayer nullTracer defaultFieldValues fp ti -- | Clean the database cleanDB' :: Monad m - => (SqliteContext, DBLayer m s k) - -> m (SqliteContext, DBLayer m s k) + => (SqliteContext WalletDb, DBLayer m s k) + -> m (SqliteContext WalletDb, DBLayer m s k) cleanDB' (ctx, db) = cleanDB db $> (ctx, db) diff --git a/lib/jormungandr/src/Cardano/Wallet/Jormungandr.hs b/lib/jormungandr/src/Cardano/Wallet/Jormungandr.hs index 9969aabfb62..95834075ce7 100644 --- a/lib/jormungandr/src/Cardano/Wallet/Jormungandr.hs +++ b/lib/jormungandr/src/Cardano/Wallet/Jormungandr.hs @@ -61,6 +61,8 @@ import Cardano.DB.Sqlite ( DBLog ) import Cardano.Launcher ( ProcessHasExited (..) ) +import Cardano.Pool.DB.Sqlite + ( PoolDb ) import Cardano.Pool.Jormungandr.Metadata ( ApiStakePool ) import Cardano.Pool.Jormungandr.Metrics @@ -79,7 +81,7 @@ import Cardano.Wallet.Api.Server import Cardano.Wallet.Api.Types ( DecodeAddress, EncodeAddress, EncodeStakeAddress ) import Cardano.Wallet.DB.Sqlite - ( DefaultFieldValues (..), PersistState ) + ( DefaultFieldValues (..), PersistState, WalletDb ) import Cardano.Wallet.Jormungandr.Api.Server ( server ) import Cardano.Wallet.Jormungandr.Compatibility @@ -471,9 +473,9 @@ data Tracers' f = Tracers { applicationTracer :: f ApplicationLog , apiServerTracer :: f ApiLog , walletEngineTracer :: f (WorkerLog WalletId WalletLog) - , walletDbTracer :: f DBLog + , walletDbTracer :: f (DBLog WalletDb) , stakePoolEngineTracer :: f (WorkerLog Text StakePoolLog) - , stakePoolDbTracer :: f DBLog + , stakePoolDbTracer :: f (DBLog PoolDb) , networkTracer :: f NetworkLayerLog , ntpClientTracer :: f NtpTrace } diff --git a/lib/shelley/src/Cardano/Wallet/Shelley.hs b/lib/shelley/src/Cardano/Wallet/Shelley.hs index 99a4106a6e5..3cb69fe9fde 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley.hs @@ -55,6 +55,8 @@ import Cardano.BM.Trace ( Trace, appendName ) import Cardano.DB.Sqlite ( DBLog ) +import Cardano.Pool.DB.Sqlite + ( PoolDb ) import Cardano.Pool.Metadata ( defaultManagerSettings , fetchFromRemote @@ -76,7 +78,7 @@ import Cardano.Wallet.Api.Types , EncodeStakeAddress ) import Cardano.Wallet.DB.Sqlite - ( DefaultFieldValues (..), PersistState ) + ( DefaultFieldValues (..), PersistState, WalletDb ) import Cardano.Wallet.Logging ( trMessageText ) import Cardano.Wallet.Network @@ -462,9 +464,9 @@ data Tracers' f = Tracers { applicationTracer :: f ApplicationLog , apiServerTracer :: f ApiLog , walletEngineTracer :: f (WorkerLog WalletId WalletLog) - , walletDbTracer :: f DBLog + , walletDbTracer :: f (DBLog WalletDb) , poolsEngineTracer :: f (WorkerLog Text StakePoolLog) - , poolsDbTracer :: f DBLog + , poolsDbTracer :: f (DBLog PoolDb) , ntpClientTracer :: f NtpTrace , networkTracer :: f (NetworkLayerLog TPraosStandardCrypto) }