Skip to content

Commit 26c2331

Browse files
Jimbo4350Jimbo4350
committed
Implement CIP129 class
1 parent 09c7498 commit 26c2331

File tree

7 files changed

+245
-0
lines changed

7 files changed

+245
-0
lines changed

‎cardano-api/cardano-api.cabal

+1
Original file line numberDiff line numberDiff line change
@@ -185,6 +185,7 @@ library
185185

186186
other-modules:
187187
Cardano.Api.Internal.Anchor
188+
Cardano.Api.Internal.CIP.CIP129
188189
Cardano.Api.Internal.Certificate
189190
Cardano.Api.Internal.Compatible.Tx
190191
Cardano.Api.Internal.Convenience.Construction

‎cardano-api/src/Cardano/Api.hs

+6
Original file line numberDiff line numberDiff line change
@@ -709,6 +709,11 @@ module Cardano.Api
709709
, Bech32DecodeError (..)
710710
, UsingBech32 (..)
711711

712+
-- ** Bech32 CIP-129
713+
, CIP129 (..)
714+
, deserialiseFromBech32CIP129
715+
, serialiseToBech32CIP129
716+
712717
-- ** Addresses
713718

714719
-- | Address serialisation is (sadly) special
@@ -1104,6 +1109,7 @@ where
11041109
import Cardano.Api.Internal.Address
11051110
import Cardano.Api.Internal.Anchor
11061111
import Cardano.Api.Internal.Block
1112+
import Cardano.Api.Internal.CIP.CIP129
11071113
import Cardano.Api.Internal.Certificate
11081114
import Cardano.Api.Internal.Convenience.Construction
11091115
import Cardano.Api.Internal.Convenience.Query

‎cardano-api/src/Cardano/Api/Internal/CIP/CIP129.hs

+225
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,225 @@
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE FlexibleInstances #-}
3+
{-# LANGUAGE RankNTypes #-}
4+
{-# LANGUAGE ScopedTypeVariables #-}
5+
{-# LANGUAGE TypeFamilies #-}
6+
{-# OPTIONS_GHC -Wno-orphans #-}
7+
8+
module Cardano.Api.Internal.CIP.CIP129
9+
( CIP129 (..)
10+
, deserialiseFromBech32CIP129
11+
, serialiseToBech32CIP129
12+
, serialiseGovActionIdToBech32CIP129
13+
, deserialiseGovActionIdFromBech32CIP129
14+
)
15+
where
16+
17+
import Cardano.Api.Internal.Governance.Actions.ProposalProcedure
18+
import Cardano.Api.Internal.HasTypeProxy
19+
import Cardano.Api.Internal.Orphans ()
20+
import Cardano.Api.Internal.SerialiseBech32
21+
import Cardano.Api.Internal.SerialiseRaw
22+
import Cardano.Api.Internal.TxIn
23+
import Cardano.Api.Internal.Utils
24+
25+
import Cardano.Binary qualified as CBOR
26+
import Cardano.Ledger.Conway.Governance qualified as Gov
27+
import Cardano.Ledger.Credential (Credential (..))
28+
import Cardano.Ledger.Credential qualified as L
29+
import Cardano.Ledger.Keys qualified as L
30+
31+
import Codec.Binary.Bech32 qualified as Bech32
32+
import Control.Monad (guard)
33+
import Data.Bifunctor
34+
import Data.ByteString (ByteString)
35+
import Data.ByteString qualified as BS
36+
import Data.ByteString.Base16 qualified as Base16
37+
import Data.ByteString.Char8 qualified as C8
38+
import Data.Text (Text)
39+
import Data.Text.Encoding qualified as Text
40+
import GHC.Exts (IsList (..))
41+
import Text.Read
42+
43+
-- | CIP129 is a typeclass for to capture the serialisation requirements of https://cips.cardano.org/cip/CIP-0129
44+
class SerialiseAsRawBytes a => CIP129 a where
45+
cip129Bech32PrefixFor :: a -> Text
46+
cip129HeaderHexByte :: a -> ByteString
47+
cip129Bech32PrefixesPermitted :: AsType a -> [Text]
48+
49+
instance CIP129 (Credential L.ColdCommitteeRole) where
50+
cip129Bech32PrefixFor _ = "cc_cold"
51+
cip129Bech32PrefixesPermitted AsColdCommitteeCredential = ["cc_cold"]
52+
cip129HeaderHexByte c =
53+
case c of
54+
L.KeyHashObj{} -> BS.singleton 0x12 -- 0001 0010
55+
L.ScriptHashObj{} -> BS.singleton 0x13 -- 0001 0011
56+
57+
instance HasTypeProxy (Credential L.ColdCommitteeRole) where
58+
data AsType (Credential L.ColdCommitteeRole) = AsColdCommitteeCredential
59+
proxyToAsType _ = AsColdCommitteeCredential
60+
61+
instance SerialiseAsRawBytes (Credential L.ColdCommitteeRole) where
62+
serialiseToRawBytes = CBOR.serialize'
63+
deserialiseFromRawBytes AsColdCommitteeCredential =
64+
first
65+
( \e ->
66+
SerialiseAsRawBytesError
67+
("Unable to deserialise Credential ColdCommitteeRole: " ++ show e)
68+
)
69+
. CBOR.decodeFull'
70+
71+
instance CIP129 (Credential L.HotCommitteeRole) where
72+
cip129Bech32PrefixFor _ = "cc_hot"
73+
cip129Bech32PrefixesPermitted AsHotCommitteeCredential = ["cc_hot"]
74+
cip129HeaderHexByte c =
75+
case c of
76+
L.KeyHashObj{} -> BS.singleton 0x02 -- 0000 0010
77+
L.ScriptHashObj{} -> BS.singleton 0x03 -- 0000 0011
78+
79+
instance HasTypeProxy (Credential L.HotCommitteeRole) where
80+
data AsType (Credential L.HotCommitteeRole) = AsHotCommitteeCredential
81+
proxyToAsType _ = AsHotCommitteeCredential
82+
83+
instance SerialiseAsRawBytes (Credential L.HotCommitteeRole) where
84+
serialiseToRawBytes = CBOR.serialize'
85+
deserialiseFromRawBytes AsHotCommitteeCredential =
86+
first
87+
( \e ->
88+
SerialiseAsRawBytesError
89+
("Unable to deserialise Credential HotCommitteeRole: " ++ show e)
90+
)
91+
. CBOR.decodeFull'
92+
93+
instance CIP129 (Credential L.DRepRole) where
94+
cip129Bech32PrefixFor _ = "drep"
95+
cip129Bech32PrefixesPermitted AsDrepCredential = ["drep"]
96+
cip129HeaderHexByte c =
97+
case c of
98+
L.KeyHashObj{} -> BS.singleton 0x22 -- 0010 0010
99+
L.ScriptHashObj{} -> BS.singleton 0x23 -- 0010 0011
100+
101+
instance HasTypeProxy (Credential L.DRepRole) where
102+
data AsType (Credential L.DRepRole) = AsDrepCredential
103+
proxyToAsType _ = AsDrepCredential
104+
105+
instance SerialiseAsRawBytes (Credential L.DRepRole) where
106+
serialiseToRawBytes = CBOR.serialize'
107+
deserialiseFromRawBytes AsDrepCredential =
108+
first
109+
( \e ->
110+
SerialiseAsRawBytesError ("Unable to deserialise Credential DRepRole: " ++ show e)
111+
)
112+
. CBOR.decodeFull'
113+
114+
serialiseToBech32CIP129 :: CIP129 a => a -> Text
115+
serialiseToBech32CIP129 a =
116+
Bech32.encodeLenient
117+
humanReadablePart
118+
(Bech32.dataPartFromBytes (cip129HeaderHexByte a <> serialiseToRawBytes a))
119+
where
120+
prefix = cip129Bech32PrefixFor a
121+
humanReadablePart =
122+
case Bech32.humanReadablePartFromText prefix of
123+
Right p -> p
124+
Left err ->
125+
error $
126+
"serialiseToBech32: invalid prefix "
127+
++ show prefix
128+
++ ", "
129+
++ show err
130+
131+
deserialiseFromBech32CIP129
132+
:: CIP129 a
133+
=> AsType a -> Text -> Either Bech32DecodeError a
134+
deserialiseFromBech32CIP129 asType bech32Str = do
135+
(prefix, dataPart) <-
136+
Bech32.decodeLenient bech32Str
137+
?!. Bech32DecodingError
138+
139+
let actualPrefix = Bech32.humanReadablePartToText prefix
140+
permittedPrefixes = cip129Bech32PrefixesPermitted asType
141+
guard (actualPrefix `elem` permittedPrefixes)
142+
?! Bech32UnexpectedPrefix actualPrefix (fromList permittedPrefixes)
143+
144+
payload <-
145+
Bech32.dataPartToBytes dataPart
146+
?! Bech32DataPartToBytesError (Bech32.dataPartToText dataPart)
147+
148+
let (header, credential) = BS.splitAt 1 payload
149+
150+
value <- case deserialiseFromRawBytes asType credential of
151+
Right a -> Right a
152+
Left _ -> Left $ Bech32DeserialiseFromBytesError payload
153+
154+
let expectedHeader = cip129HeaderHexByte value
155+
156+
guard (header == expectedHeader)
157+
?! Bech32UnexpectedHeader (toBase16Text expectedHeader) (toBase16Text header)
158+
159+
let expectedPrefix = cip129Bech32PrefixFor value
160+
guard (actualPrefix == expectedPrefix)
161+
?! Bech32WrongPrefix actualPrefix expectedPrefix
162+
163+
return value
164+
where
165+
toBase16Text = Text.decodeUtf8 . Base16.encode
166+
167+
-- | Governance Action ID
168+
-- According to CIP129 there is no header byte for GovActionId.
169+
-- Instead they append the txid and index to form the payload.
170+
serialiseGovActionIdToBech32CIP129 :: Gov.GovActionId -> Text
171+
serialiseGovActionIdToBech32CIP129 (Gov.GovActionId txid index) =
172+
let txidHex = serialiseToRawBytes $ fromShelleyTxId txid
173+
indexHex = C8.pack $ show $ Gov.unGovActionIx index
174+
payload = txidHex <> indexHex
175+
in Bech32.encodeLenient
176+
humanReadablePart
177+
(Bech32.dataPartFromBytes payload)
178+
where
179+
humanReadablePart =
180+
let prefix = "gov_action"
181+
in case Bech32.humanReadablePartFromText prefix of
182+
Right p -> p
183+
Left err ->
184+
error $
185+
"serialiseToBech32: invalid prefix "
186+
++ show prefix
187+
++ ", "
188+
++ show err
189+
190+
deserialiseGovActionIdFromBech32CIP129
191+
:: Text -> Either Bech32DecodeError Gov.GovActionId
192+
deserialiseGovActionIdFromBech32CIP129 bech32Str = do
193+
let permittedPrefixes = ["gov_action"]
194+
(prefix, dataPart) <-
195+
Bech32.decodeLenient bech32Str
196+
?!. Bech32DecodingError
197+
let actualPrefix = Bech32.humanReadablePartToText prefix
198+
guard (actualPrefix `elem` permittedPrefixes)
199+
?! Bech32UnexpectedPrefix actualPrefix (fromList permittedPrefixes)
200+
201+
payload <-
202+
Bech32.dataPartToBytes dataPart
203+
?! Bech32DataPartToBytesError (Bech32.dataPartToText dataPart)
204+
205+
case deserialiseFromRawBytes AsGovActionId payload of
206+
Right a -> Right a
207+
Left _ -> Left $ Bech32DeserialiseFromBytesError payload
208+
209+
instance HasTypeProxy Gov.GovActionId where
210+
data AsType Gov.GovActionId = AsGovActionId
211+
proxyToAsType _ = AsGovActionId
212+
213+
instance SerialiseAsRawBytes Gov.GovActionId where
214+
serialiseToRawBytes (Gov.GovActionId txid (Gov.GovActionIx ix)) =
215+
let hex = Base16.encode $ C8.pack $ show ix
216+
in mconcat [serialiseToRawBytes $ fromShelleyTxId txid, hex]
217+
deserialiseFromRawBytes AsGovActionId bytes = do
218+
let (txidBs, index) = BS.splitAt 32 bytes
219+
220+
txid <- deserialiseFromRawBytes AsTxId txidBs
221+
let asciiIndex = C8.unpack $ Base16.decodeLenient index
222+
case readMaybe asciiIndex of
223+
Just ix -> return $ Gov.GovActionId (toShelleyTxId txid) (Gov.GovActionIx ix)
224+
Nothing ->
225+
Left $ SerialiseAsRawBytesError $ "Unable to deserialise GovActionId: invalid index: " <> asciiIndex

‎cardano-api/src/Cardano/Api/Internal/Keys/Shelley.hs

+1
Original file line numberDiff line numberDiff line change
@@ -2045,6 +2045,7 @@ instance HasTextEnvelope (SigningKey DRepKey) where
20452045
---
20462046
--- Drep extended keys
20472047
---
2048+
20482049
data DRepExtendedKey
20492050

20502051
instance HasTypeProxy DRepExtendedKey where

‎cardano-api/src/Cardano/Api/Internal/SerialiseBech32.hs

+10
Original file line numberDiff line numberDiff line change
@@ -141,6 +141,11 @@ data Bech32DecodeError
141141
| -- | The human-readable prefix in the Bech32-encoded string does not
142142
-- correspond to the prefix that should be used for the payload value.
143143
Bech32WrongPrefix !Text !Text
144+
| Bech32UnexpectedHeader
145+
!Text
146+
-- ^ Expected header
147+
!Text
148+
-- ^ Unexpected header
144149
deriving (Eq, Show, Data)
145150

146151
instance Error Bech32DecodeError where
@@ -168,3 +173,8 @@ instance Error Bech32DecodeError where
168173
[ "Mismatch in the Bech32 prefix: the actual prefix is " <> pshow actual
169174
, ", but the prefix for this payload value should be " <> pshow expected
170175
]
176+
Bech32UnexpectedHeader expected actual ->
177+
mconcat
178+
[ "Unexpected CIP-129 Bech32 header: the actual header is " <> pshow actual
179+
, ", but it was expected to be " <> pshow expected
180+
]

‎cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs

+1
Original file line numberDiff line numberDiff line change
@@ -157,6 +157,7 @@ test_Bech32DecodeError =
157157
, Bech32DataPartToBytesError text
158158
, Bech32DeserialiseFromBytesError bytestring
159159
, Bech32WrongPrefix text text
160+
, Bech32UnexpectedHeader text text
160161
]
161162

162163
test_InputDecodeError :: TestTree

‎cardano-api/test/cardano-api-golden/files/golden/errors/Cardano.Api.Internal.SerialiseBech32.Bech32DecodeError/Bech32UnexpectedHeader.txt

+1
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
Unexpected CIP-129 Bech32 header: the actual header is "<text>", but it was expected to be "<text>"

0 commit comments

Comments
 (0)