Skip to content

Commit b70e6b6

Browse files
qnikstqnikst
committed
Code typechecks and nice helpers introduced
LedgerCBOR instance — allows to generate CanonicalCBOR instance from the ledger one MempackCBOR instance - allow to generate CanonicalCBOR instance from the mempack one
1 parent 02e34f6 commit b70e6b6

File tree

2 files changed

+75
-57
lines changed

2 files changed

+75
-57
lines changed

‎cabal.project‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -103,20 +103,20 @@ source-repository-package
103103
subdir: scls-cbor
104104
allow-older:
105105
, merkle-tree-incremental:bytestring
106-
tag: 1e4d0ae357ca9a215653aa46784644dd1407101d
106+
tag: 7e0344dad0ff156d4a3932f1c73dc54379a50c51
107107

108108
source-repository-package
109109
type: git
110110
location: https://github.com/tweag/cardano-canonical-ledger.git
111111
subdir: scls-format
112112
allow-older:
113113
, merkle-tree-incremental:bytestring
114-
tag: 1e4d0ae357ca9a215653aa46784644dd1407101d
114+
tag: 7e0344dad0ff156d4a3932f1c73dc54379a50c51
115115

116116
source-repository-package
117117
type: git
118118
location: https://github.com/tweag/cardano-canonical-ledger.git
119119
subdir: merkle-tree-incremental
120120
allow-older:
121121
, bytestring
122-
tag: 1e4d0ae357ca9a215653aa46784644dd1407101d
122+
tag: 7e0344dad0ff156d4a3932f1c73dc54379a50c51

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

Lines changed: 72 additions & 54 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,7 @@
1+
{-# LANGUAGE LambdaCase #-}
12
{-# LANGUAGE DataKinds #-}
3+
{-# LANGUAGE StandaloneDeriving #-}
4+
{-# LANGUAGE DerivingVia #-}
25
{-# LANGUAGE RecordWildCards #-}
36
{-# LANGUAGE MultiParamTypeClasses #-}
47
{-# LANGUAGE FlexibleInstances #-}
@@ -11,30 +14,46 @@ module Cardano.Ledger.Export.Namespace.UTxO
1114
) where
1215

1316
import Cardano.SCLS.CBOR.Canonical.Encoder
14-
import Cardano.Ledger.Binary
17+
import Cardano.Ledger.Binary (decodeMemPack, encodeMemPack, EncCBOR(..), DecCBOR(..), toPlainEncoding, shelleyProtVer, toPlainDecoder)
1518
import Cardano.SCLS.CBOR.Canonical.Decoder
16-
-- import Cardano.Ledger.Binary.Version
19+
import qualified Codec.CBOR.Encoding as E
20+
import qualified Codec.CBOR.Decoding as D
1721
import Cardano.Ledger.Compactible
1822
import Cardano.Ledger.Address
1923
import Cardano.Ledger.Credential
2024
import Cardano.Ledger.Keys
2125
import Cardano.Ledger.Hashes
22-
-- import Cardano.Ledger.Coin
2326
import Cardano.Ledger.Plutus.Data (Datum(..))
2427
import Cardano.Ledger.Plutus.Data (BinaryData)
2528
import Cardano.Ledger.Mary (MaryEra)
26-
-- import Cardano.Ledger
2729
import Cardano.SCLS.Internal.Version
28-
-- import Cardano.Ledger.Mary.Value (MaryValue)
2930
import Data.Typeable (Typeable)
3031
import qualified Cardano.Ledger.Shelley.TxOut as Shelley
3132
import qualified Cardano.Ledger.Babbage.TxOut as Babbage
3233
import Cardano.Ledger.Allegra.Scripts (Timelock(..))
3334
import Data.MemPack
34-
import qualified Codec.CBOR.Encoding as E
3535
import Data.Word (Word8, Word16)
3636
import Cardano.Ledger.Alonzo.TxOut (DataHash32, Addr28Extra)
3737

38+
-- | Helper that allows us to deriving instances via internal CBOR representation
39+
newtype LedgerCBOR a = LedgerCBOR { unLedgerCBOR :: a }
40+
deriving (Eq, Show)
41+
42+
instance EncCBOR a => ToCanonicalCBOR V1 (LedgerCBOR a) where
43+
toCanonicalCBOR _v (LedgerCBOR a) = toPlainEncoding shelleyProtVer (encCBOR a)
44+
45+
instance DecCBOR a => FromCanonicalCBOR V1 (LedgerCBOR a) where
46+
fromCanonicalCBOR = Versioned . LedgerCBOR <$> toPlainDecoder Nothing shelleyProtVer decCBOR
47+
48+
newtype MemPackCBOR a = MemPackCBOR { unMemPackCBOR :: a }
49+
deriving (Eq, Show)
50+
51+
instance (MemPack a) => ToCanonicalCBOR V1 (MemPackCBOR a) where
52+
toCanonicalCBOR _v (MemPackCBOR a) = toPlainEncoding shelleyProtVer (encodeMemPack a)
53+
54+
instance (MemPack a) => FromCanonicalCBOR V1 (MemPackCBOR a) where
55+
fromCanonicalCBOR = Versioned . MemPackCBOR <$> toPlainDecoder Nothing shelleyProtVer decodeMemPack
56+
3857
-- | Input wrapper for the keys that are used in utxo namespace
3958
data UtxoIn = UtxoIn { utxoInAddress :: DataHash32, utxoInIndex :: Word16 }
4059

@@ -54,8 +73,8 @@ instance FromCanonicalCBOR V1 UtxoIn where
5473
fmap (uncurry UtxoIn) <$> fromCanonicalCBOR
5574

5675
instance ToCanonicalCBOR V1 UtxoOut where
57-
toCanonicalCBOR v (UtxoOutShelley shelleyOut) = toCanonicalCBOR v (1::Word8, shelleyOut)
58-
toCanonicalCBOR v (UtxoOutBabbage babbageOut) = toCanonicalCBOR v (2::Word8, babbageOut)
76+
toCanonicalCBOR v (UtxoOutShelley shelleyOut) = E.encodeTag 1 <> toCanonicalCBOR v shelleyOut
77+
toCanonicalCBOR v (UtxoOutBabbage babbageOut) = E.encodeTag 2 <> toCanonicalCBOR v babbageOut
5978

6079
instance FromCanonicalCBOR V1 UtxoOut where
6180
fromCanonicalCBOR = do
@@ -67,64 +86,63 @@ instance FromCanonicalCBOR V1 UtxoOut where
6786

6887
instance ToCanonicalCBOR V1 (Shelley.ShelleyTxOut MaryEra) where
6988
toCanonicalCBOR v (Shelley.TxOutCompact cAddr cValue) =
70-
toCanonicalCBOR v (cAddr, cValue) -- TODO: differ from spec as it uses compact representation
89+
toCanonicalCBOR v (cAddr, cValue)
7190
instance FromCanonicalCBOR V1 (Shelley.ShelleyTxOut MaryEra) where
7291
fromCanonicalCBOR = undefined -- fmap (uncurry Shelley.TxOutCompact) <$> fromCanonicalCBOR
7392

7493
instance ToCanonicalCBOR V1 (Babbage.BabbageTxOut MaryEra) where
75-
toCanonicalCBOR v (Babbage.TxOutCompact' cAddr form) = toCanonicalCBOR v (cAddr, form)
76-
toCanonicalCBOR v (Babbage.TxOutCompactDH' cAddr form dataHash) = toCanonicalCBOR v (cAddr, form, dataHash)
77-
toCanonicalCBOR v (Babbage.TxOutCompactDatum cAddr form inlineDatum) = toCanonicalCBOR v (cAddr, form, inlineDatum)
78-
toCanonicalCBOR v (Babbage.TxOutCompactRefScript cAddr form datum script) = toCanonicalCBOR v (cAddr, form, datum, script)
79-
toCanonicalCBOR v (Babbage.TxOut_AddrHash28_AdaOnly staking hash28 compact) = toCanonicalCBOR v (staking, hash28, compact)
80-
toCanonicalCBOR v (Babbage.TxOut_AddrHash28_AdaOnly_DataHash32 staking hash28 compact dataHash) = toCanonicalCBOR v (staking, hash28, compact, dataHash)
94+
toCanonicalCBOR v (Babbage.TxOutCompact' cAddr form) = E.encodeTag 0 <> toCanonicalCBOR v (cAddr, form)
95+
toCanonicalCBOR v (Babbage.TxOutCompactDH' cAddr form dataHash) = E.encodeTag 1 <> toCanonicalCBOR v (cAddr, form, dataHash)
96+
toCanonicalCBOR v (Babbage.TxOutCompactDatum cAddr form inlineDatum) = E.encodeTag 2 <> toCanonicalCBOR v (cAddr, form, inlineDatum)
97+
toCanonicalCBOR v (Babbage.TxOutCompactRefScript cAddr form datum script) = E.encodeTag 3 <> toCanonicalCBOR v (cAddr, form, datum, script)
98+
toCanonicalCBOR v (Babbage.TxOut_AddrHash28_AdaOnly staking hash28 compact) = E.encodeTag 4 <> toCanonicalCBOR v (staking, hash28, compact)
99+
toCanonicalCBOR v (Babbage.TxOut_AddrHash28_AdaOnly_DataHash32 staking hash28 compact dataHash) = E.encodeTag 5 <> toCanonicalCBOR v (staking, hash28, compact, dataHash)
81100

82101
instance FromCanonicalCBOR V1 (Babbage.BabbageTxOut MaryEra) where
83-
fromCanonicalCBOR = undefined
84-
-- Versioned (addr, value, mDataHash) <- fromCanonicalCBOR
85-
-- pure $! Versioned (Babbage.TxOutCompact addr value mDataHash)
86-
87-
instance EncCBOR (CompactForm a) => ToCanonicalCBOR V1 (CompactForm a) where
88-
toCanonicalCBOR _ a = toPlainEncoding shelleyProtVer (encCBOR a)
89-
90-
instance ToCanonicalCBOR V1 (CompactAddr) where
91-
toCanonicalCBOR v s = toCanonicalCBOR v (unCompactAddr s)
92-
93-
instance FromCanonicalCBOR V1 (CompactAddr) where
94-
fromCanonicalCBOR = undefined
95-
96-
instance ToCanonicalCBOR V1 DataHash32 where
97-
toCanonicalCBOR _ hash32 = E.encodeBytes $ packByteString hash32
102+
fromCanonicalCBOR = do
103+
D.decodeTag >>= \case
104+
0 -> fmap (\(c, f) -> Babbage.TxOutCompact' c f) <$> fromCanonicalCBOR
105+
1 -> fmap (\(a,b,c) -> Babbage.TxOutCompactDH' a b c) <$> fromCanonicalCBOR
106+
2 -> fmap (\(a,b,c) -> Babbage.TxOutCompactDatum a b c) <$> fromCanonicalCBOR
107+
3 -> fmap (\(a,b,c,d) -> Babbage.TxOutCompactRefScript a b c d) <$> fromCanonicalCBOR
108+
4 -> fmap (\(a,b,c) -> Babbage.TxOut_AddrHash28_AdaOnly a b c) <$> fromCanonicalCBOR
109+
5 -> fmap (\(a,b,c,d) -> Babbage.TxOut_AddrHash28_AdaOnly_DataHash32 a b c d) <$> fromCanonicalCBOR
110+
t -> fail $ "Unknown BabbageTxOut tag: " <> show t
98111

99-
instance FromCanonicalCBOR V1 DataHash32 where
100-
fromCanonicalCBOR = undefined
101-
{-
102-
Versioned bytes <- fromCanonicalCBOR
103-
case decodeDataHash32 (bytes) of
104-
dh -> pure $! Versioned (encodeDataHash32 dh)
105-
-}
106112

107113
instance Typeable kr => ToCanonicalCBOR V1 (Credential kr) where
108114
toCanonicalCBOR v (ScriptHashObj sh) = toCanonicalCBOR v (0::Word8, sh)
109115
toCanonicalCBOR v (KeyHashObj kh) = toCanonicalCBOR v (1::Word8, kh)
110116

111-
instance Typeable kr => ToCanonicalCBOR V1 (KeyHash kr) where
112-
toCanonicalCBOR _ = toPlainEncoding shelleyProtVer . encCBOR
113-
114-
instance ToCanonicalCBOR V1 ScriptHash where
115-
toCanonicalCBOR _ = toPlainEncoding shelleyProtVer . encCBOR
116-
117-
instance ToCanonicalCBOR V1 Addr28Extra where
118-
toCanonicalCBOR _ = E.encodeBytes . packByteString
119-
120-
instance ToCanonicalCBOR V1 (Timelock MaryEra) where
121-
toCanonicalCBOR _v = toPlainEncoding shelleyProtVer . encCBOR
117+
instance Typeable kr => FromCanonicalCBOR V1 (Credential kr) where
118+
fromCanonicalCBOR = do
119+
tag <- fromCanonicalCBOR
120+
case unVer tag :: Word8 of
121+
0 -> fmap ScriptHashObj <$> fromCanonicalCBOR
122+
1 -> fmap KeyHashObj <$> fromCanonicalCBOR
123+
x -> fail $ "Unknown Credential tag: " <> show x
124+
125+
deriving via (MemPackCBOR (CompactForm a)) instance (MemPack (CompactForm a)) => ToCanonicalCBOR V1 (CompactForm a)
126+
deriving via (MemPackCBOR (CompactForm a)) instance (MemPack (CompactForm a)) => FromCanonicalCBOR V1 (CompactForm a)
127+
deriving via (MemPackCBOR CompactAddr) instance FromCanonicalCBOR V1 CompactAddr
128+
deriving via (MemPackCBOR CompactAddr) instance ToCanonicalCBOR V1 CompactAddr
129+
deriving via (MemPackCBOR Addr28Extra) instance FromCanonicalCBOR V1 Addr28Extra
130+
deriving via (MemPackCBOR Addr28Extra) instance ToCanonicalCBOR V1 Addr28Extra
131+
deriving via (MemPackCBOR DataHash32) instance FromCanonicalCBOR V1 DataHash32
132+
deriving via (MemPackCBOR DataHash32) instance ToCanonicalCBOR V1 DataHash32
133+
deriving via (MemPackCBOR (Timelock MaryEra)) instance ToCanonicalCBOR V1 (Timelock MaryEra)
134+
deriving via (MemPackCBOR (Timelock MaryEra)) instance FromCanonicalCBOR V1 (Timelock MaryEra)
135+
136+
deriving via (LedgerCBOR (KeyHash kr)) instance Typeable kr => ToCanonicalCBOR V1 (KeyHash kr)
137+
deriving via (LedgerCBOR (KeyHash kr)) instance Typeable kr => FromCanonicalCBOR V1 (KeyHash kr)
138+
deriving via (LedgerCBOR (ScriptHash)) instance FromCanonicalCBOR V1 ScriptHash
139+
deriving via (LedgerCBOR (ScriptHash)) instance ToCanonicalCBOR V1 ScriptHash
140+
deriving via (LedgerCBOR (Datum MaryEra)) instance ToCanonicalCBOR V1 (Datum MaryEra)
141+
deriving via (LedgerCBOR (Datum MaryEra)) instance FromCanonicalCBOR V1 (Datum MaryEra)
142+
deriving via (LedgerCBOR (BinaryData MaryEra)) instance ToCanonicalCBOR V1 (BinaryData MaryEra)
143+
deriving via (LedgerCBOR (BinaryData MaryEra)) instance FromCanonicalCBOR V1 (BinaryData MaryEra)
144+
deriving via (LedgerCBOR (SafeHash EraIndependentData)) instance ToCanonicalCBOR V1 ((SafeHash EraIndependentData))
145+
deriving via (LedgerCBOR (SafeHash EraIndependentData)) instance FromCanonicalCBOR V1 ((SafeHash EraIndependentData))
122146

123-
instance ToCanonicalCBOR V1 (Datum MaryEra) where
124-
toCanonicalCBOR _v = toPlainEncoding shelleyProtVer . encCBOR
125147

126-
instance ToCanonicalCBOR V1 (BinaryData MaryEra) where
127-
toCanonicalCBOR _v = toPlainEncoding shelleyProtVer . encCBOR
128148

129-
instance ToCanonicalCBOR V1 (SafeHash EraIndependentData) where
130-
toCanonicalCBOR _v = toPlainEncoding shelleyProtVer . encCBOR

0 commit comments

Comments
 (0)