From 87845965e20777439b8a9fccc5579532c91921c9 Mon Sep 17 00:00:00 2001 From: kderme Date: Thu, 6 Feb 2020 12:30:40 +0200 Subject: [PATCH] Add traces --- .../Ouroboros/Storage/ChainDB/Impl/Args.hs | 1 + .../Ouroboros/Storage/ChainDB/Impl/Types.hs | 2 + .../Ouroboros/Storage/ChainDB/Impl/VolDB.hs | 27 +++++++--- .../src/Ouroboros/Storage/VolatileDB/Impl.hs | 50 ++++++++++++------- .../src/Ouroboros/Storage/VolatileDB/Types.hs | 12 +++++ .../Ouroboros/Storage/ChainDB/StateMachine.hs | 4 ++ .../Test/Ouroboros/Storage/VolatileDB.hs | 4 +- .../Storage/VolatileDB/StateMachine.hs | 3 +- 8 files changed, 77 insertions(+), 26 deletions(-) diff --git a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/Args.hs b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/Args.hs index 53d9d7ab856..c914d8f05b0 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/Args.hs +++ b/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 diff --git a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/Types.hs index b808c5b9afe..b6194d762ee 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/Types.hs +++ b/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 diff --git a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/VolDB.hs b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/VolDB.hs index a45a17098be..aea566a5d36 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/VolDB.hs +++ b/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 diff --git a/ouroboros-consensus/src/Ouroboros/Storage/VolatileDB/Impl.hs b/ouroboros-consensus/src/Ouroboros/Storage/VolatileDB/Impl.hs index 3b1499f95f4..24ca96e5eee 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/VolatileDB/Impl.hs +++ b/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,16 +235,18 @@ 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 @@ -248,7 +254,7 @@ closeDBImpl :: IOLike 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: -- - 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'). diff --git a/ouroboros-consensus/src/Ouroboros/Storage/VolatileDB/Types.hs b/ouroboros-consensus/src/Ouroboros/Storage/VolatileDB/Types.hs index 94de0053d0d..3b58aaf88c8 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/VolatileDB/Types.hs +++ b/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) diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/StateMachine.hs index 97857fdcfb2..3036c29f3e7 100644 --- a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/StateMachine.hs +++ b/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 diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/VolatileDB.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/VolatileDB.hs index 313f4569cfe..61b4c0561e3 100644 --- a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/VolatileDB.hs +++ b/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 diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs index d54f77d48a8..ccdfd8d5cf0 100644 --- a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs +++ b/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