Dependencies (upgrade to Cardano 10.5.1)

README.md

@@ -52,6 +52,22 @@ Next steps:
 cabal test
 ```
 
+N.B. Test data must be created in the following way (TODO: finish):
+* Install <https://github.com/cardano-foundation/testnet-generation-tool>
+* Use it to generate testnet config files (no need to deploy testnet)
+* Fix the config.json by hand for some fields ("LedgerDB", "DijkstraGenesisFile") by looking at recent config files in cardano-node and ouroboros-consensus
+* Use db-synthesizer (from <https://github.com/IntersectMBO/ouroboros-consensus>) to generate a db using the config and keys generated by testnet-generation-tool.
+
+Testnet-generation-tool command used:
+
+```
+python3 genesis-cli.py example-config-testnet.yaml -o ../db-server/test-data/10.5.1 -c generate
+```
+
+```
+db-synthesizer --config configs/config.json --db db --shelley-operational-certificate keys/opcert.cert --shelley-vrf-key keys/vrf.skey --shelley-kes-key keys/kes.skey -b 3000
+```
+
 # Usage
 
 `db-server` can be used in two modes: as an HTTP server exposing some endpoints over an existing cardano-node DB, or as command-line query tool.
@@ -154,16 +170,17 @@ The last entry above with the `HttpServerListening` signals the database is open
 
 #### Retrieve snasphot
 
-* `GET /snapshots/:slot`: Retrieve raw hex-encoded CBOR bytes of ledger state at given `:slot`, if it exists
+* `GET /snapshots/:slot/:hash`: Retrieve raw hex-encoded CBOR bytes of ledger state at given point, if it exists
   * `200` : Returns hex-encoded bytes for the snapshot serialised as CBOR
   * `400` : Wrongly formatted `:slot`
+  * `400` : Wrongly formatted `:hash`
   * `404` : No snapshot exists at given slot
 
 
 **Example** (result is truncated for legibility, and the block is empty):
 
 ```
-% curl -v http://localhost:9003/snapshots/59737
+% curl -v http://localhost:9003/snapshots/59737/574a6ed18ccca232028a4b2632abdb7b99ef28adf25e58ee7392574fe69a4c74
 ...
 76ba082c604e6af7c482f716934ed08d19c227331b00071a1474e7f000f6
 ```

build.hs

@@ -45,7 +45,7 @@ install = do
 
 runShake :: FilePath -> UID -> IO ()
 runShake pwd uid = shakeArgs options $ do
-  let defaultNodeVersion = "10.1.4"
+  let defaultNodeVersion = "10.5.1"
       needHaskellSources = do
         needDirectoryFiles
           "."

cabal.project

@@ -14,9 +14,9 @@ repository cardano-haskell-packages
 -- update either of these.
 index-state:
   -- Bump this if you need newer packages from Hackage
-  , hackage.haskell.org 2024-12-10T16:20:07Z
+  , hackage.haskell.org 2025-10-01T11:47:07Z
   -- Bump this if you need newer packages from CHaP
-  , cardano-haskell-packages 2025-01-04T13:50:25Z
+  , cardano-haskell-packages 2025-09-30T09:59:24Z
 
 packages:
   .
@@ -26,3 +26,6 @@ tests: true
 benchmarks: true
 
 multi-repl: True
+
+constraints:
+  mempack ^>= 0.1.2

db-server.cabal

@@ -65,16 +65,18 @@ library
     cardano-crypto-class,
     cardano-ledger-api,
     cardano-ledger-binary,
+    cardano-ledger-core,
     cardano-slotting,
     contra-tracer,
     http-types,
     network,
     optparse-applicative,
-    ouroboros-consensus ^>= 0.21,
-    ouroboros-consensus-cardano,
+    ouroboros-consensus,
+    ouroboros-consensus-cardano ^>= 0.26,
     ouroboros-consensus-diffusion,
     ouroboros-consensus-cardano:unstable-cardano-tools,
     ouroboros-network-api,
+    resource-registry,
     QuickCheck,
     text,
     time,

src/Cardano/Tools/DB.hs

@@ -43,7 +43,7 @@ module Cardano.Tools.DB
 where
 
 import Cardano.Crypto.Hash (hashToBytes)
-import Cardano.Ledger.Api (StandardCrypto)
+import Cardano.Ledger.Crypto (StandardCrypto)
 import Cardano.Ledger.Binary (serialize)
 import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..))
 import Cardano.Tools.DBAnalyser.Block.Cardano (Args (CardanoBlockArgs))
@@ -64,7 +64,6 @@ import Ouroboros.Consensus.Block.RealPoint
 import Ouroboros.Consensus.Cardano (CardanoBlock)
 import Ouroboros.Consensus.Cardano.Block (LedgerState (..))
 import Ouroboros.Consensus.Config (configStorage)
-import Ouroboros.Consensus.Fragment.InFuture (dontCheck)
 import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (ledgerState))
 import qualified Ouroboros.Consensus.Node as Node
 import qualified Ouroboros.Consensus.Node.InitStorage as Node
@@ -74,15 +73,16 @@ import Ouroboros.Consensus.Shelley.Protocol.Abstract (ShelleyHash (..))
 import Ouroboros.Consensus.Storage.ChainDB (BlockComponent (..), ChainDB, IteratorResult (..), TraceEvent, defaultArgs, getBlockComponent, streamAll)
 import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
 import Ouroboros.Consensus.Storage.ChainDB.Impl.Args (completeChainDbArgs, updateTracer)
-import Ouroboros.Consensus.Storage.LedgerDB (Checkpoint (unCheckpoint), LedgerDB (..))
+import Ouroboros.Consensus.Storage.LedgerDB (LedgerDB (..), LedgerDbFlavorArgs (LedgerDbFlavorArgsV2))
 import Ouroboros.Consensus.Util.IOLike (atomically)
-import Ouroboros.Consensus.Util.ResourceRegistry (withRegistry)
+import Control.ResourceRegistry (withRegistry)
 import Ouroboros.Network.AnchoredSeq (lookupByMeasure)
 import qualified Ouroboros.Network.AnchoredSeq as Seq
 import Text.Read (readMaybe)
 import qualified Data.Aeson.Types as Aeson
 import qualified Data.Aeson.KeyMap as KeyMap
 import Data.Aeson.Types (fromJSON)
+import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2
 
 type StandardBlock = CardanoBlock StandardCrypto
 
@@ -132,6 +132,10 @@ withDB ::
   IO a
 withDB configurationFile databaseDir tracer k = do
   let args = CardanoBlockArgs configurationFile Nothing
+  ldbArgs <- parseLedgerDbConfig configurationFile >>= \case
+    Left err -> error $ "Failed to parse LedgerDB config: " ++ show err
+    Right cfg -> case backend cfg of
+      V2InMemory -> pure $ LedgerDbFlavorArgsV2 $ V2.V2Args V2.InMemoryHandleArgs
   protocolInfo <- mkProtocolInfo args
   withRegistry $ \registry -> do
     let ProtocolInfo {pInfoInitLedger = genesisLedger, pInfoConfig = cfg} = protocolInfo
@@ -140,13 +144,13 @@ withDB configurationFile databaseDir tracer k = do
           updateTracer tracer $
             completeChainDbArgs
               registry
-              dontCheck
               cfg
               genesisLedger
               chunkInfo
               (const True)
               (Node.stdMkChainDbHasFS databaseDir)
               (Node.stdMkChainDbHasFS databaseDir)
+              ldbArgs
               defaultArgs
     ChainDB.withDB chainDbArgs $ \chainDB -> k chainDB
 
@@ -197,34 +201,35 @@ getBlock :: ChainDB IO StandardBlock -> StandardPoint -> IO (Result LBS.ByteStri
 getBlock db point =
   maybe (Err NotFound) Found <$> getBlockComponent db GetRawBlock point
 
-pointOfState :: LedgerState StandardBlock -> StandardPoint
-pointOfState = \case
-  LedgerStateConway state ->
-    makePointOfState state
-  LedgerStateBabbage state ->
-    makePointOfState state
-  _ -> error "snapshots older than conway are not supported"
-  where
-    makePointOfState state =
-      case shelleyLedgerTip state of
-        At shelleyTip ->
-          RealPoint
-            (shelleyTipSlotNo shelleyTip)
-            ( fromRawHash (Proxy @StandardBlock)
-                . hashToBytes
-                . unShelleyHash @StandardCrypto
-                $ shelleyTipHash shelleyTip
-            )
-        Origin -> error "ledger state is at origin"
+--pointOfState :: LedgerState StandardBlock -> StandardPoint
+--pointOfState = \case
+--  LedgerStateConway state ->
+--    makePointOfState state
+--  LedgerStateBabbage state ->
+--    makePointOfState state
+--  _ -> error "snapshots older than conway are not supported"
+--  where
+--    makePointOfState state =
+--      case shelleyLedgerTip state of
+--        At shelleyTip ->
+--          RealPoint
+--            (shelleyTipSlotNo shelleyTip)
+--            ( fromRawHash (Proxy @StandardBlock)
+--                . hashToBytes
+--                . unShelleyHash @StandardCrypto
+--                $ shelleyTipHash shelleyTip
+--            )
+--        Origin -> error "ledger state is at origin"
 
 makeSlot :: Text -> Maybe SlotNo
 makeSlot slotTxt = fromInteger <$> readMaybe (Text.unpack slotTxt)
 
 listSnapshots :: ChainDB IO StandardBlock -> IO [StandardPoint]
 listSnapshots db = do
-  LedgerDB {ledgerDbCheckpoints} <- atomically $ ChainDB.getLedgerDB db
-  let snapshotsList :: [LedgerState StandardBlock] = ledgerState . unCheckpoint <$> Seq.toOldestFirst ledgerDbCheckpoints
-  pure $ pointOfState <$> snapshotsList
+  --LedgerDB {getPastLedgerState} <- atomically $ ChainDB.getCurrentLedger db
+  --let snapshotsList :: [LedgerState StandardBlock] = ledgerState . unCheckpoint <$> Seq.toOldestFirst getPastLedgerState
+  --pure $ pointOfState <$> snapshotsList
+  pure []
 
 listBlocks :: ChainDB IO StandardBlock -> IO [StandardPoint]
 listBlocks db = do
@@ -238,15 +243,12 @@ listBlocks db = do
         IteratorBlockGCed _ ->
           error "block on the current chain was garbage-collected"
 
-getSnapshot :: ChainDB IO StandardBlock -> SlotNo -> IO (Result LBS.ByteString)
-getSnapshot db slot = do
-  LedgerDB {ledgerDbCheckpoints} <- atomically $ ChainDB.getLedgerDB db
-  case lookupByMeasure (At slot) ledgerDbCheckpoints of
-    [snapshot] ->
-      case ledgerState $ unCheckpoint snapshot of
-        LedgerStateBabbage state ->
-          pure $ Found $ serialize (toEnum 10) $ shelleyLedgerState state
-        _other -> pure (Err UnknownStateType)
+getSnapshot :: ChainDB IO StandardBlock -> StandardPoint -> IO (Result LBS.ByteString)
+getSnapshot db point = do
+  maybeLedgerState <- atomically $ ChainDB.getPastLedger db $ realPointToPoint point
+  case ledgerState <$> maybeLedgerState of
+    Just (LedgerStateConway state) ->
+      pure $ Found $ serialize (toEnum 10) $ shelleyLedgerState state
     _other -> pure (Err NotFound)
 
 

src/Cardano/Tools/DBQuery.hs

@@ -81,7 +81,7 @@ runDBQuery db query = do
         GetBlock point -> getBlock db point
         GetHeader point -> getHeader db point
         GetParent point -> getParent db point
-        GetSnapshot slot -> getSnapshot db slot
+        GetSnapshot slot -> undefined -- getSnapshot db slot
         ListSnapshots -> Found . Aeson.encode <$> listSnapshots db
         ListBlocks -> Found . Aeson.encode <$> listBlocks db
 

src/Cardano/Tools/DBServer.hs

@@ -67,7 +67,7 @@ webApp :: ChainDB IO StandardBlock -> Application
 webApp db req send =
   case pathInfo req of
     ["snapshots"] -> handleGetSnapshots
-    ["snapshots", slot] -> handleGetSnapshot slot
+    ["snapshots", slot, hash] -> handleGetSnapshot slot hash
     ["blocks", slot, hash] -> handleGetBlock slot hash
     ["blocks", slot, hash, "header"] -> handleGetHeader slot hash
     ["blocks", slot, hash, "parent"] -> handleGetParent slot hash
@@ -92,19 +92,12 @@ webApp db req send =
 
     handleGetHeader = handleWithPoint getHeader
 
-    handleGetSnapshot slot =
-      case makeSlot slot of
-        Nothing -> send $ responseBadRequest "Malformed slot"
-        Just slot' ->
-          getSnapshot db slot' >>= \case
-            Err NotFound -> send responseNotFound
-            Err err -> send $ responseBadRequest ("Bad query: " <> toBytestring err)
-            Found snapshot -> send $ responseOk (LHex.encode snapshot)
-
     handleGetParent = handleWithPoint getParent
 
     handleGetBlock = handleWithPoint getBlock
 
+    handleGetSnapshot = handleWithPoint getSnapshot
+
 -- * Tracing
 
 withLog :: (ToJSON log) => Handle -> (Tracer IO log -> IO a) -> IO a