make sure to close and destroy the database before removing files fro…

…m disk

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

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.

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

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