{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | CBOR encoding utilities needed for the Byron transaction format
module Cardano.Chain.Common.CBOR (
  -- * CBOR in CBOR

  -- | These utilities are is used in the Byron-era chain encodings in cases
  -- where there are extensible parts of the encoding. In thse cases we have to
  -- be able to handle unknown extensions and thus decode values where we do
  -- not know the concrete type.
  --
  -- To solve this, the serialised representation uses nested CBOR-in-CBOR
  -- <https://tools.ietf.org/html/rfc7049#section-2.4.4.1>. The nesting means
  -- that the size is known without having to decode the body in those cases
  -- where we cannot decode the body.
  --
  -- The functions in this module handle the encoding and decoding for the
  -- cases of the known and unknown types.
  encodeKnownCborDataItem,
  encodeUnknownCborDataItem,
  knownCborDataItemSizeExpr,
  unknownCborDataItemSizeExpr,
  decodeKnownCborDataItem,
  decodeUnknownCborDataItem,

  -- * Cyclic redundancy check

  -- | The Byron era address format includes a CRC to help resist accidental
  -- corruption. These functions deal with encoding and decoding the format
  -- that is used.
  encodeCrcProtected,
  encodedCrcProtectedSizeExpr,
  decodeCrcProtected,
) where

import Cardano.Ledger.Binary (
  DecCBOR (..),
  Decoder,
  EncCBOR (..),
  Encoding,
  Size,
  byronProtVer,
  cborError,
  decodeFull',
  decodeNestedCbor,
  decodeNestedCborBytes,
  encodeListLen,
  encodeNestedCbor,
  encodeNestedCborBytes,
  enforceSize,
  nestedCborBytesSizeExpr,
  nestedCborSizeExpr,
  serialize,
  toCborError,
 )
import Cardano.Prelude hiding (cborError, toCborError)
import Data.Digest.CRC32 (CRC32 (..))
import Formatting (Format, sformat, shown)

-- | This is an alias for 'encodeNestedCbor'.
--
-- This function is used to handle the case of a known type, but compatible
-- with the encoding used by 'encodeUnknownCborDataItem'.
encodeKnownCborDataItem :: EncCBOR a => a -> Encoding
encodeKnownCborDataItem :: forall a. EncCBOR a => a -> Encoding
encodeKnownCborDataItem = a -> Encoding
forall a. EncCBOR a => a -> Encoding
encodeNestedCbor

-- | This is an alias for 'encodeNestedCborBytes', so all its details apply.
--
-- This function is used to handle the case of an unknown type, so it takes an
-- opaque blob that is the representation of the value of the unknown type.
encodeUnknownCborDataItem :: LByteString -> Encoding
encodeUnknownCborDataItem :: LByteString -> Encoding
encodeUnknownCborDataItem = LByteString -> Encoding
encodeNestedCborBytes

knownCborDataItemSizeExpr :: Size -> Size
knownCborDataItemSizeExpr :: Size -> Size
knownCborDataItemSizeExpr = Size -> Size
nestedCborSizeExpr

unknownCborDataItemSizeExpr :: Size -> Size
unknownCborDataItemSizeExpr :: Size -> Size
unknownCborDataItemSizeExpr = Size -> Size
nestedCborBytesSizeExpr

-- | This is an alias for 'decodeNestedCbor'.
--
-- This function is used to handle the case of a known type, but compatible
-- with the encoding used by 'decodeUnknownCborDataItem'.
decodeKnownCborDataItem :: DecCBOR a => Decoder s a
decodeKnownCborDataItem :: forall a s. DecCBOR a => Decoder s a
decodeKnownCborDataItem = Decoder s a
forall a s. DecCBOR a => Decoder s a
decodeNestedCbor

-- | This is an alias for 'decodeNestedCborBytes', so all its details apply.
--
-- This function is used to handle the case of an unknown type, so it returns
-- an opaque blob that is the representation of the value of the unknown type.
decodeUnknownCborDataItem :: Decoder s ByteString
decodeUnknownCborDataItem :: forall s. Decoder s ByteString
decodeUnknownCborDataItem = Decoder s ByteString
forall s. Decoder s ByteString
decodeNestedCborBytes

--------------------------------------------------------------------------------
-- Cyclic redundancy check
--------------------------------------------------------------------------------

-- | Encodes a value of type @a@, protecting it from accidental corruption by
-- protecting it with a CRC.
encodeCrcProtected :: EncCBOR a => a -> Encoding
encodeCrcProtected :: forall a. EncCBOR a => a -> Encoding
encodeCrcProtected a
x =
  Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> LByteString -> Encoding
encodeUnknownCborDataItem LByteString
body Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word32 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (LByteString -> Word32
forall a. CRC32 a => a -> Word32
crc32 LByteString
body)
  where
    body :: LByteString
body = Version -> a -> LByteString
forall a. EncCBOR a => Version -> a -> LByteString
serialize Version
byronProtVer a
x

encodedCrcProtectedSizeExpr ::
  forall a.
  EncCBOR a =>
  (forall t. EncCBOR t => Proxy t -> Size) ->
  Proxy a ->
  Size
encodedCrcProtectedSizeExpr :: forall a.
EncCBOR a =>
(forall t. EncCBOR t => Proxy t -> Size) -> Proxy a -> Size
encodedCrcProtectedSizeExpr forall t. EncCBOR t => Proxy t -> Size
size Proxy a
pxy =
  Size
2
    Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size -> Size
unknownCborDataItemSizeExpr (Proxy a -> Size
forall t. EncCBOR t => Proxy t -> Size
size Proxy a
pxy)
    Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Proxy Word32 -> Size
forall t. EncCBOR t => Proxy t -> Size
size (Word32 -> Proxy Word32
forall a. a -> Proxy a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word32 -> Proxy Word32) -> Word32 -> Proxy Word32
forall a b. (a -> b) -> a -> b
$ LByteString -> Word32
forall a. CRC32 a => a -> Word32
crc32 (Version -> a -> LByteString
forall a. EncCBOR a => Version -> a -> LByteString
serialize Version
byronProtVer (Text -> a
forall a. HasCallStack => Text -> a
panic Text
"unused" :: a)))

-- | Decodes a CBOR blob into a value of type @a@, checking the serialised CRC
--   corresponds to the computed one
decodeCrcProtected :: forall s a. DecCBOR a => Decoder s a
decodeCrcProtected :: forall s a. DecCBOR a => Decoder s a
decodeCrcProtected = do
  Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize (Text
"decodeCrcProtected: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeRep -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show (Proxy a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a))) Int
2
  ByteString
body <- Decoder s ByteString
forall s. Decoder s ByteString
decodeUnknownCborDataItem
  Word32
expectedCrc <- Decoder s Word32
forall s. Decoder s Word32
forall a s. DecCBOR a => Decoder s a
decCBOR
  let actualCrc :: Word32
      actualCrc :: Word32
actualCrc = ByteString -> Word32
forall a. CRC32 a => a -> Word32
crc32 ByteString
body
  let crcErrorFmt :: Format r (Word32 -> Word32 -> r)
      crcErrorFmt :: forall r. Format r (Word32 -> Word32 -> r)
crcErrorFmt =
        Format (Word32 -> Word32 -> r) (Word32 -> Word32 -> r)
"decodeCrcProtected, expected CRC "
          Format (Word32 -> Word32 -> r) (Word32 -> Word32 -> r)
-> Format r (Word32 -> Word32 -> r)
-> Format r (Word32 -> Word32 -> r)
forall b c a. Format b c -> Format a b -> Format a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (Word32 -> r) (Word32 -> Word32 -> r)
forall a r. Show a => Format r (a -> r)
shown
          Format (Word32 -> r) (Word32 -> Word32 -> r)
-> Format r (Word32 -> r) -> Format r (Word32 -> Word32 -> r)
forall b c a. Format b c -> Format a b -> Format a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (Word32 -> r) (Word32 -> r)
" was not the computed one, which was "
          Format (Word32 -> r) (Word32 -> r)
-> Format r (Word32 -> r) -> Format r (Word32 -> r)
forall b c a. Format b c -> Format a b -> Format a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format r (Word32 -> r)
forall a r. Show a => Format r (a -> r)
shown
  Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
actualCrc Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
expectedCrc)
    (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$ Text -> Decoder s ()
forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError (Format Text (Word32 -> Word32 -> Text) -> Word32 -> Word32 -> Text
forall a. Format Text a -> a
sformat Format Text (Word32 -> Word32 -> Text)
forall r. Format r (Word32 -> Word32 -> r)
crcErrorFmt Word32
expectedCrc Word32
actualCrc)
  Either DecoderError a -> Decoder s a
forall (m :: * -> *) e a.
(MonadFail m, Buildable e) =>
Either e a -> m a
toCborError (Either DecoderError a -> Decoder s a)
-> Either DecoderError a -> Decoder s a
forall a b. (a -> b) -> a -> b
$ Version -> ByteString -> Either DecoderError a
forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
decodeFull' Version
byronProtVer ByteString
body