WIP - debug db-sync issue #683

cardano-api/src/Cardano/Api.hs

@@ -146,7 +146,7 @@ module Cardano.Api (
     -- | Constructing and inspecting transactions
 
     -- ** Transaction bodies
-    TxBody,
+    TxBody (..),
     makeTransactionBody,
     TxBodyContent(..),
     TxBodyError(..),

cardano-client-demo/LedgerState.hs

@@ -26,28 +26,86 @@ import           Ouroboros.Network.Protocol.ChainSync.ClientPipelined
 import           Ouroboros.Network.Protocol.ChainSync.PipelineDecision
 import           System.Environment (getArgs)
 
+import qualified Shelley.Spec.Ledger.TxBody as L
+import qualified Shelley.Spec.Ledger.RewardUpdate as L
+import qualified Cardano.Ledger.ShelleyMA.TxBody as MA
+import qualified Shelley.Spec.Ledger.API as L
+import qualified Data.Sequence.Strict as StrictSeq
+import qualified Data.Map.Strict as Map
+
+data State = State { lastCheckpoint :: Word64
+                   , lastRewEpoch   :: Word64
+                   }
 
 main :: IO ()
 main = do
   -- Get socket path from CLI argument.
-  configFilePath : socketPath : _ <- getArgs
-  blockCount <- fmap (either (error . T.unpack . renderFoldBlocksError) id) $ runExceptT $ foldBlocks
+  configFilePath : socketPath : target : checkpointSize : _ <- getArgs
+  -- $ cabal exec ledger-state configuration/cardano/mainnet-config.json state-node-mainnet/node.socket 8190331207ecedfcaf448340d8bb84354a0e8c285982a2d7f98bb234 500000
+  lastCheckpoint <- fmap (either (error . T.unpack . renderFoldBlocksError) id) $ runExceptT $ foldBlocks
     configFilePath
     socketPath
-    Mainnet
+    Mainnet --(Testnet $ NetworkMagic 3)
     True -- enable validation?
-    (0 :: Int) -- We just use a count of the blocks as the current state
+    State {lastCheckpoint = 0, lastRewEpoch = 0}
     (\_env
       !ledgerState
-      (BlockInMode (Block (BlockHeader _slotNo _blockHeaderHash (BlockNo blockNoI)) _transactions) _era)
-      blockCount -> do
-        case ledgerState of
-            LedgerStateShelley (Shelley.ShelleyLedgerState shelleyTipWO _ _) -> case shelleyTipWO of
-              Origin -> putStrLn "."
-              At (Shelley.ShelleyTip _ _ hash) -> print hash
-            _ -> when (blockNoI `mod` 100 == 0) (print blockNoI)
-        return (blockCount + 1)
+      (BlockInMode (Block (BlockHeader (SlotNo slotNo) _blockHeaderHash (BlockNo _blockNoI)) transactions) _era)
+      state -> do
+        let go = L.unStake . L._stake . L._pstakeGo . L.esSnapshots . L.nesEs
+        let cps = read checkpointSize
+        let (name, info) =
+              case ledgerState of
+                LedgerStateByron _                                     ->
+                  ("byron", Nothing)
+                LedgerStateShelley (Shelley.ShelleyLedgerState _ ls _) ->
+                  ( "shelley", Just (L.nesEL ls, L.nesRu ls, go ls))
+                LedgerStateAllegra (Shelley.ShelleyLedgerState _ ls _) ->
+                  ( "allegra", Just (L.nesEL ls, L.nesRu ls, go ls))
+                LedgerStateMary    (Shelley.ShelleyLedgerState _ ls _) ->
+                  ( "mary",    Just (L.nesEL ls, L.nesRu ls, go ls))
+
+        displayCheckpoint name slotNo (lastCheckpoint state) cps
+        mapM_ (displayDeleg target slotNo . getTxBody) transactions
+
+        let lc = if newCheckpoint slotNo (lastCheckpoint state) cps then slotNo else (lastCheckpoint state)
+        e <- case info of
+                Just (ep, L.SJust (L.Complete ru), goSnap) ->
+                  dispReward (lastRewEpoch state) ep (L.rs ru) goSnap target
+                _ -> return (lastRewEpoch state)
+
+        return State {lastCheckpoint = lc, lastRewEpoch = e}
     )
 
-  putStrLn $ "Processed " ++ show blockCount ++ " blocks"
   return ()
+  where
+    log :: Show a => String -> a -> IO ()
+    log title a = putStrLn $ title <> " " <> show a
+
+    newCheckpoint s lc cps = s - lc >= cps
+    displayCheckpoint era s lc cps = when (newCheckpoint s lc cps) (log ("CHECKPOINT-" <> era) s)
+
+    displayDeleg :: String -> Word64 -> TxBody era -> IO ()
+    displayDeleg _ _ (ByronTxBody _                               ) = return ()
+    displayDeleg t s (ShelleyTxBody ShelleyBasedEraShelley txb _ _) = displayFiltered t s $ L._certs txb
+    displayDeleg t s (ShelleyTxBody ShelleyBasedEraAllegra txb _ _) = displayFiltered t s $ MA.certs' txb
+    displayDeleg t s (ShelleyTxBody ShelleyBasedEraMary    txb _ _) = displayFiltered t s $ MA.certs' txb
+
+    dispCert s c = log "DELEG" (s, c)
+    displayFiltered t s cs = mapM_ (dispCert s) $ filter (onlyTarget t) (toList cs)
+
+    isTarget t (L.KeyHashObj    (L.KeyHash    kh)) = (tail . init . show) kh == t
+    isTarget t (L.ScriptHashObj (L.ScriptHash sh)) = (tail . init . show) sh == t
+
+    onlyTarget t (L.DCertDeleg (L.RegKey cred))                    = isTarget t cred
+    onlyTarget t (L.DCertDeleg (L.DeRegKey cred))                  = isTarget t cred
+    onlyTarget t (L.DCertDeleg (L.Delegate (L.Delegation cred _))) = isTarget t cred
+    onlyTarget t _ = False
+
+    dispReward el (EpochNo e) rs ss t =
+      if el < e
+        then
+          log "REWARD" (e-1, Map.filterWithKey (\k _ -> isTarget t k) rs)
+            >> log "STAKE" (e-1, Map.filterWithKey (\k _ -> isTarget t k) ss)
+            >> return e
+        else return el

cardano-client-demo/cardano-client-demo.cabal

@@ -42,6 +42,7 @@ executable ledger-state
                        base16-bytestring,
                        bytestring,
                        containers,
+                       strict-containers,
                        filepath,
                        memory,
                        mtl,
@@ -66,4 +67,5 @@ executable ledger-state
                        ouroboros-consensus-byron,
                        ouroboros-consensus-shelley,
                        shelley-spec-ledger,
+                       cardano-ledger-shelley-ma,
                        typed-protocols,