{-# 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 = forall a. Format String a -> a
formatToString 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 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

-- | 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 = forall b.
(ByteString -> Either DecoderError b)
-> Text -> Either DecoderError b
withHexText 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 = 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))) =>
  -- | 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 <- 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 #-}

-- | 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
  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 #-}

-- <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
    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 #-}