Test that uncommitted forkers do not leak handles

Author: jasagredo

ouroboros-consensus/ouroboros-consensus.cabal

@@ -742,6 +742,7 @@ test-suite storage-test
     ouroboros-consensus,
     ouroboros-network-api,
     ouroboros-network-mock,
+    ouroboros-network-protocols,
     pretty-show,
     quickcheck-dynamic,
     quickcheck-lockstep ^>=0.8,

ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs

@@ -72,6 +72,7 @@ import Ouroboros.Consensus.Util hiding (Some)
 import Ouroboros.Consensus.Util.Args
 import Ouroboros.Consensus.Util.IOLike
 import qualified Ouroboros.Network.AnchoredSeq as AS
+import Ouroboros.Network.Protocol.LocalStateQuery.Type
 import qualified System.Directory as Dir
 import System.FS.API
 import qualified System.FS.IO as FSIO
@@ -114,9 +115,11 @@ prop_sequential ::
   QC.Property
 prop_sequential maxSuccess mkTestArguments getLmdbDir fsOps as = QC.withMaxSuccess maxSuccess $
   QC.monadicIO $ do
-    ref <- lift $ initialEnvironment fsOps getLmdbDir mkTestArguments =<< initChainDB
-    (_, env@(Environment _ testInternals _ _ _ _ clean)) <- runPropertyStateT (runActions as) ref
+    reg <- lift $ unsafeNewRegistry
+    ref <- lift $ initialEnvironment fsOps getLmdbDir mkTestArguments reg =<< initChainDB
+    (_, env@(Environment _ testInternals _ _ _ _ clean _)) <- runPropertyStateT (runActions as) ref
     checkNoLeakedHandles env
+    lift $ closeRegistry reg
     QC.run $ closeLedgerDB testInternals >> clean
     QC.assert True
 
@@ -129,9 +132,10 @@ initialEnvironment ::
   IO (SomeHasFS IO, IO ()) ->
   IO (FilePath, IO ()) ->
   (SecurityParam -> FilePath -> TestArguments IO) ->
+  ResourceRegistry IO ->
   ChainDB IO ->
   IO Environment
-initialEnvironment fsOps getLmdbDir mkTestArguments cdb = do
+initialEnvironment fsOps getLmdbDir mkTestArguments reg cdb = do
   (sfs, cleanupFS) <- fsOps
   (lmdbDir, cleanupLMDB) <- getLmdbDir
   pure $
@@ -143,6 +147,7 @@ initialEnvironment fsOps getLmdbDir mkTestArguments cdb = do
       sfs
       (pure $ NumOpenHandles 0)
       (cleanupFS >> cleanupLMDB)
+      reg
 
 {-------------------------------------------------------------------------------
   Arguments
@@ -280,6 +285,9 @@ instance StateModel Model where
       Action Model (ExtLedgerState TestBlock EmptyMK, ExtLedgerState TestBlock EmptyMK)
     Init :: SecurityParam -> Action Model ()
     ValidateAndCommit :: Word64 -> [TestBlock] -> Action Model ()
+    -- | This action is used only to observe the side effects of closing an
+    -- uncommitted forker, to ensure all handles are properly deallocated.
+    OpenAndCloseForker :: Action Model ()
 
   actionName WipeLedgerDB{} = "WipeLedgerDB"
   actionName TruncateSnapshots{} = "TruncateSnapshots"
@@ -288,6 +296,7 @@ instance StateModel Model where
   actionName GetState{} = "GetState"
   actionName Init{} = "Init"
   actionName ValidateAndCommit{} = "ValidateAndCommit"
+  actionName OpenAndCloseForker = "OpenAndCloseForker"
 
   arbitraryAction _ UnInit = Some . Init <$> QC.arbitrary
   arbitraryAction _ model@(Model chain secParam) =
@@ -316,6 +325,7 @@ instance StateModel Model where
         )
       , (1, pure $ Some WipeLedgerDB)
       , (1, pure $ Some TruncateSnapshots)
+      , (1, pure $ Some OpenAndCloseForker)
       ]
 
   initialState = UnInit
@@ -357,6 +367,7 @@ instance StateModel Model where
   nextState state WipeLedgerDB _var = state
   nextState state TruncateSnapshots _var = state
   nextState state (DropAndRestore n) _var = modelRollback n state
+  nextState state OpenAndCloseForker _var = state
   nextState UnInit _ _ = error "Uninitialized model created a command different than Init"
 
   precondition UnInit Init{} = True
@@ -526,25 +537,26 @@ data Environment
       (SomeHasFS IO)
       (IO NumOpenHandles)
       (IO ())
+      (ResourceRegistry IO)
 
 instance RunModel Model (StateT Environment IO) where
   perform _ (Init secParam) _ = do
-    Environment _ _ chainDb mkArgs fs _ cleanup <- get
+    Environment _ _ chainDb mkArgs fs _ cleanup rr <- get
     (ldb, testInternals, getNumOpenHandles) <- lift $ do
       let args = mkArgs secParam
       openLedgerDB (argFlavorArgs args) chainDb (argLedgerDbCfg args) fs
-    put (Environment ldb testInternals chainDb mkArgs fs getNumOpenHandles cleanup)
+    put (Environment ldb testInternals chainDb mkArgs fs getNumOpenHandles cleanup rr)
   perform _ WipeLedgerDB _ = do
-    Environment _ testInternals _ _ _ _ _ <- get
+    Environment _ testInternals _ _ _ _ _ _ <- get
     lift $ wipeLedgerDB testInternals
   perform _ GetState _ = do
-    Environment ldb _ _ _ _ _ _ <- get
+    Environment ldb _ _ _ _ _ _ _ <- get
     lift $ atomically $ (,) <$> getImmutableTip ldb <*> getVolatileTip ldb
   perform _ ForceTakeSnapshot _ = do
-    Environment _ testInternals _ _ _ _ _ <- get
+    Environment _ testInternals _ _ _ _ _ _ <- get
     lift $ takeSnapshotNOW testInternals TakeAtImmutableTip Nothing
   perform _ (ValidateAndCommit n blks) _ = do
-    Environment ldb _ chainDb _ _ _ _ <- get
+    Environment ldb _ chainDb _ _ _ _ _ <- get
     lift $ do
       atomically $
         modifyTVar (dbBlocks chainDb) $
@@ -561,13 +573,20 @@ instance RunModel Model (StateT Environment IO) where
           ValidateExceededRollBack{} -> error "Unexpected Rollback"
           ValidateLedgerError (AnnLedgerError forker _ _) -> forkerClose forker >> error "Unexpected ledger error"
   perform state@(Model _ secParam) (DropAndRestore n) lk = do
-    Environment _ testInternals chainDb _ _ _ _ <- get
+    Environment _ testInternals chainDb _ _ _ _ _ <- get
     lift $ do
       atomically $ modifyTVar (dbChain chainDb) (drop (fromIntegral n))
       closeLedgerDB testInternals
     perform state (Init secParam) lk
+  perform _ OpenAndCloseForker _ = do
+    Environment ldb _ _ _ _ _ _ _ <- get
+    lift $ withRegistry $ \rr -> do
+      eFrk <- LedgerDB.getForkerAtTarget ldb rr VolatileTip
+      case eFrk of
+        Left err -> error $ "Impossible: can't acquire forker at tip: " <> show err
+        Right frk -> forkerClose frk
   perform _ TruncateSnapshots _ = do
-    Environment _ testInternals _ _ _ _ _ <- get
+    Environment _ testInternals _ _ _ _ _ _ <- get
     lift $ truncateSnapshots testInternals
   perform UnInit _ _ = error "Uninitialized model created a command different than Init"
 
@@ -622,7 +641,7 @@ mkTrackOpenHandles = do
 
 -- | Check that we didn't leak any 'LedgerTablesHandle's (with V2 only).
 checkNoLeakedHandles :: Environment -> QC.PropertyM IO ()
-checkNoLeakedHandles (Environment _ testInternals _ _ _ getNumOpenHandles _) = do
+checkNoLeakedHandles (Environment _ testInternals _ _ _ getNumOpenHandles _ _) = do
   expected <- liftIO $ NumOpenHandles <$> LedgerDB.getNumLedgerTablesHandles testInternals
   actual <- liftIO getNumOpenHandles
   QC.assertWith (actual == expected) $