diff --git a/lib/core/src/Cardano/Wallet/Network.hs b/lib/core/src/Cardano/Wallet/Network.hs index 561a2ac4d01..d66b5b38232 100644 --- a/lib/core/src/Cardano/Wallet/Network.hs +++ b/lib/core/src/Cardano/Wallet/Network.hs @@ -293,7 +293,7 @@ follow -- ^ Getter on the abstract 'block' type -> IO () follow nl tr' readCursor forward' backward recovery tol header = do - tr <- monitorStatus tr' + tr <- monitorFollowStats tr' loop tr True where loop tr firstTime = do @@ -525,9 +525,12 @@ instance HasSeverityAnnotation tr => HasSeverityAnnotation (FollowLog tr) where -- -- Log aggregation --- Perhaps this could be done using iohk-monitoring as well. +-- -- | Statistics of interest from the follow-function. +-- +-- The @f@ allows us to use @LogState@ to keep track of both current and +-- previously logged stats, and perform operations over it in a nice way. data FollowStats f = FollowStats { blocksApplied :: f Int , rollbacks :: f Int @@ -539,6 +542,7 @@ data FollowStats f = FollowStats deriving instance Show (FollowStats LogState) deriving instance Eq (FollowStats LogState) +-- | Change the @f@ wrapping each record field. hoistStats :: (forall a. f a -> g a) -> FollowStats f @@ -550,14 +554,12 @@ hoistStats f FollowStats{blocksApplied,rollbacks,time,prog} = FollowStats , prog = f prog } --- | For keeping track of what we have logged and what we have not logged. +-- | For keeping track of what we have logged and what we have not. -- -- The idea is to --- 1. Maintain the @current@ @state@ using a @Trace@ +-- 1. Reconstruct a model of the @current@ @state@ using a @Trace@ -- 2. Sometimes log the difference between the @current@ state and the most -- recently logged one. --- --- TODO: What if we had a @Functor f@ on each field in @FollowStats@ instead? data LogState a = LogState { prev :: a -- ^ Most previously logged state , current :: a -- ^ Not-yet logged state @@ -566,9 +568,14 @@ data LogState a = LogState initLogState :: a -> LogState a initLogState a = LogState a a +-- | Modify the current state of a @LogState state@ overCurrent :: (a -> a) -> LogState a -> LogState a overCurrent f (LogState prev cur) = LogState prev (f cur) +-- | /The way/ to log the current stats. +-- +-- It /traces/ a presentable @FollowStats LogState@ before flushing and +-- /returns/ a new flushed @FollowStats@ where @prev == current@. flush :: Monad m => Tracer m (FollowStats LogState) @@ -588,6 +595,7 @@ emptyStats t p = FollowStats (f 0) (f 0) (f t) (f p) where f = initLogState +-- | Update the stats based on a new log message. updateStats :: FollowLog tr -> FollowStats LogState -> FollowStats LogState updateStats msg s = case msg of MsgApplyBlocks _tip blocks -> @@ -603,13 +611,20 @@ instance ToText (FollowStats LogState) where where -- NOTE: We are using NotResponding as initial value. syncStatus = case sp of - LogState NotResponding Ready -> "In sync." - LogState Ready Ready -> "Still in sync." - LogState NotResponding NotResponding -> "Still not syncing." - LogState (Syncing _p) Ready -> "In sync!" - LogState Ready (Syncing p) -> "Syncing again (" <> (pretty p) <> ")" - LogState _ (Syncing p) -> "Syncing (" <> (pretty p) <> ")" - LogState prev NotResponding -> "Not responding. Previously " <> (pretty prev) <> "." + LogState NotResponding Ready -> + "In sync." + LogState Ready Ready -> + "Still in sync." + LogState NotResponding NotResponding -> + "Still not syncing." + LogState (Syncing _p) Ready -> + "In sync!" + LogState Ready (Syncing p) -> + "Syncing again (" <> (pretty p) <> ")" + LogState _ (Syncing p) -> + "Syncing (" <> (pretty p) <> ")" + LogState prev NotResponding -> + "Not responding. Previously " <> (pretty prev) <> "." stats = mconcat [ "Applied " <> pretty (using (-) b) <> " blocks, " , pretty (using (-) r) <> " rollbacks " @@ -622,35 +637,22 @@ instance HasSeverityAnnotation (FollowStats LogState) where getSeverityAnnotation s | current (prog s) < prev (prog s) = Warning | otherwise = Info - -- FIXME: Here we check if the sync progress is going backwards, which + -- NOTE: Here we check if the sync progress is going backwards, which -- would be a sign the wallet is overloaded (or rollbacks) -- -- But this check might be in the wrong place. Might be better to -- produce new logs from inside the updateStats function and immeditely -- warn there. - --- TODO: What is actually interesting? --- --- If we are not restored: --- - How fast we are restoring --- - Where we are on-chain --- - Where the node is --- - Where the current time is --- - How many rollbacks we encounter --- - What the worker itself is finding on-chain --- - How long the worker operations are --- - When we are restored --- --- If we are restored: --- - If the node goes out of sync with the network --- - If the wallet goes out of sync with the node -monitorStatus :: Tracer IO (FollowLog tr) -> IO (Tracer IO (FollowLog tr)) -monitorStatus tr = do +-- | Starts a new thread for monitoring health and statistics from +-- the returned @FollowLog tr@. +monitorFollowStats :: Tracer IO (FollowLog tr) -> IO (Tracer IO (FollowLog tr)) +monitorFollowStats tr = do t0' <- getCurrentTime - let sp = NotResponding -- TODO: other default prob + let sp = NotResponding -- Hijacked as a default value. Should be fine. + -- It appears to be otherwise unused in the codebase. mvar <- newMVar $ emptyStats t0' sp - _ <- forkIO $ loop mvar 5000000 + _ <- forkIO $ loop mvar (5 * second) return $ flip contramapM tr $ \msg -> do modifyMVar_ mvar (pure . updateStats msg) pure msg