Skip to content

Commit fea90ac

Browse files
jasagredojasagredo
committed
Adapt cardano-tools to use the types from the extracted sublibraries
1 parent bf42d6c commit fea90ac

File tree

7 files changed

+231
-103
lines changed

7 files changed

+231
-103
lines changed

‎ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs‎

Lines changed: 1 addition & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -43,12 +43,7 @@ parseDBAnalyserConfig =
4343
<*> parseAnalysis
4444
<*> parseLimit
4545
<*> Foldable.asum
46-
[ flag' V1InMem $
47-
mconcat
48-
[ long "v1-in-mem"
49-
, help "use v1 in-memory backing store [deprecated]"
50-
]
51-
, flag' V1LMDB $
46+
[ flag' V1LMDB $
5247
mconcat
5348
[ long "lmdb"
5449
, help "use v1 LMDB backing store"

‎ouroboros-consensus-cardano/app/Ouroboros/Consensus/Cardano/StreamingLedgerTables.hs‎

Lines changed: 114 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,114 @@
1+
{-# LANGUAGE ScopedTypeVariables #-}
2+
{-# LANGUAGE TypeApplications #-}
3+
{-# LANGUAGE TypeOperators #-}
4+
5+
module Ouroboros.Consensus.Cardano.StreamingLedgerTables
6+
( mkInMemYieldArgs
7+
, mkInMemSinkArgs
8+
) where
9+
10+
import Cardano.Ledger.Binary
11+
import Cardano.Ledger.Core (ByronEra, Era, eraDecoder, toEraCBOR)
12+
import qualified Cardano.Ledger.Shelley.API as SL
13+
import qualified Cardano.Ledger.Shelley.LedgerState as SL
14+
import qualified Cardano.Ledger.State as SL
15+
import qualified Codec.CBOR.Encoding
16+
import Control.ResourceRegistry
17+
import Data.Proxy
18+
import Data.SOP.BasicFunctors
19+
import Data.SOP.Functors
20+
import Data.SOP.Strict
21+
import qualified Data.SOP.Telescope as Telescope
22+
import Lens.Micro
23+
import Ouroboros.Consensus.Byron.Ledger
24+
import Ouroboros.Consensus.Cardano.Block
25+
import Ouroboros.Consensus.Cardano.Ledger
26+
import Ouroboros.Consensus.HardFork.Combinator
27+
import Ouroboros.Consensus.HardFork.Combinator.State
28+
import Ouroboros.Consensus.Ledger.Abstract
29+
import Ouroboros.Consensus.Shelley.Ledger
30+
import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol ()
31+
import Ouroboros.Consensus.Storage.LedgerDB.API
32+
import Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as V2
33+
import System.Directory
34+
import System.FS.API
35+
import System.FS.IO
36+
37+
type L = LedgerState (CardanoBlock StandardCrypto)
38+
39+
mkInMemYieldArgs :: FilePath -> L EmptyMK -> ResourceRegistry IO -> IO (YieldArgs IO V2.Mem L)
40+
mkInMemYieldArgs fp (HardForkLedgerState (HardForkState idx)) _ =
41+
let
42+
np ::
43+
NP
44+
(Current (Flip LedgerState EmptyMK) -.-> K (Decoders L))
45+
(CardanoEras StandardCrypto)
46+
np =
47+
(Fn $ const $ K $ error "Byron")
48+
:* (Fn $ K . fromEra ShelleyTxOut . unFlip . currentState)
49+
:* (Fn $ K . fromEra AllegraTxOut . unFlip . currentState)
50+
:* (Fn $ K . fromEra MaryTxOut . unFlip . currentState)
51+
:* (Fn $ K . fromEra AlonzoTxOut . unFlip . currentState)
52+
:* (Fn $ K . fromEra BabbageTxOut . unFlip . currentState)
53+
:* (Fn $ K . fromEra ConwayTxOut . unFlip . currentState)
54+
:* (Fn $ K . fromEra DijkstraTxOut . unFlip . currentState)
55+
:* Nil
56+
in
57+
pure $
58+
YieldInMemory
59+
(SomeHasFS . ioHasFS)
60+
fp
61+
(hcollapse $ hap np $ Telescope.tip idx)
62+
where
63+
fromEra ::
64+
forall proto era.
65+
ShelleyCompatible proto era =>
66+
(TxOut (LedgerState (ShelleyBlock proto era)) -> CardanoTxOut StandardCrypto) ->
67+
LedgerState (ShelleyBlock proto era) EmptyMK ->
68+
Decoders L
69+
fromEra toCardanoTxOut st =
70+
let certInterns =
71+
internsFromMap $
72+
shelleyLedgerState st
73+
^. SL.nesEsL
74+
. SL.esLStateL
75+
. SL.lsCertStateL
76+
. SL.certDStateL
77+
. SL.accountsL
78+
. SL.accountsMapL
79+
in Decoders
80+
(eraDecoder @era decodeMemPack)
81+
(eraDecoder @era $ toCardanoTxOut <$> decShareCBOR certInterns)
82+
83+
mkInMemSinkArgs ::
84+
FilePath ->
85+
L EmptyMK ->
86+
ResourceRegistry IO ->
87+
IO (SinkArgs IO V2.Mem L)
88+
mkInMemSinkArgs fp (HardForkLedgerState (HardForkState idx)) _ = do
89+
currDir <- getCurrentDirectory
90+
let
91+
np =
92+
(Fn $ const $ K $ encOne (Proxy @ByronEra))
93+
:* (Fn $ const $ K $ encOne (Proxy @ShelleyEra))
94+
:* (Fn $ const $ K $ encOne (Proxy @AllegraEra))
95+
:* (Fn $ const $ K $ encOne (Proxy @MaryEra))
96+
:* (Fn $ const $ K $ encOne (Proxy @AlonzoEra))
97+
:* (Fn $ const $ K $ encOne (Proxy @BabbageEra))
98+
:* (Fn $ const $ K $ encOne (Proxy @ConwayEra))
99+
:* (Fn $ const $ K $ encOne (Proxy @DijkstraEra))
100+
:* Nil
101+
pure $
102+
uncurry
103+
(SinkInMemory 1000)
104+
(hcollapse $ hap np $ Telescope.tip idx)
105+
(SomeHasFS $ ioHasFS $ MountPoint currDir)
106+
fp
107+
where
108+
encOne ::
109+
forall era.
110+
Era era =>
111+
Proxy era ->
112+
(TxIn L -> Codec.CBOR.Encoding.Encoding, TxOut L -> Codec.CBOR.Encoding.Encoding)
113+
encOne _ =
114+
(toEraCBOR @era . encodeMemPack, toEraCBOR @era . eliminateCardanoTxOut (const encodeMemPack))

‎ouroboros-consensus-cardano/app/snapshot-converter.hs‎

Lines changed: 43 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,10 @@
11
{-# LANGUAGE DeriveAnyClass #-}
22
{-# LANGUAGE FlexibleContexts #-}
3+
{-# LANGUAGE GADTs #-}
34
{-# LANGUAGE LambdaCase #-}
45
{-# LANGUAGE OverloadedStrings #-}
56
{-# LANGUAGE RecordWildCards #-}
7+
{-# LANGUAGE ScopedTypeVariables #-}
68
{-# LANGUAGE TupleSections #-}
79
{-# LANGUAGE TypeApplications #-}
810
{-# LANGUAGE ViewPatterns #-}
@@ -30,11 +32,12 @@ import Ouroboros.Consensus.Config
3032
import Ouroboros.Consensus.Ledger.Basics
3133
import Ouroboros.Consensus.Ledger.Extended
3234
import Ouroboros.Consensus.Node.ProtocolInfo
35+
import Ouroboros.Consensus.Storage.LedgerDB.API
3336
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
3437
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as V1
38+
import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM
3539
import Ouroboros.Consensus.Util.CRC
36-
import Ouroboros.Consensus.Util.IOLike
37-
import Ouroboros.Consensus.Util.StreamingLedgerTables
40+
import Ouroboros.Consensus.Util.IOLike hiding (yield)
3841
import System.Console.ANSI
3942
import qualified System.Directory as D
4043
import System.Exit
@@ -45,6 +48,7 @@ import System.FilePath (splitDirectories)
4548
import qualified System.FilePath as F
4649
import System.IO
4750
import System.ProgressBar
51+
import System.Random
4852

4953
data Format
5054
= Mem FilePath
@@ -215,24 +219,29 @@ instance StandardHash blk => Show (Error blk) where
215219
["Error when reading entries in the UTxO tables: ", show df]
216220
show Cancelled = "Cancelled"
217221

218-
data InEnv = InEnv
222+
data InEnv backend = InEnv
219223
{ inState :: LedgerState (CardanoBlock StandardCrypto) EmptyMK
220224
, inFilePath :: FilePath
221225
, inStream ::
222226
LedgerState (CardanoBlock StandardCrypto) EmptyMK ->
223227
ResourceRegistry IO ->
224-
IO (YieldArgs (LedgerState (CardanoBlock StandardCrypto)) IO)
228+
IO (SomeBackend YieldArgs)
225229
, inProgressMsg :: String
226230
, inCRC :: CRC
227231
, inSnapReadCRC :: Maybe CRC
228232
}
229233

230-
data OutEnv = OutEnv
234+
data SomeBackend c where
235+
SomeBackend ::
236+
StreamingBackend IO backend (LedgerState (CardanoBlock StandardCrypto)) =>
237+
c IO backend (LedgerState (CardanoBlock StandardCrypto)) -> SomeBackend c
238+
239+
data OutEnv backend = OutEnv
231240
{ outFilePath :: FilePath
232241
, outStream ::
233242
LedgerState (CardanoBlock StandardCrypto) EmptyMK ->
234243
ResourceRegistry IO ->
235-
IO (SinkArgs (LedgerState (CardanoBlock StandardCrypto)) IO)
244+
IO (SomeBackend SinkArgs)
236245
, outCreateExtra :: Maybe FilePath
237246
, outDeleteExtra :: Maybe FilePath
238247
, outProgressMsg :: String
@@ -356,7 +365,7 @@ main = withStdTerminalHandles $ do
356365
InEnv
357366
st
358367
fp
359-
(fromInMemory (fp F.</> "tables" F.</> "tvar"))
368+
(\a b -> SomeBackend <$> mkInMemYieldArgs (fp F.</> "tables" F.</> "tvar") a b)
360369
("InMemory@[" <> fp <> "]")
361370
c
362371
mtd
@@ -375,7 +384,7 @@ main = withStdTerminalHandles $ do
375384
InEnv
376385
st
377386
fp
378-
(fromLMDB (fp F.</> "tables") defaultLMDBLimits)
387+
(\a b -> SomeBackend <$> V1.mkLMDBYieldArgs (fp F.</> "tables") defaultLMDBLimits a b)
379388
("LMDB@[" <> fp <> "]")
380389
c
381390
mtd
@@ -394,7 +403,9 @@ main = withStdTerminalHandles $ do
394403
InEnv
395404
st
396405
fp
397-
(fromLSM lsmDbPath (last $ splitDirectories fp))
406+
( \a b ->
407+
SomeBackend <$> mkLSMYieldArgs lsmDbPath (last $ splitDirectories fp) stdMkBlockIOFS newStdGen a b
408+
)
398409
("LSM@[" <> lsmDbPath <> "]")
399410
c
400411
mtd
@@ -412,7 +423,7 @@ main = withStdTerminalHandles $ do
412423
pure $
413424
OutEnv
414425
fp
415-
(toInMemory (fp F.</> "tables" F.</> "tvar"))
426+
(\a b -> SomeBackend <$> mkInMemSinkArgs (fp F.</> "tables" F.</> "tvar") a b)
416427
(Just "tables")
417428
(Nothing)
418429
("InMemory@[" <> fp <> "]")
@@ -429,7 +440,7 @@ main = withStdTerminalHandles $ do
429440
pure $
430441
OutEnv
431442
fp
432-
(toLMDB fp defaultLMDBLimits)
443+
(\a b -> SomeBackend <$> V1.mkLMDBSinkArgs fp defaultLMDBLimits a b)
433444
Nothing
434445
Nothing
435446
("LMDB@[" <> fp <> "]")
@@ -446,12 +457,32 @@ main = withStdTerminalHandles $ do
446457
pure $
447458
OutEnv
448459
fp
449-
(toLSM lsmDbPath (last $ splitDirectories fp))
460+
( \a b ->
461+
SomeBackend <$> mkLSMSinkArgs lsmDbPath (last $ splitDirectories fp) stdMkBlockIOFS newStdGen a b
462+
)
450463
Nothing
451464
(Just lsmDbPath)
452465
("LSM@[" <> lsmDbPath <> "]")
453466
UTxOHDLSMSnapshot
454467

468+
stream ::
469+
LedgerState (CardanoBlock StandardCrypto) EmptyMK ->
470+
( LedgerState (CardanoBlock StandardCrypto) EmptyMK ->
471+
ResourceRegistry IO ->
472+
IO (SomeBackend YieldArgs)
473+
) ->
474+
( LedgerState (CardanoBlock StandardCrypto) EmptyMK ->
475+
ResourceRegistry IO ->
476+
IO (SomeBackend SinkArgs)
477+
) ->
478+
ExceptT DeserialiseFailure IO (Maybe CRC, Maybe CRC)
479+
stream st mYieldArgs mSinkArgs =
480+
ExceptT $
481+
withRegistry $ \reg -> do
482+
(SomeBackend (yArgs :: YieldArgs IO backend1 l)) <- mYieldArgs st reg
483+
(SomeBackend (sArgs :: SinkArgs IO backend2 l)) <- mSinkArgs st reg
484+
runExceptT $ yield (Proxy @backend1) yArgs st $ sink (Proxy @backend2) sArgs st
485+
455486
-- Helpers
456487

457488
-- UI

‎ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal‎

Lines changed: 14 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -585,7 +585,7 @@ library unstable-cardano-tools
585585
network,
586586
network-mux,
587587
nothunks,
588-
ouroboros-consensus ^>=0.27,
588+
ouroboros-consensus:{ouroboros-consensus, ouroboros-consensus-lmdb, ouroboros-consensus-lsm} ^>=0.27,
589589
ouroboros-consensus-cardano,
590590
ouroboros-consensus-diffusion ^>=0.23,
591591
ouroboros-consensus-protocol:{ouroboros-consensus-protocol, unstable-protocol-testlib} ^>=0.12,
@@ -693,21 +693,33 @@ executable immdb-server
693693
executable snapshot-converter
694694
import: common-exe
695695
hs-source-dirs: app
696+
other-modules:
697+
Ouroboros.Consensus.Cardano.StreamingLedgerTables
698+
696699
main-is: snapshot-converter.hs
697700
build-depends:
698701
ansi-terminal,
699702
base,
700703
cardano-crypto-class,
704+
cardano-ledger-binary,
705+
cardano-ledger-core,
706+
cardano-ledger-shelley,
707+
cborg,
701708
directory,
702709
filepath,
703710
fs-api,
711+
microlens,
704712
mtl,
705713
optparse-applicative,
706-
ouroboros-consensus,
714+
ouroboros-consensus:{ouroboros-consensus, ouroboros-consensus-lmdb, ouroboros-consensus-lsm},
707715
ouroboros-consensus-cardano,
708716
ouroboros-consensus-cardano:unstable-cardano-tools,
717+
random,
709718
resource-registry,
710719
serialise,
720+
sop-core,
721+
sop-extras,
722+
strict-sop-core,
711723
terminal-progress-bar,
712724
text,
713725
with-utf8,

0 commit comments

Comments
 (0)