Skip to content

Commit aca5dee

Browse files
qnikstqnikst
committed
conway:scls-export
1 parent 766caa1 commit aca5dee

File tree

7 files changed

+471
-3
lines changed

7 files changed

+471
-3
lines changed

‎cabal.project‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -101,16 +101,16 @@ source-repository-package
101101
type: git
102102
location: https://github.com/tweag/cardano-canonical-ledger.git
103103
subdir: scls-cbor
104-
tag: 7e0344dad0ff156d4a3932f1c73dc54379a50c51
104+
tag: 09f2b80d6d0c7419053e3f9e70ff57acbcff0eec
105105

106106
source-repository-package
107107
type: git
108108
location: https://github.com/tweag/cardano-canonical-ledger.git
109109
subdir: scls-format
110-
tag: 7e0344dad0ff156d4a3932f1c73dc54379a50c51
110+
tag: 09f2b80d6d0c7419053e3f9e70ff57acbcff0eec
111111

112112
source-repository-package
113113
type: git
114114
location: https://github.com/tweag/cardano-canonical-ledger.git
115115
subdir: merkle-tree-incremental
116-
tag: 7e0344dad0ff156d4a3932f1c73dc54379a50c51
116+
tag: 09f2b80d6d0c7419053e3f9e70ff57acbcff0eec

‎eras/conway/impl/cardano-ledger-conway.cabal‎

Lines changed: 48 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -208,6 +208,54 @@ library testlib
208208
time,
209209
tree-diff,
210210

211+
library scls-export
212+
exposed-modules:
213+
Cardano.Ledger.Export.Namespace.UTxO
214+
visibility: public
215+
hs-source-dirs: scls-export/src
216+
default-language: Haskell2010
217+
ghc-options:
218+
-Wall
219+
-Wcompat
220+
-Wincomplete-record-updates
221+
-Wincomplete-uni-patterns
222+
-Wpartial-fields
223+
-Wredundant-constraints
224+
-Wunused-packages
225+
226+
build-depends:
227+
-- cardano-data:{cardano-data},
228+
cardano-ledger-allegra,
229+
cardano-ledger-alonzo:{cardano-ledger-alonzo},
230+
cardano-ledger-babbage:{cardano-ledger-babbage},
231+
cardano-ledger-binary:{cardano-ledger-binary},
232+
-- cardano-ledger-byron:{cardano-ledger-byron},
233+
cardano-ledger-conway:{cardano-ledger-conway},
234+
cardano-ledger-core:{cardano-ledger-core},
235+
cardano-ledger-mary:{cardano-ledger-mary},
236+
cardano-ledger-shelley:{cardano-ledger-shelley},
237+
-- cardano-slotting:{cardano-slotting},
238+
-- cardano-strict-containers,
239+
cborg,
240+
-- containers,
241+
-- cuddle >=0.4,
242+
-- data-default,
243+
-- deepseq,
244+
-- generic-random,
245+
-- heredoc,
246+
-- kmicrolens,
247+
mempack,
248+
-- microlens-mtl,
249+
-- mtl,
250+
-- plutus-ledger-api,
251+
-- prettyprinter,
252+
-- small-steps >=1.1,
253+
-- text,
254+
base,
255+
scls-cbor,
256+
scls-format,
257+
-- time
258+
211259
executable huddle-cddl
212260
main-is: Main.hs
213261
hs-source-dirs: huddle-cddl

‎eras/conway/impl/scls-export/src/Cardano/Ledger/Export/Namespace/UTxO.hs‎

Lines changed: 244 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,244 @@
1+
{-# LANGUAGE LambdaCase #-}
2+
{-# LANGUAGE DataKinds #-}
3+
{-# LANGUAGE StandaloneDeriving #-}
4+
{-# LANGUAGE DerivingVia #-}
5+
{-# LANGUAGE RecordWildCards #-}
6+
{-# LANGUAGE MultiParamTypeClasses #-}
7+
{-# LANGUAGE FlexibleInstances #-}
8+
{-# LANGUAGE FlexibleContexts #-}
9+
{-# LANGUAGE KindSignatures #-}
10+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
11+
{-# OPTIONS_GHC -Wno-orphans #-}
12+
-- | UTxO namespace export.
13+
module Cardano.Ledger.Export.Namespace.UTxO
14+
( UtxoKey(..)
15+
, UtxoOut(..)
16+
, AddrUtxoIn(..)
17+
, ScriptUtxoIn(..)
18+
, Version(..)
19+
, ToCanonicalCBOR(..)
20+
, FromCanonicalCBOR(..)
21+
) where
22+
23+
import Cardano.SCLS.CBOR.Canonical.Encoder
24+
import Cardano.Ledger.Binary (decodeMemPack, encodeMemPack, EncCBOR(..), DecCBOR(..), toPlainEncoding, shelleyProtVer, toPlainDecoder)
25+
import Cardano.SCLS.CBOR.Canonical.Decoder
26+
import qualified Codec.CBOR.Encoding as E
27+
import qualified Codec.CBOR.Decoding as D
28+
import Cardano.Ledger.Conway (ConwayEra)
29+
import Cardano.Ledger.TxIn (TxIn(..))
30+
import Cardano.Ledger.Core (TxOut(..))
31+
-- import Cardano.Ledger.TxOut (TxOut(..))
32+
import Cardano.Ledger.Compactible
33+
import Cardano.Ledger.Address
34+
import Cardano.Ledger.Credential
35+
import Cardano.Ledger.Keys
36+
import Cardano.Ledger.Hashes
37+
import Cardano.Ledger.Plutus.Data (Datum(..))
38+
import Cardano.Ledger.Plutus.Data (BinaryData)
39+
import Cardano.Ledger.Mary (MaryEra, MaryValue)
40+
import Cardano.SCLS.Internal.Entry
41+
import Cardano.SCLS.Internal.Version
42+
import Data.Typeable (Typeable)
43+
import qualified Cardano.Ledger.Shelley.TxOut as Shelley
44+
import qualified Cardano.Ledger.Babbage.TxOut as Babbage
45+
import Cardano.Ledger.Allegra.Scripts (Timelock(..))
46+
import Data.MemPack
47+
import Data.Word (Word8, Word16)
48+
import Cardano.Ledger.Alonzo.TxOut (DataHash32, Addr28Extra)
49+
import Cardano.Ledger.Alonzo.Scripts (AlonzoPlutusPurpose, AsItem, AlonzoScript)
50+
51+
-- | Helper that allows us to deriving instances via internal CBOR representation
52+
newtype LedgerCBOR (v::Version) a = LedgerCBOR { unLedgerCBOR :: a }
53+
deriving (Eq, Show)
54+
55+
instance EncCBOR a => ToCanonicalCBOR v (LedgerCBOR v a) where
56+
toCanonicalCBOR _v (LedgerCBOR a) = toPlainEncoding shelleyProtVer (encCBOR a)
57+
58+
instance DecCBOR a => FromCanonicalCBOR v (LedgerCBOR v a) where
59+
fromCanonicalCBOR = Versioned . LedgerCBOR <$> toPlainDecoder Nothing shelleyProtVer decCBOR
60+
61+
newtype MemPackCBOR a = MemPackCBOR { unMemPackCBOR :: a }
62+
deriving (Eq, Show)
63+
64+
instance (MemPack a) => ToCanonicalCBOR V1 (MemPackCBOR a) where
65+
toCanonicalCBOR _v (MemPackCBOR a) = toPlainEncoding shelleyProtVer (encodeMemPack a)
66+
67+
instance (MemPack a) => FromCanonicalCBOR V1 (MemPackCBOR a) where
68+
fromCanonicalCBOR = Versioned . MemPackCBOR <$> toPlainDecoder Nothing shelleyProtVer decodeMemPack
69+
70+
-- | Input wrapper for the keys that are used in utxo namespace
71+
data UtxoKey
72+
= UtxoKeyIn TxIn
73+
-- | UtxoKeyScript ScriptUtxoIn
74+
75+
instance Eq UtxoKey where
76+
(UtxoKeyIn txIn1) == (UtxoKeyIn txIn2) = txIn1 == txIn2
77+
-- (UtxoKeyScript script1) == (UtxoKeyScript script2) = undefined script1 script2
78+
-- _ == _ = False
79+
80+
instance Ord UtxoKey where
81+
compare (UtxoKeyIn txIn1) (UtxoKeyIn txIn2) = compare txIn1 txIn2
82+
-- compare (UtxoKeyScript script1) (UtxoKeyScript script2) = undefined script1 script2
83+
-- compare (UtxoKeyIn _) (UtxoKeyScript _) = LT
84+
-- compare (UtxoKeyScript _) (UtxoKeyIn _) = GT
85+
86+
instance IsKey UtxoKey where
87+
keySize = 34
88+
packKeyM (UtxoKeyIn (TxIn a b)) = do
89+
packM a
90+
packM b
91+
-- packKeyM (UtxoKeyScript (ScriptUtxoIn purpose hash)) = do
92+
-- undefined purpose hash
93+
unpackKeyM = do
94+
a <- unpackM
95+
b <- unpackM
96+
return $ UtxoKeyIn (TxIn a b)
97+
-- toKeyBytes v key = toStrictByteString $ toCanonicalCBOR v key
98+
99+
newtype Out = Out (TxOut ConwayEra)
100+
deriving newtype (ToCanonicalCBOR V1, FromCanonicalCBOR V1)
101+
102+
data AddrUtxoIn = AddrUtxoIn { addrUtxoInAddress :: DataHash32, addrUtxoInIndex :: Word16 }
103+
data ScriptUtxoIn = ScriptUtxoIn { scriptUtxoInPurpose :: AlonzoPlutusPurpose AsItem MaryEra, scriptUtxoInHash :: ScriptHash }
104+
105+
-- | Output key that is used in utxo namespace
106+
--
107+
-- Here we follow the current spec, but after benchmarks we can decide that this representation
108+
-- is not efficient and we can replace it with the implementation based on the compact values
109+
data UtxoOut
110+
= UtxoOutShelley (Shelley.ShelleyTxOut MaryEra)
111+
| UtxoOutBabbage (Babbage.BabbageTxOut MaryEra)
112+
| UtxoValue MaryValue
113+
114+
instance ToCanonicalCBOR V1 UtxoKey where
115+
toCanonicalCBOR v (UtxoKeyIn txIn) = E.encodeTag 0 <> toCanonicalCBOR v txIn
116+
-- toCanonicalCBOR v (UtxoKeyScript script) = E.encodeTag 1 <> toCanonicalCBOR v script
117+
118+
119+
instance ToCanonicalCBOR V1 AddrUtxoIn where
120+
toCanonicalCBOR v (AddrUtxoIn addr idx) = toCanonicalCBOR v (addr, idx)
121+
122+
instance FromCanonicalCBOR V1 AddrUtxoIn where
123+
fromCanonicalCBOR = fmap (uncurry AddrUtxoIn) <$> fromCanonicalCBOR
124+
125+
instance ToCanonicalCBOR V1 ScriptUtxoIn where
126+
toCanonicalCBOR v (ScriptUtxoIn purpose hash) = toCanonicalCBOR v (purpose, hash)
127+
128+
instance FromCanonicalCBOR V1 ScriptUtxoIn where
129+
fromCanonicalCBOR = fmap (uncurry ScriptUtxoIn) <$> fromCanonicalCBOR
130+
131+
instance FromCanonicalCBOR V1 UtxoKey where
132+
fromCanonicalCBOR = do
133+
tag <- fromCanonicalCBOR
134+
case unVer tag :: Word8 of
135+
0 -> fmap UtxoKeyIn <$> fromCanonicalCBOR
136+
-- 1 -> fmap UtxoKeyScript <$> fromCanonicalCBOR
137+
_ -> fail "Unknown UtxoKey tag"
138+
139+
instance ToCanonicalCBOR V1 UtxoOut where
140+
toCanonicalCBOR v (UtxoOutShelley shelleyOut) = E.encodeTag 1 <> toCanonicalCBOR v shelleyOut
141+
toCanonicalCBOR v (UtxoOutBabbage babbageOut) = E.encodeTag 2 <> toCanonicalCBOR v babbageOut
142+
toCanonicalCBOR v (UtxoValue value) = E.encodeTag 3 <> toCanonicalCBOR v value
143+
144+
instance FromCanonicalCBOR V1 UtxoOut where
145+
fromCanonicalCBOR = do
146+
tag <- fromCanonicalCBOR
147+
case unVer tag :: Word8 of
148+
1 -> fmap UtxoOutShelley <$> fromCanonicalCBOR
149+
2 -> fmap UtxoOutBabbage <$> fromCanonicalCBOR
150+
3 -> fmap UtxoValue <$> fromCanonicalCBOR
151+
t -> fail $ "Unknown UtxoOut tag: " <> show t
152+
153+
instance ToCanonicalCBOR V1 (Babbage.BabbageTxOut ConwayEra) where
154+
toCanonicalCBOR v (Babbage.TxOutCompact' cAddr form) = E.encodeTag 0 <> toCanonicalCBOR v (cAddr, form)
155+
toCanonicalCBOR v (Babbage.TxOutCompactDH' cAddr form dataHash) = E.encodeTag 1 <> toCanonicalCBOR v (cAddr, form, dataHash)
156+
toCanonicalCBOR v (Babbage.TxOutCompactDatum cAddr form inlineDatum) = E.encodeTag 2 <> toCanonicalCBOR v (cAddr, form, inlineDatum)
157+
toCanonicalCBOR v (Babbage.TxOutCompactRefScript cAddr form datum script) = E.encodeTag 3 <> toCanonicalCBOR v (cAddr, form, datum, script)
158+
toCanonicalCBOR v (Babbage.TxOut_AddrHash28_AdaOnly staking hash28 compact) = E.encodeTag 4 <> toCanonicalCBOR v (staking, hash28, compact)
159+
toCanonicalCBOR v (Babbage.TxOut_AddrHash28_AdaOnly_DataHash32 staking hash28 compact dataHash) = E.encodeTag 5 <> toCanonicalCBOR v (staking, hash28, compact, dataHash)
160+
161+
instance FromCanonicalCBOR V1 (Babbage.BabbageTxOut ConwayEra) where
162+
fromCanonicalCBOR = do
163+
D.decodeTag >>= \case
164+
0 -> fmap (\(c, f) -> Babbage.TxOutCompact' c f) <$> fromCanonicalCBOR
165+
1 -> fmap (\(a,b,c) -> Babbage.TxOutCompactDH' a b c) <$> fromCanonicalCBOR
166+
2 -> fmap (\(a,b,c) -> Babbage.TxOutCompactDatum a b c) <$> fromCanonicalCBOR
167+
3 -> fmap (\(a,b,c,d) -> Babbage.TxOutCompactRefScript a b c d) <$> fromCanonicalCBOR
168+
4 -> fmap (\(a,b,c) -> Babbage.TxOut_AddrHash28_AdaOnly a b c) <$> fromCanonicalCBOR
169+
5 -> fmap (\(a,b,c,d) -> Babbage.TxOut_AddrHash28_AdaOnly_DataHash32 a b c d) <$> fromCanonicalCBOR
170+
t -> fail $ "Unknown BabbageTxOut tag: " <> show t
171+
172+
instance ToCanonicalCBOR V1 (Babbage.BabbageTxOut MaryEra) where
173+
toCanonicalCBOR v (Babbage.TxOutCompact' cAddr form) = E.encodeTag 0 <> toCanonicalCBOR v (cAddr, form)
174+
toCanonicalCBOR v (Babbage.TxOutCompactDH' cAddr form dataHash) = E.encodeTag 1 <> toCanonicalCBOR v (cAddr, form, dataHash)
175+
toCanonicalCBOR v (Babbage.TxOutCompactDatum cAddr form inlineDatum) = E.encodeTag 2 <> toCanonicalCBOR v (cAddr, form, inlineDatum)
176+
toCanonicalCBOR v (Babbage.TxOutCompactRefScript cAddr form datum script) = E.encodeTag 3 <> toCanonicalCBOR v (cAddr, form, datum, script)
177+
toCanonicalCBOR v (Babbage.TxOut_AddrHash28_AdaOnly staking hash28 compact) = E.encodeTag 4 <> toCanonicalCBOR v (staking, hash28, compact)
178+
toCanonicalCBOR v (Babbage.TxOut_AddrHash28_AdaOnly_DataHash32 staking hash28 compact dataHash) = E.encodeTag 5 <> toCanonicalCBOR v (staking, hash28, compact, dataHash)
179+
180+
instance FromCanonicalCBOR V1 (Babbage.BabbageTxOut MaryEra) where
181+
fromCanonicalCBOR = do
182+
D.decodeTag >>= \case
183+
0 -> fmap (\(c, f) -> Babbage.TxOutCompact' c f) <$> fromCanonicalCBOR
184+
1 -> fmap (\(a,b,c) -> Babbage.TxOutCompactDH' a b c) <$> fromCanonicalCBOR
185+
2 -> fmap (\(a,b,c) -> Babbage.TxOutCompactDatum a b c) <$> fromCanonicalCBOR
186+
3 -> fmap (\(a,b,c,d) -> Babbage.TxOutCompactRefScript a b c d) <$> fromCanonicalCBOR
187+
4 -> fmap (\(a,b,c) -> Babbage.TxOut_AddrHash28_AdaOnly a b c) <$> fromCanonicalCBOR
188+
5 -> fmap (\(a,b,c,d) -> Babbage.TxOut_AddrHash28_AdaOnly_DataHash32 a b c d) <$> fromCanonicalCBOR
189+
t -> fail $ "Unknown BabbageTxOut tag: " <> show t
190+
191+
192+
instance Typeable kr => ToCanonicalCBOR V1 (Credential kr) where
193+
toCanonicalCBOR v (ScriptHashObj sh) = toCanonicalCBOR v (0::Word8, sh)
194+
toCanonicalCBOR v (KeyHashObj kh) = toCanonicalCBOR v (1::Word8, kh)
195+
196+
instance Typeable kr => FromCanonicalCBOR V1 (Credential kr) where
197+
fromCanonicalCBOR = do
198+
tag <- fromCanonicalCBOR
199+
case unVer tag :: Word8 of
200+
0 -> fmap ScriptHashObj <$> fromCanonicalCBOR
201+
1 -> fmap KeyHashObj <$> fromCanonicalCBOR
202+
x -> fail $ "Unknown Credential tag: " <> show x
203+
204+
deriving via (LedgerCBOR v (Shelley.ShelleyTxOut MaryEra)) instance ToCanonicalCBOR v (Shelley.ShelleyTxOut MaryEra)
205+
deriving via (LedgerCBOR v (Shelley.ShelleyTxOut MaryEra)) instance FromCanonicalCBOR v (Shelley.ShelleyTxOut MaryEra)
206+
deriving via (LedgerCBOR v (AlonzoPlutusPurpose AsItem MaryEra)) instance ToCanonicalCBOR v (AlonzoPlutusPurpose AsItem MaryEra)
207+
deriving via (LedgerCBOR v (AlonzoPlutusPurpose AsItem MaryEra)) instance FromCanonicalCBOR v (AlonzoPlutusPurpose AsItem MaryEra)
208+
deriving via (LedgerCBOR v (AlonzoPlutusPurpose AsItem ConwayEra)) instance ToCanonicalCBOR v (AlonzoPlutusPurpose AsItem ConwayEra)
209+
deriving via (LedgerCBOR v (AlonzoPlutusPurpose AsItem ConwayEra)) instance FromCanonicalCBOR v (AlonzoPlutusPurpose AsItem ConwayEra)
210+
deriving via (MemPackCBOR (AlonzoScript ConwayEra)) instance ToCanonicalCBOR V1 (AlonzoScript ConwayEra)
211+
deriving via (MemPackCBOR (AlonzoScript ConwayEra)) instance FromCanonicalCBOR V1 (AlonzoScript ConwayEra)
212+
deriving via (MemPackCBOR (CompactForm a)) instance (MemPack (CompactForm a)) => ToCanonicalCBOR V1 (CompactForm a)
213+
deriving via (MemPackCBOR (CompactForm a)) instance (MemPack (CompactForm a)) => FromCanonicalCBOR V1 (CompactForm a)
214+
deriving via (MemPackCBOR CompactAddr) instance FromCanonicalCBOR V1 CompactAddr
215+
deriving via (MemPackCBOR CompactAddr) instance ToCanonicalCBOR V1 CompactAddr
216+
deriving via (MemPackCBOR Addr28Extra) instance FromCanonicalCBOR V1 Addr28Extra
217+
deriving via (MemPackCBOR Addr28Extra) instance ToCanonicalCBOR V1 Addr28Extra
218+
deriving via (LedgerCBOR v TxIn) instance FromCanonicalCBOR v TxIn
219+
deriving via (LedgerCBOR v TxIn) instance ToCanonicalCBOR v TxIn
220+
deriving via (MemPackCBOR DataHash32) instance FromCanonicalCBOR V1 DataHash32
221+
deriving via (MemPackCBOR DataHash32) instance ToCanonicalCBOR V1 DataHash32
222+
deriving via (MemPackCBOR (Timelock MaryEra)) instance ToCanonicalCBOR V1 (Timelock MaryEra)
223+
deriving via (MemPackCBOR (Timelock MaryEra)) instance FromCanonicalCBOR V1 (Timelock MaryEra)
224+
deriving via (LedgerCBOR v MaryValue) instance ToCanonicalCBOR v MaryValue
225+
deriving via (LedgerCBOR v MaryValue) instance FromCanonicalCBOR v MaryValue
226+
227+
228+
deriving via (LedgerCBOR v (KeyHash kr)) instance Typeable kr => ToCanonicalCBOR v (KeyHash kr)
229+
deriving via (LedgerCBOR v (KeyHash kr)) instance Typeable kr => FromCanonicalCBOR v (KeyHash kr)
230+
deriving via (LedgerCBOR v (ScriptHash)) instance FromCanonicalCBOR v ScriptHash
231+
deriving via (LedgerCBOR v (ScriptHash)) instance ToCanonicalCBOR v ScriptHash
232+
deriving via (LedgerCBOR v (Datum MaryEra)) instance ToCanonicalCBOR v (Datum MaryEra)
233+
deriving via (LedgerCBOR v (Datum MaryEra)) instance FromCanonicalCBOR v (Datum MaryEra)
234+
deriving via (LedgerCBOR v (Datum ConwayEra)) instance ToCanonicalCBOR v (Datum ConwayEra)
235+
deriving via (LedgerCBOR v (Datum ConwayEra)) instance FromCanonicalCBOR v (Datum ConwayEra)
236+
deriving via (LedgerCBOR v (BinaryData MaryEra)) instance ToCanonicalCBOR v (BinaryData MaryEra)
237+
deriving via (LedgerCBOR v (BinaryData MaryEra)) instance FromCanonicalCBOR v (BinaryData MaryEra)
238+
deriving via (LedgerCBOR v (BinaryData ConwayEra)) instance ToCanonicalCBOR v (BinaryData ConwayEra)
239+
deriving via (LedgerCBOR v (BinaryData ConwayEra)) instance FromCanonicalCBOR v (BinaryData ConwayEra)
240+
deriving via (LedgerCBOR v (SafeHash EraIndependentData)) instance ToCanonicalCBOR v ((SafeHash EraIndependentData))
241+
deriving via (LedgerCBOR v (SafeHash EraIndependentData)) instance FromCanonicalCBOR v ((SafeHash EraIndependentData))
242+
243+
244+

‎libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/StakeDistr.hs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -108,6 +108,9 @@ readNewEpochState = do
108108
case Plain.decodeFullDecoder lbl fromCBOR lazyBytes of
109109
Left err -> error (show err)
110110
Right (nes :: NewEpochState CurrentEra) -> pure nes
111+
-- case Aeson.eitherDecode lazyBytes of
112+
-- Left err -> error (show err)
113+
-- Right (nes :: NewEpochState CurrentEra) -> pure nes
111114
Nothing ->
112115
bogusNewEpochState <$ do
113116
putStrLn $

0 commit comments

Comments
 (0)