{-# 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 qualified Cardano.Binary as Plain (
  Encoding,
  encodeListLen,
  encodeNestedCborBytes,
  nestedCborBytesSizeExpr,
  nestedCborSizeExpr,
  serialize,
 )
import Cardano.Ledger.Binary (
  DecCBOR (..),
  Decoder,
  EncCBOR (..),
  Encoding,
  Size,
  ToCBOR (..),
  byronProtVer,
  cborError,
  decodeFull',
  decodeNestedCbor,
  decodeNestedCborBytes,
  encodeNestedCbor,
  enforceSize,
  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 'Plain.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 -> Plain.Encoding
encodeUnknownCborDataItem :: LByteString -> Encoding
encodeUnknownCborDataItem = LByteString -> Encoding
Plain.encodeNestedCborBytes

knownCborDataItemSizeExpr :: Size -> Size
knownCborDataItemSizeExpr :: Size -> Size
knownCborDataItemSizeExpr = Size -> Size
Plain.nestedCborSizeExpr

unknownCborDataItemSizeExpr :: Size -> Size
unknownCborDataItemSizeExpr :: Size -> Size
unknownCborDataItemSizeExpr = Size -> Size
Plain.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 :: ToCBOR a => a -> Plain.Encoding
encodeCrcProtected :: forall a. ToCBOR a => a -> Encoding
encodeCrcProtected a
x =
  Word -> Encoding
Plain.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. ToCBOR a => a -> Encoding
toCBOR (LByteString -> Word32
forall a. CRC32 a => a -> Word32
crc32 LByteString
body)
  where
    body :: LByteString
body = a -> LByteString
forall a. ToCBOR a => a -> LByteString
Plain.serialize a
x

encodedCrcProtectedSizeExpr ::
  forall a.
  ToCBOR a =>
  (forall t. ToCBOR t => Proxy t -> Size) ->
  Proxy a ->
  Size
encodedCrcProtectedSizeExpr :: forall a.
ToCBOR a =>
(forall t. ToCBOR t => Proxy t -> Size) -> Proxy a -> Size
encodedCrcProtectedSizeExpr forall t. ToCBOR 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. ToCBOR t => Proxy t -> Size
size Proxy a
pxy)
    Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Proxy Word32 -> Size
forall t. ToCBOR 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 (a -> LByteString
forall a. ToCBOR a => a -> LByteString
Plain.serialize (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
  body <- Decoder s ByteString
forall s. Decoder s ByteString
decodeUnknownCborDataItem
  expectedCrc <- decCBOR
  let actualCrc :: Word32
      actualCrc = ByteString -> Word32
forall a. CRC32 a => a -> Word32
crc32 ByteString
body
  let crcErrorFmt :: 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
  when (actualCrc /= expectedCrc)
    $ cborError (sformat crcErrorFmt expectedCrc actualCrc)
  toCborError $ decodeFull' byronProtVer body