diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs index ea0f6656e91..ce24ec7c7c7 100644 --- a/lib/core/src/Cardano/Wallet/Api/Server.hs +++ b/lib/core/src/Cardano/Wallet/Api/Server.hs @@ -481,9 +481,9 @@ deleteWallet -> ApiT WalletId -> Handler NoContent deleteWallet ctx (ApiT wid) = do - liftHandler $ withWorkerCtx ctx wid throwE $ \wrk -> W.deleteWallet wrk wid - liftIO $ Registry.remove re wid + liftHandler $ withWorkerCtx @_ @s @k ctx wid throwE $ \_ -> pure () liftIO $ (df ^. #removeDatabase) wid + liftIO $ Registry.remove re wid return NoContent where re = ctx ^. workerRegistry @s @k diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs index b4f473d5964..6fc72584a8c 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs @@ -23,7 +23,7 @@ module Cardano.Wallet.DB.Sqlite ( newDBLayer - , mkDBFactory + , newDBFactory , findDatabases , withDBLayer @@ -91,6 +91,8 @@ import Cardano.Wallet.Primitive.AddressDiscovery ( IsOurs (..) ) import Control.Arrow ( (***) ) +import Control.Concurrent.MVar + ( newEmptyMVar, putMVar, readMVar ) import Control.DeepSeq ( NFData ) import Control.Exception @@ -190,17 +192,17 @@ withDBLayer -- ^ Logging object -> Maybe FilePath -- ^ Path to database directory, or Nothing for in-memory database - -> (DBLayer IO s k -> IO a) + -> ((SqliteContext, DBLayer IO s k) -> IO a) -- ^ Action to run. -> IO a -withDBLayer logConfig trace mDatabaseDir action = - bracket before after (action . snd) +withDBLayer logConfig trace mDatabaseDir = + bracket before after where before = newDBLayer logConfig trace mDatabaseDir after = destroyDBLayer . fst -- | Instantiate a 'DBFactory' from a given directory -mkDBFactory +newDBFactory :: forall s k. ( IsOurs s W.Address , IsOurs s W.ChimericAccount @@ -216,33 +218,38 @@ mkDBFactory -- ^ Logging object -> Maybe FilePath -- ^ Path to database directory, or Nothing for in-memory database - -> DBFactory IO s k -mkDBFactory cfg tr mDatabaseDir = case mDatabaseDir of - Nothing -> DBFactory - { withDatabase = \_ -> - withDBLayer cfg tracerDB Nothing - , removeDatabase = \_ -> - pure () - } - Just databaseDir -> DBFactory - { withDatabase = \wid -> - withDBLayer cfg tracerDB (Just $ databaseFile wid) - , removeDatabase = \wid -> do - let files = - [ databaseFile wid - , databaseFile wid <> "-wal" - , databaseFile wid <> "-shm" - ] - mapM_ removePathForcibly files - } + -> IO (DBFactory IO s k) +newDBFactory cfg tr mDatabaseDir = do + mvar <- newEmptyMVar + case mDatabaseDir of + Nothing -> pure DBFactory + { withDatabase = \_ action -> + withDBLayer cfg tracerDB Nothing (action . snd) + , removeDatabase = \_ -> + pure () + } + Just databaseDir -> pure DBFactory + { withDatabase = \wid action -> + withDBLayer cfg tracerDB (Just $ databaseFile wid) $ \(ctx,db) -> do + putMVar mvar ctx + action db + , removeDatabase = \wid -> do + let files = + [ databaseFile wid + , databaseFile wid <> "-wal" + , databaseFile wid <> "-shm" + ] + readMVar mvar >>= destroyDBLayer + mapM_ removePathForcibly files + } + where + databaseFilePrefix = keyTypeDescriptor $ Proxy @k + databaseFile wid = + databaseDir + databaseFilePrefix <> "." <> + T.unpack (toText wid) <> ".sqlite" where - databaseFilePrefix = keyTypeDescriptor $ Proxy @k - databaseFile wid = - databaseDir - databaseFilePrefix <> "." <> - T.unpack (toText wid) <> ".sqlite" - where - tracerDB = appendName "database" tr + tracerDB = appendName "database" tr -- | Return all wallet databases that match the specified key type within the -- specified directory. diff --git a/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs b/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs index e078daa8278..9d861d071b5 100644 --- a/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs @@ -511,7 +511,7 @@ withTestDBFile action expectations = do withSystemTempFile "spec.db" $ \fp handle -> do hClose handle removeFile fp - withDBLayer logConfig trace (Just fp) action + withDBLayer logConfig trace (Just fp) (action . snd) expectations fp inMemoryDBLayer diff --git a/lib/jormungandr/src/Cardano/Wallet/Jormungandr.hs b/lib/jormungandr/src/Cardano/Wallet/Jormungandr.hs index c9ee5da80ff..1d7cd030612 100644 --- a/lib/jormungandr/src/Cardano/Wallet/Jormungandr.hs +++ b/lib/jormungandr/src/Cardano/Wallet/Jormungandr.hs @@ -51,8 +51,6 @@ import Cardano.Wallet.Api.Types ( DecodeAddress, EncodeAddress ) import Cardano.Wallet.DaedalusIPC ( daedalusIPC ) -import Cardano.Wallet.DB - ( DBFactory ) import Cardano.Wallet.DB.Sqlite ( PersistState ) import Cardano.Wallet.Jormungandr.Compatibility @@ -236,8 +234,9 @@ serveWallet apiLayer tracer tl nl = do let (block0, bp) = staticBlockchainParameters nl wallets <- maybe (pure []) (Sqlite.findDatabases @k trText) databaseDir + db <- Sqlite.newDBFactory cfg trText databaseDir Server.newApiLayer - tracer (toWLBlock block0, bp, sTolerance) nl' tl dbFactory wallets + tracer (toWLBlock block0, bp, sTolerance) nl' tl db wallets where nl' = toWLBlock <$> nl @@ -256,19 +255,6 @@ serveWallet onExit = defaultWorkerAfter tr' trStakePool = contramap (fmap LogStakePoolLayerMsg) trRoot - dbFactory - :: forall s k. - ( IsOurs s Address - , IsOurs s ChimericAccount - , NFData s - , Show s - , PersistState s - , PersistPrivateKey (k 'RootK) - , WalletKey k - ) - => DBFactory IO s k - dbFactory = Sqlite.mkDBFactory cfg trText databaseDir - handleNetworkStartupError :: ErrStartup -> IO ExitCode handleNetworkStartupError = \case ErrStartupGetBlockchainParameters e -> case e of