Skip to content

Commit 6a22e35

Browse files
Jimbo4350Jimbo4350
committed
Add module Cardano.Api.DeserialiseAnyOf
1 parent 55ec227 commit 6a22e35

File tree

5 files changed

+335
-1
lines changed

5 files changed

+335
-1
lines changed

Diff for: ‎cardano-api/cardano-api.cabal

+1
Original file line numberDiff line numberDiff line change
@@ -57,6 +57,7 @@ library
5757
Cardano.Api.Convenience.Constraints
5858
Cardano.Api.Convenience.Construction
5959
Cardano.Api.Convenience.Query
60+
Cardano.Api.DeserialiseAnyOf
6061
Cardano.Api.Environment
6162
Cardano.Api.EraCast
6263
Cardano.Api.Eras

Diff for: ‎cardano-api/src/Cardano/Api.hs

+12
Original file line numberDiff line numberDiff line change
@@ -425,6 +425,17 @@ module Cardano.Api (
425425

426426
-- * Serialisation
427427
-- | Support for serialising data in JSON, CBOR and text files.
428+
InputFormat (..),
429+
InputDecodeError (..),
430+
deserialiseInput,
431+
deserialiseInputAnyOf,
432+
renderInputDecodeError,
433+
434+
SomeAddressVerificationKey(..),
435+
deserialiseAnyVerificationKey,
436+
deserialiseAnyVerificationKeyBech32,
437+
deserialiseAnyVerificationKeyTextEnvelope,
438+
renderSomeAddressVerificationKey,
428439

429440
-- ** CBOR
430441
SerialiseAsCBOR,
@@ -727,6 +738,7 @@ import Cardano.Api.Certificate
727738
import Cardano.Api.Convenience.Constraints
728739
import Cardano.Api.Convenience.Construction
729740
import Cardano.Api.Convenience.Query
741+
import Cardano.Api.DeserialiseAnyOf
730742
import Cardano.Api.Environment
731743
import Cardano.Api.EraCast
732744
import Cardano.Api.Eras

Diff for: ‎cardano-api/src/Cardano/Api/DeserialiseAnyOf.hs

+317
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,317 @@
1+
{-# LANGUAGE GADTs #-}
2+
{-# LANGUAGE ScopedTypeVariables #-}
3+
4+
-- | Class of errors used in the Api.
5+
--
6+
module Cardano.Api.DeserialiseAnyOf
7+
( InputFormat (..)
8+
, InputDecodeError (..)
9+
, deserialiseInput
10+
, deserialiseInputAnyOf
11+
, renderInputDecodeError
12+
13+
-- TODO: Consider moving everything below
14+
, SomeAddressVerificationKey(..)
15+
, deserialiseAnyVerificationKey
16+
, deserialiseAnyVerificationKeyBech32
17+
, deserialiseAnyVerificationKeyTextEnvelope
18+
, renderSomeAddressVerificationKey
19+
) where
20+
21+
import Prelude
22+
23+
import qualified Data.Aeson as Aeson
24+
import Data.Bifunctor (first)
25+
import Data.ByteString (ByteString)
26+
import qualified Data.ByteString.Char8 as BSC
27+
import Data.Char (toLower)
28+
import Data.List.NonEmpty (NonEmpty)
29+
import qualified Data.List.NonEmpty as NE
30+
import Data.Text (Text)
31+
import qualified Data.Text as Text
32+
import qualified Data.Text.Encoding as Text
33+
import Formatting (build, sformat, (%))
34+
35+
import qualified Cardano.Chain.Common as Common
36+
import qualified Cardano.Crypto.Signing as Crypto
37+
38+
import Cardano.Api.Error
39+
import Cardano.Api.SerialiseBech32
40+
import Cardano.Api.SerialiseRaw
41+
import Cardano.Api.SerialiseTextEnvelope
42+
43+
-- TODO: Think about if these belong
44+
import Cardano.Api.Address
45+
import Cardano.Api.Key
46+
import Cardano.Api.KeysByron
47+
import Cardano.Api.KeysPraos
48+
import Cardano.Api.KeysShelley
49+
50+
------------------------------------------------------------------------------
51+
-- Formatted/encoded input deserialisation
52+
------------------------------------------------------------------------------
53+
54+
-- | Input format/encoding.
55+
data InputFormat a where
56+
-- | Bech32 encoding.
57+
InputFormatBech32 :: SerialiseAsBech32 a => InputFormat a
58+
59+
-- | Hex/Base16 encoding.
60+
InputFormatHex :: SerialiseAsRawBytes a => InputFormat a
61+
62+
-- TODO: Specify TextEnvelope CBOR hex
63+
-- | Text envelope format.
64+
InputFormatTextEnvelope :: HasTextEnvelope a => InputFormat a
65+
66+
-- TODO: Add constructor for TextEnvelope Bech32
67+
68+
-- | Input decoding error.
69+
data InputDecodeError
70+
= InputTextEnvelopeError !TextEnvelopeError
71+
-- ^ The provided data seems to be a valid text envelope, but some error
72+
-- occurred in deserialising it.
73+
| InputBech32DecodeError !Bech32DecodeError
74+
-- ^ The provided data is valid Bech32, but some error occurred in
75+
-- deserialising it.
76+
| InputInvalidError
77+
-- ^ The provided data does not represent a valid value of the provided
78+
-- type.
79+
deriving (Eq, Show)
80+
instance Error InputDecodeError where
81+
displayError = Text.unpack . renderInputDecodeError
82+
83+
-- | Render an error message for a 'InputDecodeError'.
84+
renderInputDecodeError :: InputDecodeError -> Text
85+
renderInputDecodeError err =
86+
case err of
87+
InputTextEnvelopeError textEnvErr ->
88+
Text.pack (displayError textEnvErr)
89+
InputBech32DecodeError decodeErr ->
90+
Text.pack (displayError decodeErr)
91+
InputInvalidError -> "Invalid key."
92+
93+
-- | The result of a deserialisation function.
94+
--
95+
-- Note that this type isn't intended to be exported, but only used as a
96+
-- helper within the 'deserialiseInput' function.
97+
data DeserialiseInputResult a
98+
= DeserialiseInputSuccess !a
99+
-- ^ Input successfully deserialised.
100+
| DeserialiseInputError !InputDecodeError
101+
-- ^ The provided data is of the expected format/encoding, but an error
102+
-- occurred in deserialising it.
103+
| DeserialiseInputErrorFormatMismatch
104+
-- ^ The provided data's formatting/encoding does not match that which was
105+
-- expected. This error is an indication that one could attempt to
106+
-- deserialise the input again, but instead expecting a different format.
107+
108+
-- | Deserialise an input of some type that is formatted in some way.
109+
deserialiseInput
110+
:: forall a.
111+
AsType a
112+
-> NonEmpty (InputFormat a)
113+
-> ByteString
114+
-> Either InputDecodeError a
115+
deserialiseInput asType acceptedFormats inputBs =
116+
go (NE.toList acceptedFormats)
117+
where
118+
inputText :: Text
119+
inputText = Text.decodeUtf8 inputBs
120+
121+
go :: [InputFormat a] -> Either InputDecodeError a
122+
go [] = Left InputInvalidError
123+
go (kf:kfs) =
124+
let res =
125+
case kf of
126+
InputFormatBech32 -> deserialiseBech32
127+
InputFormatHex -> deserialiseHex
128+
InputFormatTextEnvelope -> deserialiseTextEnvelope
129+
in case res of
130+
DeserialiseInputSuccess a -> Right a
131+
DeserialiseInputError err -> Left err
132+
DeserialiseInputErrorFormatMismatch -> go kfs
133+
134+
deserialiseTextEnvelope :: HasTextEnvelope a => DeserialiseInputResult a
135+
deserialiseTextEnvelope = do
136+
let textEnvRes :: Either TextEnvelopeError a
137+
textEnvRes =
138+
deserialiseFromTextEnvelope asType
139+
=<< first TextEnvelopeAesonDecodeError (Aeson.eitherDecodeStrict' inputBs)
140+
case textEnvRes of
141+
Right res -> DeserialiseInputSuccess res
142+
143+
-- The input was valid a text envelope, but there was a type mismatch
144+
-- error.
145+
Left err@TextEnvelopeTypeError{} ->
146+
DeserialiseInputError (InputTextEnvelopeError err)
147+
148+
-- The input was not valid a text envelope.
149+
Left _ -> DeserialiseInputErrorFormatMismatch
150+
151+
deserialiseBech32 :: SerialiseAsBech32 a => DeserialiseInputResult a
152+
deserialiseBech32 =
153+
case deserialiseFromBech32 asType inputText of
154+
Right res -> DeserialiseInputSuccess res
155+
156+
-- The input was not valid Bech32.
157+
Left (Bech32DecodingError _) -> DeserialiseInputErrorFormatMismatch
158+
159+
-- The input was valid Bech32, but some other error occurred.
160+
Left err -> DeserialiseInputError $ InputBech32DecodeError err
161+
162+
deserialiseHex :: SerialiseAsRawBytes a => DeserialiseInputResult a
163+
deserialiseHex
164+
| isValidHex inputBs =
165+
case deserialiseFromRawBytesHex asType inputBs of
166+
Left _ -> DeserialiseInputError InputInvalidError
167+
Right x -> DeserialiseInputSuccess x
168+
| otherwise = DeserialiseInputErrorFormatMismatch
169+
170+
isValidHex :: ByteString -> Bool
171+
isValidHex x =
172+
all (`elem` hexAlpha) (toLower <$> BSC.unpack x)
173+
&& even (BSC.length x)
174+
where
175+
hexAlpha :: [Char]
176+
hexAlpha = "0123456789abcdef"
177+
178+
-- | Deserialise an input of some type that is formatted in some way.
179+
--
180+
-- The provided 'ByteString' can either be Bech32-encoded or in the text
181+
-- envelope format.
182+
deserialiseInputAnyOf
183+
:: forall b.
184+
[FromSomeType SerialiseAsBech32 b]
185+
-> [FromSomeType HasTextEnvelope b]
186+
-> ByteString
187+
-> Either InputDecodeError b
188+
deserialiseInputAnyOf bech32Types textEnvTypes inputBs =
189+
case deserialiseBech32 `orTry` deserialiseTextEnvelope of
190+
DeserialiseInputSuccess res -> Right res
191+
DeserialiseInputError err -> Left err
192+
DeserialiseInputErrorFormatMismatch -> Left InputInvalidError
193+
where
194+
inputText :: Text
195+
inputText = Text.decodeUtf8 inputBs
196+
197+
orTry
198+
:: DeserialiseInputResult b
199+
-> DeserialiseInputResult b
200+
-> DeserialiseInputResult b
201+
orTry x y =
202+
case x of
203+
DeserialiseInputSuccess _ -> x
204+
DeserialiseInputError _ -> x
205+
DeserialiseInputErrorFormatMismatch -> y
206+
207+
deserialiseTextEnvelope :: DeserialiseInputResult b
208+
deserialiseTextEnvelope = do
209+
let textEnvRes :: Either TextEnvelopeError b
210+
textEnvRes =
211+
deserialiseFromTextEnvelopeAnyOf textEnvTypes
212+
=<< first TextEnvelopeAesonDecodeError (Aeson.eitherDecodeStrict' inputBs)
213+
case textEnvRes of
214+
Right res -> DeserialiseInputSuccess res
215+
216+
-- The input was valid a text envelope, but there was a type mismatch
217+
-- error.
218+
Left err@TextEnvelopeTypeError{} ->
219+
DeserialiseInputError (InputTextEnvelopeError err)
220+
221+
-- The input was not valid a text envelope.
222+
Left _ -> DeserialiseInputErrorFormatMismatch
223+
224+
deserialiseBech32 :: DeserialiseInputResult b
225+
deserialiseBech32 =
226+
case deserialiseAnyOfFromBech32 bech32Types inputText of
227+
Right res -> DeserialiseInputSuccess res
228+
229+
-- The input was not valid Bech32.
230+
Left (Bech32DecodingError _) -> DeserialiseInputErrorFormatMismatch
231+
232+
-- The input was valid Bech32, but some other error occurred.
233+
Left err -> DeserialiseInputError $ InputBech32DecodeError err
234+
data SomeAddressVerificationKey
235+
= AByronVerificationKey (VerificationKey ByronKey)
236+
| APaymentVerificationKey (VerificationKey PaymentKey)
237+
| APaymentExtendedVerificationKey (VerificationKey PaymentExtendedKey)
238+
| AGenesisUTxOVerificationKey (VerificationKey GenesisUTxOKey)
239+
| AGenesisExtendedVerificationKey (VerificationKey GenesisExtendedKey)
240+
| AGenesisDelegateExtendedVerificationKey
241+
(VerificationKey GenesisDelegateExtendedKey)
242+
| AKesVerificationKey (VerificationKey KesKey)
243+
| AVrfVerificationKey (VerificationKey VrfKey)
244+
| AStakeVerificationKey (VerificationKey StakeKey)
245+
| AStakeExtendedVerificationKey (VerificationKey StakeExtendedKey)
246+
deriving (Show)
247+
248+
renderSomeAddressVerificationKey :: SomeAddressVerificationKey -> Text
249+
renderSomeAddressVerificationKey (AByronVerificationKey vk) = prettyByronVerificationKey vk
250+
renderSomeAddressVerificationKey (APaymentVerificationKey vk) = serialiseToBech32 vk
251+
renderSomeAddressVerificationKey (APaymentExtendedVerificationKey vk) = serialiseToBech32 vk
252+
renderSomeAddressVerificationKey (AGenesisUTxOVerificationKey vk) =
253+
serialiseToBech32 (castVerificationKey vk :: VerificationKey PaymentKey)
254+
renderSomeAddressVerificationKey (AGenesisExtendedVerificationKey vk) =
255+
let genKey = (castVerificationKey vk :: VerificationKey GenesisKey)
256+
payKey = (castVerificationKey genKey :: VerificationKey PaymentKey)
257+
in serialiseToBech32 payKey
258+
renderSomeAddressVerificationKey (AGenesisDelegateExtendedVerificationKey vk) =
259+
-- TODO: We could implement a CastVerificationKeyRole GenesisDelegateKey PaymentKey
260+
-- if we want to avoid casting twice.
261+
let genDelegKey = (castVerificationKey vk :: VerificationKey GenesisDelegateKey)
262+
stakePoolKey = castVerificationKey genDelegKey :: VerificationKey StakePoolKey
263+
in serialiseToBech32 stakePoolKey
264+
renderSomeAddressVerificationKey (AKesVerificationKey vk) = serialiseToBech32 vk
265+
renderSomeAddressVerificationKey (AVrfVerificationKey vk) = serialiseToBech32 vk
266+
renderSomeAddressVerificationKey (AStakeVerificationKey vk) = serialiseToBech32 vk
267+
renderSomeAddressVerificationKey (AStakeExtendedVerificationKey vk) = serialiseToBech32 vk
268+
269+
-- | Internal function to pretty render byron keys
270+
prettyByronVerificationKey :: VerificationKey ByronKey-> Text
271+
prettyByronVerificationKey (ByronVerificationKey vk) =
272+
sformat ( " public key hash: " % build %
273+
"\npublic key (base64): " % Crypto.fullVerificationKeyF %
274+
"\n public key (hex): " % Crypto.fullVerificationKeyHexF)
275+
(Common.addressHash vk) vk vk
276+
277+
deserialiseAnyVerificationKey
278+
:: ByteString -> Either InputDecodeError SomeAddressVerificationKey
279+
deserialiseAnyVerificationKey bs =
280+
case deserialiseAnyVerificationKeyBech32 bs of
281+
Right vk -> Right vk
282+
Left _e ->
283+
case deserialiseAnyVerificationKeyTextEnvelope bs of
284+
Right vk -> Right vk
285+
Left _e -> Left InputInvalidError
286+
287+
deserialiseAnyVerificationKeyBech32
288+
:: ByteString -> Either Bech32DecodeError SomeAddressVerificationKey
289+
deserialiseAnyVerificationKeyBech32 =
290+
deserialiseAnyOfFromBech32 allBech32VerKey . Text.decodeUtf8
291+
where
292+
allBech32VerKey
293+
:: [FromSomeType SerialiseAsBech32 SomeAddressVerificationKey]
294+
allBech32VerKey =
295+
[ FromSomeType (AsVerificationKey AsPaymentKey) APaymentVerificationKey
296+
, FromSomeType (AsVerificationKey AsPaymentExtendedKey) APaymentExtendedVerificationKey
297+
, FromSomeType (AsVerificationKey AsKesKey) AKesVerificationKey
298+
, FromSomeType (AsVerificationKey AsVrfKey) AVrfVerificationKey
299+
, FromSomeType (AsVerificationKey AsStakeKey) AStakeVerificationKey
300+
, FromSomeType (AsVerificationKey AsStakeExtendedKey) AStakeExtendedVerificationKey
301+
]
302+
303+
deserialiseAnyVerificationKeyTextEnvelope
304+
:: ByteString -> Either TextEnvelopeError SomeAddressVerificationKey
305+
deserialiseAnyVerificationKeyTextEnvelope bs =
306+
deserialiseFromTextEnvelopeAnyOf allTextEnvelopeCBOR
307+
=<< first TextEnvelopeAesonDecodeError (Aeson.eitherDecodeStrict' bs)
308+
where
309+
allTextEnvelopeCBOR
310+
:: [FromSomeType HasTextEnvelope SomeAddressVerificationKey]
311+
allTextEnvelopeCBOR =
312+
[ FromSomeType (AsVerificationKey AsByronKey) AByronVerificationKey
313+
, FromSomeType (AsVerificationKey AsPaymentKey) APaymentVerificationKey
314+
, FromSomeType (AsVerificationKey AsPaymentExtendedKey) APaymentExtendedVerificationKey
315+
, FromSomeType (AsVerificationKey AsGenesisUTxOKey) AGenesisUTxOVerificationKey
316+
]
317+

Diff for: ‎cardano-api/src/Cardano/Api/Key.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -11,7 +11,7 @@ module Cardano.Api.Key
1111
, AsType(AsVerificationKey, AsSigningKey)
1212
) where
1313

14-
import Prelude
14+
import Prelude
1515

1616
import Data.Kind (Type)
1717

Diff for: ‎cardano-api/src/Cardano/Api/KeysShelley.hs

+4
Original file line numberDiff line numberDiff line change
@@ -645,6 +645,10 @@ instance HasTextEnvelope (SigningKey GenesisKey) where
645645
proxy :: Proxy (Shelley.DSIGN StandardCrypto)
646646
proxy = Proxy
647647

648+
instance CastVerificationKeyRole GenesisKey PaymentKey where
649+
castVerificationKey (GenesisVerificationKey (Shelley.VKey vk)) =
650+
PaymentVerificationKey (Shelley.VKey vk)
651+
648652

649653
--
650654
-- Shelley genesis extended ed25519 keys

0 commit comments

Comments
 (0)