WIP cardano ledger state converter

ouroboros-consensus-cardano-tools/app/CardanoLedgerStateConverter/Parsers.hs

@@ -0,0 +1,35 @@
+{-# LANGUAGE ApplicativeDo #-}
+
+module CardanoLedgerStateConverter.Parsers (parseCmdLine) where
+
+import           Options.Applicative
+import           Ouroboros.Consensus.Storage.LedgerDB.OnDisk (DiskSnapshot (..))
+import           Cardano.Tools.CardanoLedgerStateConverter.Types
+
+
+{-------------------------------------------------------------------------------
+  Parsing
+-------------------------------------------------------------------------------}
+
+parseCmdLine :: Parser Config
+parseCmdLine = Config
+    <$> strOption (mconcat [
+            long "db"
+          , help "Path to the Chain DB"
+          , metavar "PATH"
+          ])
+    <*> parseSelectDB
+
+parseSelectDB :: Parser SelectDB
+parseSelectDB = SelectImmutableDB . snd <$> ((,) <$> onlyImmutableDB <*> analyseFrom)
+  where
+    onlyImmutableDB = flag' () (mconcat [
+        long "only-immutable-db"
+      , help "Validate only the Immutable DB (e.g. do not do ledger validation)"
+      ])
+
+    analyseFrom :: Parser (Maybe DiskSnapshot)
+    analyseFrom = optional $ ((flip DiskSnapshot $ Just "db-analyser") . read) <$> strOption
+      (  long "analyse-from"
+      <> metavar "SLOT_NUMBER"
+      <> help "Start analysis from ledger state stored at specific slot number" )

ouroboros-consensus-cardano-tools/app/cardano-ledger-state-converter.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Main (main) where
+
+import           CardanoLedgerStateConverter.Parsers
+
+import           Options.Applicative (execParser, fullDesc, helper, info,
+                     progDesc, (<**>))
+
+import           Cardano.Tools.CardanoLedgerStateConverter.Run
+import           Cardano.Tools.CardanoLedgerStateConverter.Types
+
+
+main :: IO ()
+main = getCmdLine >>= analyse
+
+getCmdLine :: IO Config
+getCmdLine = execParser opts
+  where
+    opts = info (parseCmdLine <**> helper) (mconcat [
+          fullDesc
+        , progDesc "Convert a ledger snapshot to a CBOR encoded NewEpochState"
+        ])

ouroboros-consensus-cardano-tools/ouroboros-consensus-cardano-tools.cabal

@@ -32,6 +32,8 @@ library
     Cardano.Node.Protocol
     Cardano.Node.Protocol.Types
     Cardano.Node.Types
+    Cardano.Tools.CardanoLedgerStateConverter.Run
+    Cardano.Tools.CardanoLedgerStateConverter.Types
     Cardano.Tools.DBAnalyser.Analysis
     Cardano.Tools.DBAnalyser.Block.Byron
     Cardano.Tools.DBAnalyser.Block.Cardano
@@ -148,6 +150,32 @@ executable db-synthesizer
     -Wredundant-constraints -Wmissing-export-lists -Wunused-packages
     -O2 -threaded -rtsopts "-with-rtsopts=-N -I0 -A16m"
 
+executable cardano-ledger-state-converter
+  hs-source-dirs:      app
+  main-is:             cardano-ledger-state-converter.hs
+  build-depends:       base
+                     , cardano-crypto-wrapper
+                     , optparse-applicative
+                     , ouroboros-consensus
+                     , ouroboros-consensus-byron
+                     , ouroboros-consensus-cardano-tools
+                     , ouroboros-consensus-shelley
+
+  other-modules:     CardanoLedgerStateConverter.Parsers
+
+  default-language:    Haskell2010
+  ghc-options:         -Wall
+                       -Wcompat
+                       -Wincomplete-uni-patterns
+                       -Wincomplete-record-updates
+                       -Wpartial-fields
+                       -Widentities
+                       -Wredundant-constraints
+                       -Wmissing-export-lists
+                       -threaded
+                       -rtsopts
+                       "-with-rtsopts=-T -I0 -N2 -A16m"
+
 test-suite test
   type:             exitcode-stdio-1.0
   hs-source-dirs:   test

ouroboros-consensus-cardano-tools/src/Cardano/Tools/CardanoLedgerStateConverter/Run.hs

@@ -0,0 +1,109 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE GADTs          #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Cardano.Tools.CardanoLedgerStateConverter.Run (analyse) where
+
+import           Codec.CBOR.Decoding (Decoder)
+import           Codec.Serialise (Serialise (decode))
+import           Control.Monad.Except (runExceptT)
+
+import           Ouroboros.Consensus.Config
+import           Ouroboros.Consensus.Ledger.Extended
+import qualified Ouroboros.Consensus.Node as Node
+import           Ouroboros.Consensus.Storage.Serialisation (DecodeDisk (..))
+import           Ouroboros.Consensus.Util.Orphans ()
+
+import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
+import           Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy
+                     (SnapshotInterval (..), defaultDiskPolicy)
+import           Ouroboros.Consensus.Storage.LedgerDB.OnDisk (readSnapshot)
+
+import           Cardano.Tools.CardanoLedgerStateConverter.Types
+
+import           Cardano.Ledger.Crypto (StandardCrypto)
+import qualified Cardano.Ledger.Allegra as SL
+import qualified Cardano.Ledger.Alonzo as SL
+import qualified Cardano.Ledger.Babbage as SL
+import qualified Cardano.Ledger.Mary as SL
+import qualified Cardano.Ledger.Shelley as SL
+import qualified Cardano.Ledger.Shelley.API as SL
+import           Ouroboros.Consensus.Cardano (CardanoBlock)
+import qualified Ouroboros.Consensus.Cardano.Block as Cardano
+import qualified Ouroboros.Consensus.Ledger.Basics as Consensus
+import qualified Ouroboros.Consensus.Ledger.Extended as Consensus
+import           Ouroboros.Consensus.Shelley.Ledger (shelleyLedgerState)
+import           Ouroboros.Consensus.Shelley.Ledger.Config (CodecConfig (ShelleyCodecConfig))
+import           Ouroboros.Consensus.Byron.Ledger.Config (CodecConfig (ByronCodecConfig))
+import           Cardano.Binary (ToCBOR (..), serialize')
+import           Cardano.Chain.Slotting (EpochSlots(..))
+import qualified Data.ByteString as BS
+import           Cardano.Tools.DBAnalyser.Block.Cardano ()
+
+
+data AnyShelleyEra c era where
+    ShelleyEra :: AnyShelleyEra c (SL.ShelleyEra c)
+    AllegraEra :: AnyShelleyEra c (SL.AllegraEra c)
+    MaryEra    :: AnyShelleyEra c (SL.MaryEra    c)
+    AlonzoEra  :: AnyShelleyEra c (SL.AlonzoEra  c)
+    BabbageEra :: AnyShelleyEra c (SL.BabbageEra c)
+
+data SomeNewEpochState where
+    SomeNewEpochState ::
+         !(AnyShelleyEra StandardCrypto era)
+      -> !(SL.NewEpochState era)
+      -> SomeNewEpochState
+
+instance ToCBOR SomeNewEpochState where
+  toCBOR (SomeNewEpochState AlonzoEra nes) = toCBOR nes
+  toCBOR _ = error "dont look back"
+
+-- | Returns @Nothing@ only for a Cardano ledger state in the Byron era
+projectNewEpochState ::
+     Consensus.ExtLedgerState (CardanoBlock StandardCrypto)
+  -> Maybe SomeNewEpochState
+projectNewEpochState extLedgerState =
+    case ledgerState of
+      Cardano.LedgerStateByron{}   -> Nothing
+      Cardano.LedgerStateShelley x -> f ShelleyEra x
+      Cardano.LedgerStateAllegra x -> f AllegraEra x
+      Cardano.LedgerStateMary    x -> f MaryEra    x
+      Cardano.LedgerStateAlonzo  x -> f AlonzoEra  x
+      Cardano.LedgerStateBabbage x -> f BabbageEra x
+  where
+    ledgerState :: Consensus.LedgerState (CardanoBlock StandardCrypto)
+    Consensus.ExtLedgerState {Consensus.ledgerState} = extLedgerState
+
+    f era = Just . SomeNewEpochState era . shelleyLedgerState
+
+analyse :: Config -> IO ()
+analyse Config{dbDir, selectDB} = do
+      let diskPolicy = defaultDiskPolicy (SecurityParam 0) DefaultSnapshotInterval
+          args' = ChainDB.defaultArgs (Node.stdMkChainDbHasFS dbDir) diskPolicy
+          ledgerDbFS = ChainDB.cdbHasFSLgrDB args'
+
+      case selectDB of
+        SelectImmutableDB initializeFrom -> do
+          initLedgerErr <- runExceptT $ case initializeFrom of
+            Nothing       -> error "no snapshot given"
+            Just snapshot -> readSnapshot ledgerDbFS decodeExtLedgerState' decode snapshot
+          initLedger <- either (error . show) pure initLedgerErr
+          case projectNewEpochState initLedger of
+            Nothing -> error "failed to get ledger state from extended ledger state"
+            Just ls -> BS.writeFile "newEpochState.cbor" (serialize' ls)
+  where
+    decodeExtLedgerState' :: forall s .Decoder s (ExtLedgerState (CardanoBlock StandardCrypto))
+    decodeExtLedgerState' =
+      let ccfg =
+            Cardano.CardanoCodecConfig
+              (ByronCodecConfig (EpochSlots 0))
+              ShelleyCodecConfig
+              ShelleyCodecConfig
+              ShelleyCodecConfig
+              ShelleyCodecConfig
+              ShelleyCodecConfig
+      in decodeExtLedgerState
+           (decodeDisk @(CardanoBlock StandardCrypto) ccfg)
+           (decodeDisk @(CardanoBlock StandardCrypto) ccfg)
+           (decodeDisk @(CardanoBlock StandardCrypto) ccfg)

ouroboros-consensus-cardano-tools/src/Cardano/Tools/CardanoLedgerStateConverter/Types.hs

@@ -0,0 +1,15 @@
+
+module Cardano.Tools.CardanoLedgerStateConverter.Types
+  ( SelectDB (..)
+  , Config (..)
+  ) where
+
+import           Ouroboros.Consensus.Storage.LedgerDB.OnDisk (DiskSnapshot)
+
+
+data SelectDB = SelectImmutableDB (Maybe DiskSnapshot)
+
+data Config = Config {
+    dbDir      :: FilePath
+  , selectDB   :: SelectDB
+  }