|
| 1 | +{-# LANGUAGE DeriveGeneric #-} |
| 2 | +{-# LANGUAGE NamedFieldPuns #-} |
| 3 | +{-# LANGUAGE OverloadedStrings #-} |
| 4 | +{-# LANGUAGE RecordWildCards #-} |
| 5 | +{-# LANGUAGE StrictData #-} |
| 6 | +{-# LANGUAGE TupleSections #-} |
| 7 | + |
| 8 | +module Leios.Tracing.Lifecycle ( |
| 9 | + lifecycle, |
| 10 | +) where |
| 11 | + |
| 12 | +import Control.Monad ((<=<)) |
| 13 | +import Control.Monad.State.Strict (State, execState, gets, modify') |
| 14 | +import Data.Aeson (FromJSON (..), Value (Object), withObject, (.:)) |
| 15 | +import Data.Aeson.Types (Parser, parseMaybe) |
| 16 | +import Data.Function (on) |
| 17 | +import Data.List (intercalate) |
| 18 | +import Data.Map.Strict (Map) |
| 19 | +import Data.Monoid (Sum (..)) |
| 20 | +import Data.Set (Set) |
| 21 | +import Data.Text (Text) |
| 22 | + |
| 23 | +import qualified Data.Map.Strict as M (elems, fromList, insertWith, restrictKeys, toList, unionWith) |
| 24 | +import qualified Data.Set as S (map, singleton) |
| 25 | +import qualified Data.Text as T (unpack) |
| 26 | + |
| 27 | +newtype Earliest a = Earliest {getEarliest :: Maybe a} |
| 28 | + deriving (Show) |
| 29 | + |
| 30 | +instance Eq a => Eq (Earliest a) where |
| 31 | + Earliest (Just x) == Earliest (Just y) = x == y |
| 32 | + Earliest Nothing == Earliest Nothing = True |
| 33 | + _ == _ = False |
| 34 | + |
| 35 | +instance Ord a => Ord (Earliest a) where |
| 36 | + Earliest (Just x) `compare` Earliest (Just y) = x `compare` y |
| 37 | + Earliest (Just _) `compare` Earliest Nothing = LT |
| 38 | + Earliest Nothing `compare` Earliest (Just _) = GT |
| 39 | + Earliest Nothing `compare` Earliest Nothing = EQ |
| 40 | + |
| 41 | +instance Ord a => Semigroup (Earliest a) where |
| 42 | + x <> y = if x < y then x else y |
| 43 | + |
| 44 | +instance Ord a => Monoid (Earliest a) where |
| 45 | + mempty = Earliest Nothing |
| 46 | + |
| 47 | +instance FromJSON a => FromJSON (Earliest a) where |
| 48 | + parseJSON = fmap Earliest . parseJSON |
| 49 | + |
| 50 | +data ItemKey |
| 51 | + = ItemKey |
| 52 | + { kind :: Text |
| 53 | + , item :: Text |
| 54 | + } |
| 55 | + deriving (Eq, Ord, Show) |
| 56 | + |
| 57 | +data ItemInfo |
| 58 | + = ItemInfo |
| 59 | + { size :: Earliest Int |
| 60 | + , references :: Sum Int |
| 61 | + , created :: Earliest Double |
| 62 | + , toIB :: Earliest Double |
| 63 | + , toEB :: Earliest Double |
| 64 | + , toRB :: Earliest Double |
| 65 | + , inRB :: Earliest Double |
| 66 | + , inIBs :: Set Text |
| 67 | + , inEBs :: Set Text |
| 68 | + } |
| 69 | + deriving (Show) |
| 70 | + |
| 71 | +instance Semigroup ItemInfo where |
| 72 | + x <> y = |
| 73 | + ItemInfo |
| 74 | + { size = on (<>) size x y |
| 75 | + , references = on (<>) references x y |
| 76 | + , created = on (<>) created x y |
| 77 | + , toIB = on (<>) toIB x y |
| 78 | + , toEB = on (<>) toEB x y |
| 79 | + , toRB = on (<>) toRB x y |
| 80 | + , inRB = on (<>) inRB x y |
| 81 | + , inIBs = on (<>) inIBs x y |
| 82 | + , inEBs = on (<>) inEBs x y |
| 83 | + } |
| 84 | + |
| 85 | +instance Monoid ItemInfo where |
| 86 | + mempty = |
| 87 | + ItemInfo |
| 88 | + { size = mempty |
| 89 | + , references = mempty |
| 90 | + , created = mempty |
| 91 | + , toIB = mempty |
| 92 | + , toEB = mempty |
| 93 | + , toRB = mempty |
| 94 | + , inRB = mempty |
| 95 | + , inIBs = mempty |
| 96 | + , inEBs = mempty |
| 97 | + } |
| 98 | + |
| 99 | +toCSV :: ItemKey -> ItemInfo -> String |
| 100 | +toCSV ItemKey{..} ItemInfo{..} = |
| 101 | + intercalate |
| 102 | + sep |
| 103 | + [ T.unpack kind |
| 104 | + , T.unpack item |
| 105 | + , maybe "NA" show $ getEarliest size |
| 106 | + , show $ getSum references |
| 107 | + , maybe "NA" show $ getEarliest created |
| 108 | + , maybe "NA" show $ getEarliest toIB |
| 109 | + , maybe "NA" show $ getEarliest toEB |
| 110 | + , maybe "NA" show $ getEarliest toRB |
| 111 | + , maybe "NA" show $ getEarliest inRB |
| 112 | + ] |
| 113 | + |
| 114 | +itemHeader :: String |
| 115 | +itemHeader = |
| 116 | + intercalate |
| 117 | + sep |
| 118 | + [ "Kind" |
| 119 | + , "Item" |
| 120 | + , "Size [B]" |
| 121 | + , "References" |
| 122 | + , "Created [s]" |
| 123 | + , "To IB [s]" |
| 124 | + , "To EB [s]" |
| 125 | + , "To RB [s]" |
| 126 | + , "In RB [s]" |
| 127 | + ] |
| 128 | + |
| 129 | +sep :: String |
| 130 | +sep = "," |
| 131 | + |
| 132 | +parseEvent :: Value -> Parser (ItemKey, ItemInfo, Index) |
| 133 | +parseEvent = |
| 134 | + withObject "TraceEvent" $ \event -> |
| 135 | + do |
| 136 | + time <- Earliest <$> event .: "time_s" |
| 137 | + message <- event .: "message" |
| 138 | + typ <- message .: "type" |
| 139 | + ident <- message .: "id" |
| 140 | + parseMessage typ ident time $ Object message |
| 141 | + |
| 142 | +parseMessage :: Text -> Text -> Earliest Double -> Value -> Parser (ItemKey, ItemInfo, Index) |
| 143 | +parseMessage "TXGenerated" item created = |
| 144 | + withObject "TXGenerated" $ \message -> |
| 145 | + do |
| 146 | + size <- message .: "size_bytes" |
| 147 | + pure (ItemKey{kind = "TX", item}, mempty{size, created}, mempty) |
| 148 | +parseMessage "IBGenerated" item created = |
| 149 | + withObject "IBGenerated" $ \message -> |
| 150 | + do |
| 151 | + size <- message .: "size_bytes" |
| 152 | + txs <- fmap ((,mempty{toIB = created, inIBs = S.singleton item, references = Sum 1}) . ItemKey "TX") <$> message .: "transactions" |
| 153 | + pure (ItemKey{kind = "IB", item}, mempty{size, created}, M.fromList txs) |
| 154 | +parseMessage "EBGenerated" item created = |
| 155 | + withObject "EBGenerated" $ \message -> |
| 156 | + do |
| 157 | + size <- message .: "size_bytes" |
| 158 | + ibs <- mapM (fmap ((,mempty{toEB = created, inEBs = S.singleton item, references = Sum 1}) . ItemKey "IB") . (.: "id")) =<< message .: "input_blocks" |
| 159 | + ebs <- mapM (fmap ((,mempty{toEB = created, inEBs = S.singleton item, references = Sum 1}) . ItemKey "EB") . (.: "id")) =<< message .: "endorser_blocks" |
| 160 | + pure (ItemKey{kind = "EB", item}, mempty{size, created}, M.fromList $ ibs <> ebs) |
| 161 | +parseMessage "RBGenerated" item created = |
| 162 | + withObject "RBGenerated" $ \message -> |
| 163 | + do |
| 164 | + size <- message .: "size_bytes" |
| 165 | + ebs <- |
| 166 | + maybe |
| 167 | + (pure mempty) |
| 168 | + (fmap (pure . (,mempty{toRB = created, references = Sum 1}) . ItemKey "EB") . (.: "id") <=< (.: "eb")) |
| 169 | + =<< message .: "endorsement" |
| 170 | + txs <- fmap ((,mempty{inRB = created, references = Sum 1}) . ItemKey "TX") <$> message .: "transactions" |
| 171 | + pure (ItemKey{kind = "RB", item}, mempty{size, created}, M.fromList $ ebs <> txs) |
| 172 | +parseMessage _ _ _ = |
| 173 | + const $ fail "Ignore" |
| 174 | + |
| 175 | +type Index = Map ItemKey ItemInfo |
| 176 | + |
| 177 | +tally :: Value -> State Index () |
| 178 | +tally event = |
| 179 | + case parseMaybe parseEvent event of |
| 180 | + Just (itemKey, itemInfo, updates) -> |
| 181 | + do |
| 182 | + -- Insert the generated items. |
| 183 | + modify' $ M.insertWith (<>) itemKey itemInfo |
| 184 | + -- Update the cross-references. |
| 185 | + modify' $ M.unionWith (<>) updates |
| 186 | + Nothing -> pure () |
| 187 | + |
| 188 | +updateInclusions :: Text -> ItemKey -> Set Text -> State Index () |
| 189 | +updateInclusions kind itemKey includers = |
| 190 | + do |
| 191 | + includers' <- gets $ M.elems . (`M.restrictKeys` S.map (ItemKey kind) includers) |
| 192 | + modify' $ |
| 193 | + M.insertWith |
| 194 | + (<>) |
| 195 | + itemKey |
| 196 | + mempty |
| 197 | + { toEB = mconcat $ toEB <$> includers' |
| 198 | + , toRB = mconcat $ toRB <$> includers' |
| 199 | + } |
| 200 | + |
| 201 | +updateEBs :: ItemKey -> ItemInfo -> State Index () |
| 202 | +updateEBs itemKey = updateInclusions "EB" itemKey . inEBs |
| 203 | + |
| 204 | +updateIBs :: ItemKey -> ItemInfo -> State Index () |
| 205 | +updateIBs itemKey = updateInclusions "IB" itemKey . inIBs |
| 206 | + |
| 207 | +lifecycle :: FilePath -> [Value] -> IO () |
| 208 | +lifecycle lifecycleFile events = |
| 209 | + let |
| 210 | + index = |
| 211 | + (`execState` mempty) $ |
| 212 | + do |
| 213 | + -- Compute the direct metrics from the traces. |
| 214 | + mapM_ tally events |
| 215 | + -- Update arrival in EBs and RBs for IBs. |
| 216 | + mapM_ (uncurry updateEBs) =<< gets M.toList |
| 217 | + -- Update arrival in EBs and RBs for TXs. |
| 218 | + mapM_ (uncurry updateIBs) =<< gets M.toList |
| 219 | + in |
| 220 | + writeFile lifecycleFile . unlines . (itemHeader :) $ |
| 221 | + uncurry toCSV <$> M.toList index |
0 commit comments