{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | Module that re-exports everythign from `cardano-binary` package.
--
-- Everything that gets defined in this module should most likely be migrated to
-- `cardano-binary` package.
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,

  -- * DSIGN
  C.encodeVerKeyDSIGN,
  C.decodeVerKeyDSIGN,
  C.encodeSignKeyDSIGN,
  C.decodeSignKeyDSIGN,
  C.encodeSigDSIGN,
  C.decodeSigDSIGN,
  C.encodeSignedDSIGN,
  C.decodeSignedDSIGN,

  -- * KES
  C.encodeVerKeyKES,
  C.decodeVerKeyKES,
  C.encodeSignKeyKES,
  C.decodeSignKeyKES,
  C.encodeSigKES,
  C.decodeSigKES,
  C.encodeSignedKES,
  C.decodeSignedKES,

  -- * VRF
  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 = Format String (e -> String) -> e -> String
forall a. Format String a -> a
formatToString Format String (e -> String)
forall a r. Buildable a => Format r (a -> r)
build

-- | Encode a type as CBOR and encode it as base16
serializeAsHexText :: ToCBOR a => a -> Text.Text
serializeAsHexText :: forall a. ToCBOR a => a -> Text
serializeAsHexText = ByteString -> Text
Text.decodeLatin1 (ByteString -> Text) -> (a -> ByteString) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B16.encode (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
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 -> DecoderError -> Either DecoderError b
forall a b. a -> Either a b
Left (DecoderError -> Either DecoderError b)
-> DecoderError -> Either DecoderError b
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

-- | Try decoding base16 encode bytes and then try to decoding them as CBOR
decodeFullFromHexText :: FromCBOR a => Text.Text -> Either DecoderError a
decodeFullFromHexText :: forall a. FromCBOR a => Text -> Either DecoderError a
decodeFullFromHexText = (ByteString -> Either DecoderError a)
-> Text -> Either DecoderError a
forall b.
(ByteString -> Either DecoderError b)
-> Text -> Either DecoderError b
withHexText ByteString -> Either DecoderError a
forall a. FromCBOR a => ByteString -> Either DecoderError a
decodeFull'

-- | Report an error when a numeric key of the type constructor doesn't match.
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 = DecoderError -> m a
forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError (DecoderError -> m a) -> DecoderError -> m a
forall a b. (a -> b) -> a -> b
$ Text -> Text -> DecoderError
DecoderErrorCustom Text
msg (String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word -> String
forall a. Show a => a -> String
show Word
k)
  where
    msg :: Text
msg = String -> Text
Text.pack (TypeRep -> String
forall a. Show a => a -> String
show (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a))) Text -> Text -> Text
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 =
  IdentityT (Decoder s) a -> Decoder s a
forall {k} (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT (IdentityT (Decoder s) a -> Decoder s a)
-> IdentityT (Decoder s) a -> Decoder s a
forall a b. (a -> b) -> a -> b
$ Text
-> (a -> Int) -> IdentityT (Decoder s) a -> IdentityT (Decoder s) a
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 (Decoder s a -> IdentityT (Decoder s) a
forall (m :: * -> *) a. Monad m => m a -> IdentityT m a
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 =
  Text
-> m (Decoder s) a
-> (a -> Int -> m (Decoder s) ())
-> m (Decoder s) a
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) ()) -> m (Decoder s) a)
-> (a -> Int -> m (Decoder s) ()) -> m (Decoder s) a
forall a b. (a -> b) -> a -> b
$ \a
result Int
n ->
    Decoder s () -> m (Decoder s) ()
forall (m :: * -> *) a. Monad m => m a -> m m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Decoder s () -> m (Decoder s) ())
-> Decoder s () -> m (Decoder s) ()
forall a b. (a -> b) -> a -> b
$ Text -> Int -> Int -> Decoder s ()
forall s. Text -> Int -> Int -> Decoder s ()
matchSize (Text
"Record " Text -> Text -> Text
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 =
  IdentityT (Decoder s) a -> Decoder s a
forall {k} (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT (IdentityT (Decoder s) a -> Decoder s a)
-> IdentityT (Decoder s) a -> Decoder s a
forall a b. (a -> b) -> a -> b
$
    (Int, a) -> a
forall a b. (a, b) -> b
snd ((Int, a) -> a)
-> IdentityT (Decoder s) (Int, a) -> IdentityT (Decoder s) a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
      Text
-> IdentityT (Decoder s) (Int, a)
-> ((Int, a) -> Int -> IdentityT (Decoder s) ())
-> IdentityT (Decoder s) (Int, a)
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 (Decoder s (Int, a) -> IdentityT (Decoder s) (Int, a)
forall (m :: * -> *) a. Monad m => m a -> IdentityT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Decoder s Word
forall s. Decoder s Word
decodeWord Decoder s Word
-> (Word -> Decoder s (Int, a)) -> Decoder s (Int, a)
forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word -> Decoder s (Int, a)
decoder)) (((Int, a) -> Int -> IdentityT (Decoder s) ())
 -> IdentityT (Decoder s) (Int, a))
-> ((Int, a) -> Int -> IdentityT (Decoder s) ())
-> IdentityT (Decoder s) (Int, a)
forall a b. (a -> b) -> a -> b
$ \(Int
size, a
_) Int
n ->
        Decoder s () -> IdentityT (Decoder s) ()
forall (m :: * -> *) a. Monad m => m a -> IdentityT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Decoder s () -> IdentityT (Decoder s) ())
-> Decoder s () -> IdentityT (Decoder s) ()
forall a b. (a -> b) -> a -> b
$ Text -> Int -> Int -> Decoder s ()
forall s. Text -> Int -> Int -> Decoder s ()
matchSize (String -> Text
Text.pack String
"Sum " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name) Int
size Int
n
{-# INLINE decodeRecordSum #-}

decodeListLikeT ::
  (MonadTrans m, Monad (m (Decoder s))) =>
  -- | Name for error reporting
  Text.Text ->
  -- | Decoder for the datastructure itself
  m (Decoder s) a ->
  -- | In case when length was provided, act upon it.
  (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 <- Decoder s (Maybe Int) -> m (Decoder s) (Maybe Int)
forall (m :: * -> *) a. Monad m => m a -> m m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Decoder s (Maybe Int)
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 -> Decoder s () -> m (Decoder s) ()
forall (m :: * -> *) a. Monad m => m a -> m m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Decoder s () -> m (Decoder s) ())
-> Decoder s () -> m (Decoder s) ()
forall a b. (a -> b) -> a -> b
$ do
      Bool
isBreak <- Decoder s Bool
forall s. Decoder s Bool
decodeBreakOr
      Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isBreak (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$ DecoderError -> Decoder s ()
forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError (DecoderError -> Decoder s ()) -> DecoderError -> Decoder s ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> DecoderError
DecoderErrorCustom Text
name Text
"Excess terms in array"
  a -> m (Decoder s) a
forall a. a -> m (Decoder s) a
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 (Int -> Encoding) -> (a -> Int) -> a -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
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 <- Decoder s Int
forall s. Decoder s Int
decodeInt
  if a -> Int
forall a. Enum a => a -> Int
fromEnum (a
forall a. Bounded a => a
minBound :: a) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= a -> Int
forall a. Enum a => a -> Int
fromEnum (a
forall a. Bounded a => a
maxBound :: a)
    then a -> Decoder s a
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Decoder s a) -> a -> Decoder s a
forall a b. (a -> b) -> a -> b
$ Int -> a
forall a. Enum a => Int -> a
toEnum Int
n
    else String -> Decoder s a
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s a) -> String -> Decoder s a
forall a b. (a -> b) -> a -> b
$ String
"Failed to decode an Enum: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" for TypeRep: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TypeRep -> String
forall a. Show a => a -> String
show (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a))
{-# INLINE decodeEnumBounded #-}

-- | Enforces tag 30 to indicate a rational number, as per tag assignment:
-- <https://www.iana.org/assignments/cbor-tags/cbor-tags.xhtml>
--
-- <https://peteroupc.github.io/CBOR/rational.html>
decodeRationalWithTag :: Decoder s Rational
decodeRationalWithTag :: forall s. Decoder s Rational
decodeRationalWithTag = do
  Word -> Decoder s ()
forall s. Word -> Decoder s ()
assertTag Word
30
  (Int
numValues, [Integer]
values) <- Decoder s (Maybe Int)
-> Decoder s Integer -> Decoder s (Int, [Integer])
forall s v.
Decoder s (Maybe Int) -> Decoder s v -> Decoder s (Int, [v])
decodeCollectionWithLen Decoder s (Maybe Int)
forall s. Decoder s (Maybe Int)
decodeListLenOrIndef Decoder s Integer
forall s. Decoder s Integer
decodeInteger
  case [Integer]
values of
    [Integer
n, Integer
d] -> do
      Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0) (String -> Decoder s ()
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Denominator cannot be zero")
      Rational -> Decoder s Rational
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rational -> Decoder s Rational) -> Rational -> Decoder s Rational
forall a b. (a -> b) -> a -> b
$! Integer
n Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
d
    [Integer]
_ -> DecoderError -> Decoder s Rational
forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError (DecoderError -> Decoder s Rational)
-> DecoderError -> Decoder s Rational
forall a b. (a -> b) -> a -> b
$ Text -> Int -> Int -> DecoderError
DecoderErrorSizeMismatch Text
"Rational" Int
2 Int
numValues
{-# INLINE decodeRationalWithTag #-}

-- <https://www.iana.org/assignments/cbor-tags/cbor-tags.xhtml>
--
-- <https://peteroupc.github.io/CBOR/rational.html>
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
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
encodeListLen Word
2
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> t -> Encoding
encodeNumeric (Ratio t -> t
forall a. Ratio a -> a
numerator Ratio t
r)
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> t -> Encoding
encodeNumeric (Ratio t -> t
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 <-
    Decoder s (Maybe Word64)
forall s. Decoder s (Maybe Word64)
decodeTagMaybe Decoder s (Maybe Word64)
-> (Maybe Word64 -> Decoder s Word64) -> Decoder s Word64
forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just Word64
tag -> Word64 -> Decoder s Word64
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
tag
      Maybe Word64
Nothing -> String -> Decoder s Word64
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected tag"
  Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word64
tagReceived Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== (Word -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
tagExpected :: Word64)) (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$
    String -> Decoder s ()
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s ()) -> String -> Decoder s ()
forall a b. (a -> b) -> a -> b
$
      String
"Expecteg tag " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word -> String
forall a. Show a => a -> String
show Word
tagExpected String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" but got tag " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a. Show a => a -> String
show Word64
tagReceived
{-# INLINE assertTag #-}

decodeTagMaybe :: Decoder s (Maybe Word64)
decodeTagMaybe :: forall s. Decoder s (Maybe Word64)
decodeTagMaybe =
  Decoder s TokenType
forall s. Decoder s TokenType
peekTokenType Decoder s TokenType
-> (TokenType -> Decoder s (Maybe Word64))
-> Decoder s (Maybe Word64)
forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    TokenType
TypeTag -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just (Word64 -> Maybe Word64)
-> (Word -> Word64) -> Word -> Maybe Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Maybe Word64)
-> Decoder s Word -> Decoder s (Maybe Word64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Word
forall s. Decoder s Word
decodeTag
    TokenType
TypeTag64 -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just (Word64 -> Maybe Word64)
-> Decoder s Word64 -> Decoder s (Maybe Word64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Word64
forall s. Decoder s Word64
decodeTag64
    TokenType
_ -> Maybe Word64 -> Decoder s (Maybe Word64)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Word64
forall a. Maybe a
Nothing
{-# INLINE decodeTagMaybe #-}