{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Cardano.Ledger.Binary.Plain (
module Cardano.Binary,
module Codec.CBOR.Term,
showDecoderError,
invalidKey,
decodeRecordNamed,
decodeRecordNamedT,
decodeRecordSum,
decodeListLikeT,
serializeAsHexText,
decodeFullFromHexText,
encodeEnum,
decodeEnumBounded,
withHexText,
assertTag,
decodeTagMaybe,
decodeRationalWithTag,
encodeRatioWithTag,
C.encodeVerKeyDSIGN,
C.decodeVerKeyDSIGN,
C.encodeSignKeyDSIGN,
C.decodeSignKeyDSIGN,
C.encodeSigDSIGN,
C.decodeSigDSIGN,
C.encodeSignedDSIGN,
C.decodeSignedDSIGN,
C.encodeVerKeyKES,
C.decodeVerKeyKES,
C.encodeSignKeyKES,
C.decodeSignKeyKES,
C.encodeSigKES,
C.decodeSigKES,
C.encodeSignedKES,
C.decodeSignedKES,
C.encodeVerKeyVRF,
C.decodeVerKeyVRF,
C.encodeSignKeyVRF,
C.decodeSignKeyVRF,
C.encodeCertVRF,
C.decodeCertVRF,
)
where
import Cardano.Binary hiding (encodedSizeExpr)
import qualified Cardano.Crypto.DSIGN.Class as C
import qualified Cardano.Crypto.KES.Class as C
import qualified Cardano.Crypto.VRF.Class as C
import Codec.CBOR.Term
import Control.Monad (unless, when)
import Control.Monad.Trans (MonadTrans (..))
import Control.Monad.Trans.Identity (IdentityT (runIdentityT))
import Data.ByteString (ByteString)
import Data.ByteString.Base16 as B16
import Data.Ratio (Ratio, denominator, numerator, (%))
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Typeable
import Data.Word (Word64)
import Formatting (build, formatToString)
import qualified Formatting.Buildable as B (Buildable (..))
showDecoderError :: B.Buildable e => e -> String
showDecoderError :: forall e. Buildable e => e -> String
showDecoderError = forall a. Format String a -> a
formatToString forall a r. Buildable a => Format r (a -> r)
build
serializeAsHexText :: ToCBOR a => a -> Text.Text
serializeAsHexText :: forall a. ToCBOR a => a -> Text
serializeAsHexText = ByteString -> Text
Text.decodeLatin1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B16.encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToCBOR a => a -> ByteString
serialize'
withHexText :: (ByteString -> Either DecoderError b) -> Text.Text -> Either DecoderError b
withHexText :: forall b.
(ByteString -> Either DecoderError b)
-> Text -> Either DecoderError b
withHexText ByteString -> Either DecoderError b
f Text
txt =
case ByteString -> Either String ByteString
B16.decode (Text -> ByteString
Text.encodeUtf8 Text
txt) of
Left String
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> Text -> DecoderError
DecoderErrorCustom Text
"Invalid Hex encoding:" (String -> Text
Text.pack String
err)
Right ByteString
bs -> ByteString -> Either DecoderError b
f ByteString
bs
decodeFullFromHexText :: FromCBOR a => Text.Text -> Either DecoderError a
decodeFullFromHexText :: forall a. FromCBOR a => Text -> Either DecoderError a
decodeFullFromHexText = forall b.
(ByteString -> Either DecoderError b)
-> Text -> Either DecoderError b
withHexText forall a. FromCBOR a => ByteString -> Either DecoderError a
decodeFull'
invalidKey :: forall a m. (Typeable a, MonadFail m) => Word -> m a
invalidKey :: forall a (m :: * -> *). (Typeable a, MonadFail m) => Word -> m a
invalidKey Word
k = forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError forall a b. (a -> b) -> a -> b
$ Text -> Text -> DecoderError
DecoderErrorCustom Text
msg (String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Word
k)
where
msg :: Text
msg = String -> Text
Text.pack (forall a. Show a => a -> String
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy @a))) forall a. Semigroup a => a -> a -> a
<> Text
" not a valid key:"
decodeRecordNamed :: Text.Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed :: forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
name a -> Int
getRecordSize Decoder s a
decoder =
forall {k} (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT forall a b. (a -> b) -> a -> b
$ forall (m :: (* -> *) -> * -> *) s a.
(MonadTrans m, Monad (m (Decoder s))) =>
Text -> (a -> Int) -> m (Decoder s) a -> m (Decoder s) a
decodeRecordNamedT Text
name a -> Int
getRecordSize (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Decoder s a
decoder)
{-# INLINE decodeRecordNamed #-}
decodeRecordNamedT ::
(MonadTrans m, Monad (m (Decoder s))) =>
Text.Text ->
(a -> Int) ->
m (Decoder s) a ->
m (Decoder s) a
decodeRecordNamedT :: forall (m :: (* -> *) -> * -> *) s a.
(MonadTrans m, Monad (m (Decoder s))) =>
Text -> (a -> Int) -> m (Decoder s) a -> m (Decoder s) a
decodeRecordNamedT Text
name a -> Int
getRecordSize m (Decoder s) a
decoder =
forall (m :: (* -> *) -> * -> *) s a.
(MonadTrans m, Monad (m (Decoder s))) =>
Text
-> m (Decoder s) a
-> (a -> Int -> m (Decoder s) ())
-> m (Decoder s) a
decodeListLikeT Text
name m (Decoder s) a
decoder forall a b. (a -> b) -> a -> b
$ \a
result Int
n ->
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s. Text -> Int -> Int -> Decoder s ()
matchSize (Text
"Record " forall a. Semigroup a => a -> a -> a
<> Text
name) Int
n (a -> Int
getRecordSize a
result)
{-# INLINE decodeRecordNamedT #-}
decodeRecordSum :: Text.Text -> (Word -> Decoder s (Int, a)) -> Decoder s a
decodeRecordSum :: forall s a. Text -> (Word -> Decoder s (Int, a)) -> Decoder s a
decodeRecordSum Text
name Word -> Decoder s (Int, a)
decoder =
forall {k} (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT forall a b. (a -> b) -> a -> b
$
forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
forall (m :: (* -> *) -> * -> *) s a.
(MonadTrans m, Monad (m (Decoder s))) =>
Text
-> m (Decoder s) a
-> (a -> Int -> m (Decoder s) ())
-> m (Decoder s) a
decodeListLikeT Text
name (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall s. Decoder s Word
decodeWord forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word -> Decoder s (Int, a)
decoder)) forall a b. (a -> b) -> a -> b
$ \(Int
size, a
_) Int
n ->
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s. Text -> Int -> Int -> Decoder s ()
matchSize (String -> Text
Text.pack String
"Sum " forall a. Semigroup a => a -> a -> a
<> Text
name) Int
size Int
n
{-# INLINE decodeRecordSum #-}
decodeListLikeT ::
(MonadTrans m, Monad (m (Decoder s))) =>
Text.Text ->
m (Decoder s) a ->
(a -> Int -> m (Decoder s) ()) ->
m (Decoder s) a
decodeListLikeT :: forall (m :: (* -> *) -> * -> *) s a.
(MonadTrans m, Monad (m (Decoder s))) =>
Text
-> m (Decoder s) a
-> (a -> Int -> m (Decoder s) ())
-> m (Decoder s) a
decodeListLikeT Text
name m (Decoder s) a
decoder a -> Int -> m (Decoder s) ()
actOnLength = do
Maybe Int
lenOrIndef <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall s. Decoder s (Maybe Int)
decodeListLenOrIndef
a
result <- m (Decoder s) a
decoder
case Maybe Int
lenOrIndef of
Just Int
n -> a -> Int -> m (Decoder s) ()
actOnLength a
result Int
n
Maybe Int
Nothing -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
Bool
isBreak <- forall s. Decoder s Bool
decodeBreakOr
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isBreak forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError forall a b. (a -> b) -> a -> b
$ Text -> Text -> DecoderError
DecoderErrorCustom Text
name Text
"Excess terms in array"
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result
{-# INLINE decodeListLikeT #-}
encodeEnum :: Enum a => a -> Encoding
encodeEnum :: forall a. Enum a => a -> Encoding
encodeEnum = Int -> Encoding
encodeInt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum
decodeEnumBounded :: forall a s. (Enum a, Bounded a, Typeable a) => Decoder s a
decodeEnumBounded :: forall a s. (Enum a, Bounded a, Typeable a) => Decoder s a
decodeEnumBounded = do
Int
n <- forall s. Decoder s Int
decodeInt
if forall a. Enum a => a -> Int
fromEnum (forall a. Bounded a => a
minBound :: a) forall a. Ord a => a -> a -> Bool
<= Int
n Bool -> Bool -> Bool
&& Int
n forall a. Ord a => a -> a -> Bool
<= forall a. Enum a => a -> Int
fromEnum (forall a. Bounded a => a
maxBound :: a)
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Enum a => Int -> a
toEnum Int
n
else forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Failed to decode an Enum: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
n forall a. Semigroup a => a -> a -> a
<> String
" for TypeRep: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy @a))
{-# INLINE decodeEnumBounded #-}
decodeRationalWithTag :: Decoder s Rational
decodeRationalWithTag :: forall s. Decoder s Rational
decodeRationalWithTag = do
forall s. Word -> Decoder s ()
assertTag Word
30
(Int
numValues, [Integer]
values) <- forall s v.
Decoder s (Maybe Int) -> Decoder s v -> Decoder s (Int, [v])
decodeCollectionWithLen forall s. Decoder s (Maybe Int)
decodeListLenOrIndef forall s. Decoder s Integer
decodeInteger
case [Integer]
values of
[Integer
n, Integer
d] -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
d forall a. Eq a => a -> a -> Bool
== Integer
0) (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Denominator cannot be zero")
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! Integer
n forall a. Integral a => a -> a -> Ratio a
% Integer
d
[Integer]
_ -> forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError forall a b. (a -> b) -> a -> b
$ Text -> Int -> Int -> DecoderError
DecoderErrorSizeMismatch Text
"Rational" Int
2 Int
numValues
{-# INLINE decodeRationalWithTag #-}
encodeRatioWithTag :: (t -> Encoding) -> Ratio t -> Encoding
encodeRatioWithTag :: forall t. (t -> Encoding) -> Ratio t -> Encoding
encodeRatioWithTag t -> Encoding
encodeNumeric Ratio t
r =
Word -> Encoding
encodeTag Word
30
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
encodeListLen Word
2
forall a. Semigroup a => a -> a -> a
<> t -> Encoding
encodeNumeric (forall a. Ratio a -> a
numerator Ratio t
r)
forall a. Semigroup a => a -> a -> a
<> t -> Encoding
encodeNumeric (forall a. Ratio a -> a
denominator Ratio t
r)
assertTag :: Word -> Decoder s ()
assertTag :: forall s. Word -> Decoder s ()
assertTag Word
tagExpected = do
Word64
tagReceived <-
forall s. Decoder s (Maybe Word64)
decodeTagMaybe forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Word64
tag -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
tag
Maybe Word64
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected tag"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word64
tagReceived forall a. Eq a => a -> a -> Bool
== (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
tagExpected :: Word64)) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
String
"Expecteg tag " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Word
tagExpected forall a. Semigroup a => a -> a -> a
<> String
" but got tag " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Word64
tagReceived
{-# INLINE assertTag #-}
decodeTagMaybe :: Decoder s (Maybe Word64)
decodeTagMaybe :: forall s. Decoder s (Maybe Word64)
decodeTagMaybe =
forall s. Decoder s TokenType
peekTokenType forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
TokenType
TypeTag -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Word
decodeTag
TokenType
TypeTag64 -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Word64
decodeTag64
TokenType
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
{-# INLINE decodeTagMaybe #-}