Test that uncommitted forkers do not leak handles

Author: jasagredo

ouroboros-consensus/ouroboros-consensus.cabal

@@ -745,6 +745,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

@@ -75,6 +75,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
@@ -325,6 +326,7 @@ instance StateModel Model where
       Action Model (ExtLedgerState TestBlock EmptyMK, ExtLedgerState TestBlock EmptyMK)
     Init :: SecurityParam -> LSM.Salt -> Action Model ()
     ValidateAndCommit :: Word64 -> [TestBlock] -> Action Model ()
+    OpenAndCloseForker :: Action Model ()
 
   actionName WipeLedgerDB{} = "WipeLedgerDB"
   actionName TruncateSnapshots{} = "TruncateSnapshots"
@@ -333,6 +335,7 @@ instance StateModel Model where
   actionName GetState{} = "GetState"
   actionName Init{} = "Init"
   actionName ValidateAndCommit{} = "ValidateAndCommit"
+  actionName OpenAndCloseForker = "OpenAndCloseForker"
 
   arbitraryAction _ UnInit = Some <$> (Init <$> QC.arbitrary <*> QC.arbitrary)
   arbitraryAction _ model@(Model chain secParam) =
@@ -361,6 +364,7 @@ instance StateModel Model where
         )
       , (1, pure $ Some WipeLedgerDB)
       , (1, pure $ Some TruncateSnapshots)
+      , (1, pure $ Some OpenAndCloseForker)
       ]
 
   initialState = UnInit
@@ -402,6 +406,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
@@ -635,6 +640,12 @@ instance RunModel Model (StateT Environment IO) where
       atomically $ modifyTVar (dbChain chainDb) (drop (fromIntegral n))
       closeLedgerDB testInternals
     perform state (Init secParam salt) lk
+  perform _ OpenAndCloseForker _ = do
+    Environment ldb _ _ _ _ _ _ rr <- get
+    eFrk <- lift $ LedgerDB.getForkerAtTarget ldb rr VolatileTip
+    case eFrk of
+      Left err -> error $ "Impossible: can't acquire forker at tip: " <> show err
+      Right frk -> lift $ forkerClose frk
   perform _ TruncateSnapshots _ = do
     Environment _ testInternals _ _ _ _ _ _ <- get
     lift $ truncateSnapshots testInternals