{-# 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.Binary
  ( Decoder,
    Encoding,
    FromCBOR (..),
    Size,
    ToCBOR (..),
    decodeFull',
    decodeNestedCbor,
    decodeNestedCborBytes,
    encodeListLen,
    encodeNestedCbor,
    encodeNestedCborBytes,
    enforceSize,
    nestedCborBytesSizeExpr,
    nestedCborSizeExpr,
    serialize,
  )
import Cardano.Prelude
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 :: ToCBOR a => a -> Encoding
encodeKnownCborDataItem :: a -> Encoding
encodeKnownCborDataItem = a -> Encoding
forall a. ToCBOR 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 :: FromCBOR a => Decoder s a
decodeKnownCborDataItem :: Decoder s a
decodeKnownCborDataItem = Decoder s a
forall a s. FromCBOR 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 :: 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 -> Encoding
encodeCrcProtected :: 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. 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
serialize a
x

encodedCrcProtectedSizeExpr ::
  forall a.
  ToCBOR a =>
  (forall t. ToCBOR t => Proxy t -> Size) ->
  Proxy a ->
  Size
encodedCrcProtectedSizeExpr :: (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 (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
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. FromCBOR a => Decoder s a
decodeCrcProtected :: 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 a s. FromCBOR a => Decoder s a
fromCBOR
  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 :: 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 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 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 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 e s a. Buildable e => e -> Decoder s 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 e a s. Buildable e => Either e a -> Decoder s a
toCborError (Either DecoderError a -> Decoder s a)
-> Either DecoderError a -> Decoder s a
forall a b. (a -> b) -> a -> b
$ ByteString -> Either DecoderError a
forall a. FromCBOR a => ByteString -> Either DecoderError a
decodeFull' ByteString
body