Add traces

ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/Args.hs

@@ -188,6 +188,7 @@ fromChainDbArgs ChainDbArgs{..} = (
         , volDecodeBlock      = cdbDecodeBlock
         , volEncodeBlock      = cdbEncodeBlock
         , volAddHdrEnv        = cdbAddHdrEnv
+        , volTracer           = contramap TraceVolDBEvent cdbTracer
         , volIsEBB            = \blk -> case cdbIsEBB (getHeader blk) of
                                           Nothing -> IsNotEBB
                                           Just _  -> IsEBB

ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/Types.hs

@@ -86,6 +86,7 @@ import qualified Ouroboros.Storage.ChainDB.Impl.ImmDB as ImmDB
 import           Ouroboros.Storage.ChainDB.Impl.LgrDB (LgrDB)
 import qualified Ouroboros.Storage.ChainDB.Impl.LgrDB as LgrDB
 import           Ouroboros.Storage.ChainDB.Impl.VolDB (VolDB)
+import qualified Ouroboros.Storage.ChainDB.Impl.VolDB as VolDB
 
 -- | A handle to the internal ChainDB state
 newtype ChainDbHandle m blk = CDBHandle (StrictTVar m (ChainDbState m blk))
@@ -399,6 +400,7 @@ data TraceEvent blk
   | TraceLedgerEvent       (LgrDB.TraceEvent (Point blk))
   | TraceLedgerReplayEvent (LgrDB.TraceLedgerReplayEvent blk)
   | TraceImmDBEvent        (ImmDB.TraceEvent       blk)
+  | TraceVolDBEvent        (VolDB.TraceEvent       blk)
   deriving (Generic)
 
 deriving instance

ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/VolDB.hs

@@ -44,6 +44,8 @@ module Ouroboros.Storage.ChainDB.Impl.VolDB (
   , closeDB
   , reopen
   , garbageCollect
+    -- * Tracing
+  , TraceEvent
     -- * Re-exports
   , VolatileDBError
     -- * Exported for testing purposes
@@ -56,6 +58,7 @@ import           Codec.CBOR.Encoding (Encoding)
 import qualified Codec.CBOR.Read as CBOR
 import qualified Codec.CBOR.Write as CBOR
 import           Control.Monad (join)
+import           Control.Tracer (Tracer, nullTracer)
 import qualified Data.ByteString.Lazy as Lazy
 import           Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as NE
@@ -130,6 +133,10 @@ instance NoUnexpectedThunks (VolDB m blk) where
     , noUnexpectedThunks ctxt errSTM
     ]
 
+-- | Short-hand for events traced by the VolDB wrapper.
+type TraceEvent blk =
+  VolDB.TraceEvent (BlockFileParserError (HeaderHash blk)) (HeaderHash blk)
+
 {-------------------------------------------------------------------------------
   Initialization
 -------------------------------------------------------------------------------}
@@ -145,6 +152,7 @@ data VolDbArgs m blk = forall h. VolDbArgs {
     , volEncodeBlock    :: blk -> BinaryInfo Encoding
     , volIsEBB          :: blk -> IsEBB
     , volAddHdrEnv      :: IsEBB -> Lazy.ByteString -> Lazy.ByteString
+    , volTracer         :: Tracer m (TraceEvent blk)
     }
 
 -- | Default arguments when using the 'IO' monad
@@ -162,6 +170,7 @@ defaultArgs fp = VolDbArgs {
       volErr            = EH.exceptions
     , volErrSTM         = EH.throwSTM
     , volHasFS          = ioHasFS $ MountPoint (fp </> "volatile")
+    , volTracer         = nullTracer
       -- Fields without a default
     , volCheckIntegrity = error "no default for volCheckIntegrity"
     , volBlocksPerFile  = error "no default for volBlocksPerFile"
@@ -180,6 +189,7 @@ openDB args@VolDbArgs{..} = do
                volErr
                volErrSTM
                (blockFileParser args)
+               volTracer
                volBlocksPerFile
     return VolDB
       { volDB     = volDB
@@ -482,17 +492,18 @@ getBlockComponent db blockComponent hash = withDB db $ \vol ->
     blockComponent' = translateToRawDB (parse db) (addHdrEnv db) blockComponent
 
 {-------------------------------------------------------------------------------
-  Auxiliary: parsing
+  Parsing
 -------------------------------------------------------------------------------}
 
-data BlockFileParserError =
+data BlockFileParserError hash =
     BlockReadErr Util.CBOR.ReadIncrementalErr
-  | BlockCorruptErr
+  | BlockCorruptedErr hash
+  deriving (Eq, Show)
 
 blockFileParser :: forall m blk. (IOLike m, HasHeader blk)
                 => VolDbArgs m blk
                 -> VolDB.Parser
-                     BlockFileParserError
+                     (BlockFileParserError (HeaderHash blk))
                      m
                      (HeaderHash blk)
 blockFileParser VolDbArgs{..} =
@@ -507,7 +518,7 @@ blockFileParser' :: forall m blk h. (IOLike m, HasHeader blk)
                  -> (forall s. Decoder s (Lazy.ByteString -> blk))
                  -> (blk -> Bool)
                  -> VolDB.Parser
-                     BlockFileParserError
+                     (BlockFileParserError (HeaderHash blk))
                      m
                      (HeaderHash blk)
 blockFileParser' hasFS isEBB encodeBlock decodeBlock checkIntegrity =
@@ -525,7 +536,7 @@ blockFileParser' hasFS isEBB encodeBlock decodeBlock checkIntegrity =
                     m
                     (Maybe (Util.CBOR.ReadIncrementalErr, Word64))
                  -> m (VolDB.ParsedInfo (HeaderHash blk),
-                    Maybe BlockFileParserError)
+                    Maybe (BlockFileParserError (HeaderHash blk)))
     checkEntries = go []
       where
         go parsed stream = S.next stream >>= \case
@@ -534,7 +545,9 @@ blockFileParser' hasFS isEBB encodeBlock decodeBlock checkIntegrity =
             let !blockInfo = extractInfo' blk
                 newParsed = (offset, (VolDB.BlockSize size, blockInfo))
             in go (newParsed : parsed) stream'
-          _ -> return (reverse parsed, Just BlockCorruptErr)
+          Right ((_, (_, blk)), _) ->
+            let !bid = VolDB.bbid $ extractInfo' blk
+            in return (reverse parsed, Just (BlockCorruptedErr bid))
 
 {-------------------------------------------------------------------------------
   Error handling

ouroboros-consensus/src/Ouroboros/Storage/VolatileDB/Impl.hs

@@ -96,6 +96,7 @@ module Ouroboros.Storage.VolatileDB.Impl
     ) where
 
 import           Control.Monad
+import           Control.Tracer (Tracer, traceWith)
 import qualified Data.ByteString.Builder as BS
 import           Data.List (find, sortOn)
 import           Data.Map.Strict (Map)
@@ -139,6 +140,7 @@ data VolatileDBEnv m blockId = forall h e. VolatileDBEnv {
     , _dbInternalState  :: !(StrictMVar m (OpenOrClosed blockId h))
     , _maxBlocksPerFile :: !Int
     , _parser           :: !(Parser e m blockId)
+    , _tracer           :: !(Tracer m (TraceEvent e blockId))
     }
 
 data OpenOrClosed blockId h =
@@ -187,9 +189,10 @@ openDB :: ( HasCallStack
        -> ErrorHandling VolatileDBError m
        -> ThrowCantCatch VolatileDBError (STM m)
        -> Parser e m blockId
+       -> Tracer m (TraceEvent e blockId)
        -> Int
        -> m (VolatileDB blockId m)
-openDB h e e' p m = fst <$> openDBFull h e e' p m
+openDB h e e' p t m = fst <$> openDBFull h e e' p t m
 
 openDBFull :: ( HasCallStack
               , IOLike m
@@ -202,10 +205,11 @@ openDBFull :: ( HasCallStack
            -> ErrorHandling VolatileDBError m
            -> ThrowCantCatch VolatileDBError (STM m)
            -> Parser e m blockId
+           -> Tracer m (TraceEvent e blockId)
            -> Int
            -> m (VolatileDB blockId m, VolatileDBEnv m blockId)
-openDBFull hasFS err errSTM parser maxBlocksPerFile = do
-    env <- openDBImpl hasFS err errSTM parser maxBlocksPerFile
+openDBFull hasFS err errSTM parser tracer maxBlocksPerFile = do
+    env <- openDBImpl hasFS err errSTM parser tracer maxBlocksPerFile
     return $ (, env) VolatileDB {
         closeDB           = closeDBImpl  env
       , isOpenDB          = isOpenDBImpl env
@@ -231,24 +235,26 @@ openDBImpl :: ( HasCallStack
            -> ErrorHandling VolatileDBError m
            -> ThrowCantCatch VolatileDBError (STM m)
            -> Parser e m blockId
+           -> Tracer m (TraceEvent e blockId)
            -> Int -- ^ @maxBlocksPerFile@
            -> m (VolatileDBEnv m blockId)
-openDBImpl hasFS@HasFS{..} err errSTM parser maxBlocksPerFile =
+openDBImpl hasFS@HasFS{..} err errSTM parser tracer maxBlocksPerFile =
     if maxBlocksPerFile <= 0
     then EH.throwError err $ UserError . InvalidArgumentsError $
       "maxBlocksPerFile should be positive"
     else do
-      st <- mkInternalStateDB hasFS err parser maxBlocksPerFile
+      st <- mkInternalStateDB hasFS err parser tracer maxBlocksPerFile
       stVar <- newMVar $ VolatileDbOpen st
-      return $ VolatileDBEnv hasFS err errSTM stVar maxBlocksPerFile parser
+      return $
+        VolatileDBEnv hasFS err errSTM stVar maxBlocksPerFile parser tracer
 
 closeDBImpl :: IOLike m
             => VolatileDBEnv m blockId
             -> m ()
 closeDBImpl VolatileDBEnv{..} = do
     mbInternalState <- swapMVar _dbInternalState VolatileDbClosed
     case mbInternalState of
-      VolatileDbClosed -> return ()
+      VolatileDbClosed -> traceWith _tracer DBAlreadyClosed
       VolatileDbOpen InternalState{..} ->
         wrapFsError hasFsErr _dbErr $ hClose _currentWriteHandle
   where
@@ -273,9 +279,12 @@ reOpenDBImpl :: ( HasCallStack
              -> m ()
 reOpenDBImpl VolatileDBEnv{..} =
     modifyMVar _dbInternalState $ \case
-      VolatileDbOpen st -> return (VolatileDbOpen st, ())
+      VolatileDbOpen st -> do
+        traceWith _tracer DBAlreadyOpen
+        return (VolatileDbOpen st, ())
       VolatileDbClosed -> do
-        st <- mkInternalStateDB _dbHasFS _dbErr _parser _maxBlocksPerFile
+        st <- mkInternalStateDB
+          _dbHasFS _dbErr _parser _tracer _maxBlocksPerFile
         return (VolatileDbOpen st, ())
 
 getBlockComponentImpl
@@ -341,7 +350,9 @@ putBlockImpl :: forall m blockId. (IOLike m, Ord blockId)
 putBlockImpl env@VolatileDBEnv{..} BlockInfo{..} builder =
     modifyState env $ \hasFS@HasFS{..} st@InternalState{..} ->
       if Map.member bbid _currentRevMap
-      then return (st, ()) -- putting an existing block is a no-op.
+      then do
+        traceWith _tracer $ BlockAlreadyHere bbid
+        return (st, ()) -- putting an existing block is a no-op.
       else do
         bytesWritten <- hPut hasFS _currentWriteHandle builder
         updateStateAfterWrite hasFS st bytesWritten
@@ -418,10 +429,10 @@ tryCollectFile :: forall m h blockId
                -> InternalState blockId h
                -> (FileId, FileInfo blockId)
                -> m (InternalState blockId h)
-tryCollectFile hasFS@HasFS{..} env slot st@InternalState{..} (fileId, fileInfo) =
+tryCollectFile hasFS env slot st@InternalState{..} (fileId, fileInfo) =
     if  | not canGC     -> return st
         | not isCurrent -> do
-            removeFile $ filePath fileId
+            removeFile hasFS $ filePath fileId
             return st {
                 _currentMap     = Index.delete fileId _currentMap
               , _currentRevMap  = currentRevMap'
@@ -437,12 +448,14 @@ tryCollectFile hasFS@HasFS{..} env slot st@InternalState{..} (fileId, fileInfo)
             -- 'reOpenFile' technically truncates the file to 0 offset, so any
             -- concurrent readers may fail. This may become an issue after:
             -- <https://github.com/input-output-hk/ouroboros-network/issues/767>
-            st' <- reOpenFile hasFS (_dbErr env) env st
+            traceWith _tracer $ TruncateCurrentFile _currentWritePath
+            st' <- reOpenFile hasFS _dbErr env st
             return st' {
                 _currentRevMap  = currentRevMap'
               , _currentSuccMap = succMap'
               }
   where
+    VolatileDBEnv { _dbErr, _tracer } = env
     canGC          = FileInfo.canGC fileInfo slot
     isCurrent      = fileId == _currentWriteId
     isCurrentNew   = _currentWriteOffset == 0
@@ -537,14 +550,15 @@ mkInternalStateDB :: ( HasCallStack
                   => HasFS m h
                   -> ErrorHandling VolatileDBError m
                   -> Parser e m blockId
+                  -> Tracer m (TraceEvent e blockId)
                   -> Int
                   -> m (InternalState blockId h)
-mkInternalStateDB hasFS@HasFS{..} err parser maxBlocksPerFile =
+mkInternalStateDB hasFS@HasFS{..} err parser tracer maxBlocksPerFile =
     wrapFsError hasFsErr err $ do
       createDirectoryIfMissing True dbDir
       allFiles <- map toFsPath . Set.toList <$> listDirectory dbDir
       filesWithIds <- fromEither err $ parseAllFds allFiles
-      mkInternalState hasFS err parser maxBlocksPerFile filesWithIds
+      mkInternalState hasFS err parser tracer maxBlocksPerFile filesWithIds
   where
     dbDir = mkFsPath []
 
@@ -565,10 +579,11 @@ mkInternalState
   => HasFS m h
   -> ErrorHandling VolatileDBError m
   -> Parser e m blockId
+  -> Tracer m (TraceEvent e blockId)
   -> Int
   -> [(FileId, FsPath)]
   -> m (InternalState blockId h)
-mkInternalState hasFS err parser n files =
+mkInternalState hasFS err parser tracer n files =
     wrapFsError (hasFsErr hasFS) err $
       go Index.empty Map.empty Map.empty Nothing [] files
   where
@@ -581,7 +596,8 @@ mkInternalState hasFS err parser n files =
       , FileSize 0 )
 
     truncateOnError Nothing _ _ = return ()
-    truncateOnError (Just _) file offset =
+    truncateOnError (Just e) file offset = do
+      traceWith tracer $ Truncate e file offset
       -- The handle of the parser is closed at this point. We need
       -- to reopen the file in 'AppendMode' now (parser opens with
       -- 'ReadMode').

ouroboros-consensus/src/Ouroboros/Storage/VolatileDB/Types.hs

@@ -141,3 +141,15 @@ data InternalBlockInfo blockId = InternalBlockInfo {
     , ibHeaderOffset :: !Word16
     , ibHeaderSize   :: !Word16
     } deriving (Show, Generic, NoUnexpectedThunks)
+
+{------------------------------------------------------------------------------
+  Tracing
+------------------------------------------------------------------------------}
+
+data TraceEvent e hash
+    = DBAlreadyClosed
+    | DBAlreadyOpen
+    | BlockAlreadyHere hash
+    | TruncateCurrentFile FsPath
+    | Truncate e FsPath SlotOffset
+  deriving (Eq, Generic, Show)

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

@@ -99,6 +99,7 @@ import           Ouroboros.Storage.LedgerDB.DiskPolicy (defaultDiskPolicy)
 import           Ouroboros.Storage.LedgerDB.InMemory (LedgerDbParams (..))
 import qualified Ouroboros.Storage.LedgerDB.OnDisk as LedgerDB
 import qualified Ouroboros.Storage.Util.ErrorHandling as EH
+import qualified Ouroboros.Storage.VolatileDB as VolDB
 
 import           Test.Ouroboros.Storage.ChainDB.Model (IteratorId,
                      ModelSupportsBlock, ReaderId)
@@ -1113,6 +1114,8 @@ deriving instance SOP.Generic         (LedgerDB.TraceReplayEvent r replayTo bloc
 deriving instance SOP.HasDatatypeInfo (LedgerDB.TraceReplayEvent r replayTo blockInfo)
 deriving instance SOP.Generic         (ImmDB.TraceEvent e hash)
 deriving instance SOP.HasDatatypeInfo (ImmDB.TraceEvent e hash)
+deriving instance SOP.Generic         (VolDB.TraceEvent e hash)
+deriving instance SOP.HasDatatypeInfo (VolDB.TraceEvent e hash)
 
 -- TODO labelling
 
@@ -1412,6 +1415,7 @@ traceEventName = \case
     TraceLedgerEvent         ev    -> "Ledger."       <> constrName ev
     TraceLedgerReplayEvent   ev    -> "LedgerReplay." <> constrName ev
     TraceImmDBEvent          ev    -> "ImmDB."        <> constrName ev
+    TraceVolDBEvent          ev    -> "VolDB."        <> constrName ev
 
 fixedEpochSize :: EpochSize
 fixedEpochSize = 10

ouroboros-consensus/test-storage/Test/Ouroboros/Storage/VolatileDB.hs

@@ -11,6 +11,8 @@
 
 module Test.Ouroboros.Storage.VolatileDB (tests) where
 
+import           Control.Tracer (nullTracer)
+
 import           Test.QuickCheck
 import           Test.QuickCheck.Monadic
 import           Test.Tasty (TestTree, testGroup)
@@ -32,7 +34,7 @@ tests = testGroup "VolatileDB"
 prop_VolatileInvalidArg :: HasCallStack => Property
 prop_VolatileInvalidArg = monadicIO $
     run $ apiEquivalenceVolDB fExpected (\hasFS err -> do
-            _ <- Internal.openDBFull hasFS err (EH.throwCantCatch EH.monadCatch) dummyParser 0
+            _ <- Internal.openDBFull hasFS err (EH.throwCantCatch EH.monadCatch) dummyParser nullTracer 0
             return ()
         )
   where

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

@@ -25,6 +25,7 @@ import           Prelude hiding (elem)
 import           Codec.Serialise (decode)
 import           Control.Monad.Except
 import           Control.Monad.State
+import           Control.Tracer (nullTracer)
 import           Data.Bifunctor (bimap)
 import           Data.ByteString.Lazy (ByteString)
 import           Data.Functor.Classes
@@ -654,7 +655,7 @@ prop_sequential =
               let parser = blockFileParser' hasFS testBlockIsEBB
                     testBlockToBinaryInfo (const <$> decode) checkBlockIntegrity
               (db, env) <- run $
-                    Internal.openDBFull hasFS EH.monadCatch ec parser 3
+                Internal.openDBFull hasFS EH.monadCatch ec parser nullTracer 3
               let sm' = sm True errorsVar db env dbm
               (hist, _model, res) <- runCommands sm' cmds
               run $ closeDB db