Skip to content

Commit 7d9c976

Browse files
abaillyabailly
committed
feat: can list all available points
1 parent aa01224 commit 7d9c976

4 files changed

Lines changed: 62 additions & 27 deletions

File tree

‎src/Cardano/Tools/DB.hs‎

Lines changed: 39 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,5 @@
11
{-# LANGUAGE DerivingStrategies #-}
2+
{-# LANGUAGE FlexibleContexts #-}
23
{-# LANGUAGE FlexibleInstances #-}
34
{-# LANGUAGE LambdaCase #-}
45
{-# LANGUAGE NamedFieldPuns #-}
@@ -14,6 +15,7 @@ module Cardano.Tools.DB
1415
StandardPoint,
1516
pattern StandardPoint,
1617
Result (..),
18+
DBError (..),
1719
DB,
1820
DBTrace,
1921
SlotNo,
@@ -24,11 +26,13 @@ module Cardano.Tools.DB
2426
getParent,
2527
getBlock,
2628
getSnapshot,
27-
getSnapshots,
29+
listSnapshots,
2830
parsePoint,
2931
makePoint,
3032
makeSlot,
3133
mkPoint,
34+
listBlocks,
35+
toBytestring,
3236
)
3337
where
3438

@@ -42,6 +46,7 @@ import Control.Tracer (Tracer (..))
4246
import Data.Aeson (FromJSON (..), ToJSON, object, toJSON, withObject, (.:), (.=))
4347
import qualified Data.ByteString.Base16 as Hex
4448
import qualified Data.ByteString.Lazy as LBS
49+
import Data.String (IsString (fromString))
4550
import Data.Text (Text)
4651
import qualified Data.Text as Text
4752
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
@@ -59,7 +64,7 @@ import qualified Ouroboros.Consensus.Node.InitStorage as Node
5964
import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolInfo (..))
6065
import Ouroboros.Consensus.Shelley.Ledger (LedgerState (shelleyLedgerState), ShelleyTip (..), shelleyLedgerTip)
6166
import Ouroboros.Consensus.Shelley.Protocol.Abstract (ShelleyHash (..))
62-
import Ouroboros.Consensus.Storage.ChainDB (BlockComponent (..), ChainDB, TraceEvent, defaultArgs, getBlockComponent)
67+
import Ouroboros.Consensus.Storage.ChainDB (BlockComponent (..), ChainDB, IteratorResult (..), TraceEvent, defaultArgs, getBlockComponent, streamAll)
6368
import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
6469
import Ouroboros.Consensus.Storage.ChainDB.Impl.Args (completeChainDbArgs, updateTracer)
6570
import Ouroboros.Consensus.Storage.LedgerDB (Checkpoint (unCheckpoint), LedgerDB (..))
@@ -149,26 +154,37 @@ makePoint slotTxt hashTxt =
149154
Right bytes -> Just $ RealPoint slot (fromRawHash (Proxy @StandardBlock) bytes)
150155
Left _ -> Nothing
151156

152-
data Result a = Malformed | NotFound | Found a
157+
data DBError
158+
= NotFound
159+
| Malformed
160+
| MalformedQuery Text
161+
| InitialHeader
162+
| UnknownStateType
163+
deriving stock (Eq, Show)
164+
165+
toBytestring :: (IsString s) => DBError -> s
166+
toBytestring = fromString . show
167+
168+
data Result a = Err DBError | Found a
153169
deriving stock (Eq, Show)
154170

155171
getHeader :: ChainDB IO StandardBlock -> StandardPoint -> IO (Result LBS.ByteString)
156172
getHeader db point =
157-
maybe NotFound Found <$> getBlockComponent db GetRawHeader point
173+
maybe (Err NotFound) Found <$> getBlockComponent db GetRawHeader point
158174

159175
getParent :: ChainDB IO StandardBlock -> StandardPoint -> IO (Result LBS.ByteString)
160176
getParent db point =
161177
getBlockComponent db GetHeader point >>= \case
162-
Nothing -> pure NotFound
178+
Nothing -> pure (Err NotFound)
163179
Just header ->
164180
case headerPrevHash header of
165181
BlockHash headerHash ->
166182
getHeader db (RealPoint (SlotNo 0) headerHash) -- FIXME
167-
GenesisHash -> pure Malformed
183+
GenesisHash -> pure (Err InitialHeader)
168184

169185
getBlock :: ChainDB IO StandardBlock -> StandardPoint -> IO (Result LBS.ByteString)
170186
getBlock db point =
171-
maybe NotFound Found <$> getBlockComponent db GetRawBlock point
187+
maybe (Err NotFound) Found <$> getBlockComponent db GetRawBlock point
172188

173189
pointOfState :: LedgerState StandardBlock -> StandardPoint
174190
pointOfState = \case
@@ -193,12 +209,24 @@ pointOfState = \case
193209
makeSlot :: Text -> Maybe SlotNo
194210
makeSlot slotTxt = fromInteger <$> readMaybe (Text.unpack slotTxt)
195211

196-
getSnapshots :: ChainDB IO StandardBlock -> IO [StandardPoint]
197-
getSnapshots db = do
212+
listSnapshots :: ChainDB IO StandardBlock -> IO [StandardPoint]
213+
listSnapshots db = do
198214
LedgerDB {ledgerDbCheckpoints} <- atomically $ ChainDB.getLedgerDB db
199215
let snapshotsList :: [LedgerState StandardBlock] = ledgerState . unCheckpoint <$> Seq.toOldestFirst ledgerDbCheckpoints
200216
pure $ pointOfState <$> snapshotsList
201217

218+
listBlocks :: ChainDB IO StandardBlock -> IO [StandardPoint]
219+
listBlocks db = do
220+
withRegistry $ \registry ->
221+
streamAll db registry GetHeader >>= go []
222+
where
223+
go acc iter = do
224+
ChainDB.iteratorNext iter >>= \case
225+
IteratorResult hdr -> go (headerRealPoint hdr : acc) iter
226+
IteratorExhausted -> pure acc
227+
IteratorBlockGCed _ ->
228+
error "block on the current chain was garbage-collected"
229+
202230
getSnapshot :: ChainDB IO StandardBlock -> SlotNo -> IO (Result LBS.ByteString)
203231
getSnapshot db slot = do
204232
LedgerDB {ledgerDbCheckpoints} <- atomically $ ChainDB.getLedgerDB db
@@ -207,5 +235,5 @@ getSnapshot db slot = do
207235
case ledgerState $ unCheckpoint snapshot of
208236
LedgerStateBabbage state ->
209237
pure $ Found $ serialize (toEnum 10) $ shelleyLedgerState state
210-
_other -> pure NotFound
211-
_other -> pure NotFound
238+
_other -> pure (Err UnknownStateType)
239+
_other -> pure (Err NotFound)

‎src/Cardano/Tools/DBQuery.hs‎

Lines changed: 9 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,7 @@ where
1616

1717
import Cardano.Tools.DB
1818
( DB,
19+
DBError (..),
1920
Result (..),
2021
SlotNo,
2122
StandardBlock,
@@ -24,7 +25,8 @@ import Cardano.Tools.DB
2425
getHeader,
2526
getParent,
2627
getSnapshot,
27-
getSnapshots,
28+
listBlocks,
29+
listSnapshots,
2830
makeSlot,
2931
parsePoint,
3032
withDB,
@@ -56,27 +58,28 @@ data Query
5658
| GetParent StandardPoint
5759
| GetSnapshot SlotNo
5860
| ListSnapshots
61+
| ListBlocks
5962
deriving (Eq, Show)
6063

6164
runQuery :: Tracer IO DBQueryLog -> FilePath -> FilePath -> Text -> IO ()
6265
runQuery tracer configurationFile databaseDirectory query =
6366
withDB configurationFile databaseDirectory (contramap DBLog tracer) $ \db ->
6467
runDBQuery db query >>= \case
65-
NotFound -> putStrLn $ "Not found"
66-
Malformed -> putStrLn $ "Malformed"
68+
Err err -> print err
6769
Found result -> LBS.putStr result
6870

6971
runDBQuery :: DB -> Text -> IO (Result LBS.ByteString)
7072
runDBQuery db query = do
7173
case parseQuery query of
72-
Left err -> pure $ Malformed
74+
Left _err -> pure $ Err (MalformedQuery query)
7375
Right q ->
7476
case q of
7577
GetBlock point -> getBlock db point
7678
GetHeader point -> getHeader db point
7779
GetParent point -> getParent db point
7880
GetSnapshot slot -> getSnapshot db slot
79-
ListSnapshots -> Found . Aeson.encode <$> getSnapshots db
81+
ListSnapshots -> Found . Aeson.encode <$> listSnapshots db
82+
ListBlocks -> Found . Aeson.encode <$> listBlocks db
8083

8184
parseQuery :: Text -> Either Error Query
8285
parseQuery str =
@@ -87,6 +90,7 @@ parseQuery str =
8790
["get-parent", point] -> withPoint GetParent point
8891
["get-snapshot", slot] -> withSlot GetSnapshot slot
8992
["list-snapshots"] -> Right ListSnapshots
93+
["list-blocks"] -> Right ListBlocks
9094
_ -> Left $ ParseError "Invalid query"
9195
where
9296
withPoint q point =

‎src/Cardano/Tools/DBServer.hs‎

Lines changed: 10 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -14,14 +14,13 @@
1414

1515
module Cardano.Tools.DBServer where
1616

17-
import Cardano.Tools.DB (Result (..), StandardBlock, getBlock, getHeader, getParent, getSnapshot, getSnapshots, makePoint, makeSlot, withDB)
17+
import Cardano.Tools.DB (DBError (..), Result (..), StandardBlock, getBlock, getHeader, getParent, getSnapshot, listSnapshots, makePoint, makeSlot, toBytestring, withDB)
1818
import Control.Monad (forever)
1919
import Control.Tracer (Tracer (..), contramap, traceWith)
2020
import Data.Aeson (FromJSON (..), ToJSON, Value (..), encode, object, toJSON, (.=))
2121
import qualified Data.Aeson.KeyMap as KeyMap
2222
import qualified Data.ByteString as BS
2323
import qualified Data.ByteString.Base16.Lazy as LHex
24-
import qualified Data.ByteString.Base64.Lazy as Base64
2524
import qualified Data.ByteString.Lazy as LBS
2625
import Data.Function ((&))
2726
import Data.String (fromString)
@@ -77,7 +76,7 @@ webApp db req send =
7776
responseNotFound = responseLBS status404 [] ""
7877

7978
handleGetSnapshots =
80-
getSnapshots db >>= \snapshotsPoints ->
79+
listSnapshots db >>= \snapshotsPoints ->
8180
send $
8281
responseLBS
8382
status200
@@ -90,17 +89,17 @@ webApp db req send =
9089
send $ responseLBS status400 [] "Malformed hash or slot"
9190
Just point ->
9291
getHeader db point >>= \case
93-
Malformed -> send $ responseLBS status400 [] "Malformed point"
94-
NotFound -> send responseNotFound
92+
Err NotFound -> send responseNotFound
93+
Err err -> send $ responseLBS status400 [] ("Bad query: " <> toBytestring err)
9594
Found header -> send $ responseLBS status200 [("content-type", "application/text")] (LHex.encode header)
9695

9796
handleGetSnapshot slot =
9897
case makeSlot slot of
9998
Nothing -> send $ responseLBS status400 [] "Malformed slot"
10099
Just slot' ->
101100
getSnapshot db slot' >>= \case
102-
Malformed -> send $ responseLBS status400 [] "Malformed slot"
103-
NotFound -> send responseNotFound
101+
Err NotFound -> send responseNotFound
102+
Err err -> send $ responseLBS status400 [] ("Bad query: " <> toBytestring err)
104103
Found snapshot ->
105104
send $
106105
responseLBS
@@ -114,8 +113,8 @@ webApp db req send =
114113
send $ responseLBS status400 [] "Malformed hash or slot"
115114
Just point ->
116115
getParent db point >>= \case
117-
NotFound -> send responseNotFound
118-
Malformed -> send $ responseLBS status400 [] "Malformed hash or slot"
116+
Err NotFound -> send responseNotFound
117+
Err err -> send $ responseLBS status400 [] ("Bad query: " <> toBytestring err)
119118
Found parent -> send $ responseLBS status200 [("content-type", "application/json")] (LHex.encode parent)
120119

121120
handleGetBlock slot hash = do
@@ -124,8 +123,8 @@ webApp db req send =
124123
send $ responseLBS status400 [] "Malformed hash or slot"
125124
Just point ->
126125
getBlock db point >>= \case
127-
NotFound -> send responseNotFound
128-
Malformed -> send $ responseLBS status400 [] "Malformed hash or slot"
126+
Err NotFound -> send responseNotFound
127+
Err err -> send $ responseLBS status400 [] ("Bad query: " <> toBytestring err)
129128
Found parent -> send $ responseLBS status200 [("content-type", "application/json")] (LHex.encode parent)
130129

131130
-- * Tracing

‎test/Cardano/Tools/DBQuerySpec.hs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -29,6 +29,10 @@ spec = do
2929
runDBQuery db "get-header 295.eeff5bd1eeea7fc2ccfc5e8e8b858e35b101eebc3cbe70b80c43502cb1c6e3c7"
3030
`shouldReturn` Found (either error id $ LHex.decode testHeaderHex)
3131

32+
it "allow listing all points from the DB" $ \db -> do
33+
Found json <- runDBQuery db "list-blocks"
34+
length <$> decode @[StandardPoint] json `shouldBe` Just 3000
35+
3236
it "allow querying header's parent by point" $ \db -> do
3337
Found bytes <- runDBQuery db "get-parent 295.eeff5bd1eeea7fc2ccfc5e8e8b858e35b101eebc3cbe70b80c43502cb1c6e3c7"
3438
let parentHash = hashToBytesAsHex $ hashWith @Blake2b_256 id $ LBS.toStrict bytes

0 commit comments

Comments
 (0)