{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-missed-specialisations #-}

-- | Helper data type for block, tx attributes
--
--   Map with integer 1-byte keys, arbitrary-type polymorph values. Needed
--   primarily for partial serialization. Values are either parsed and put to
--   some constructor or left as unparsed.
module Cardano.Chain.Common.Attributes
  ( UnparsedFields (..),
    Attributes (..),
    attributesAreKnown,
    unknownAttributesLength,
    toCBORAttributes,
    fromCBORAttributes,
    mkAttributes,
    dropAttributes,
    dropEmptyAttributes,
  )
where

import Cardano.Binary
  ( Decoder,
    DecoderError (..),
    Dropper,
    Encoding,
    FromCBOR (..),
    ToCBOR (..),
    decodeMapLen,
    dropBytes,
    dropMap,
    dropWord8,
  )
import Cardano.Prelude
import Data.Aeson (ToJSON (..))
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LChar8
import qualified Data.Map.Strict as M
import Formatting (bprint, build, int)
import Formatting.Buildable (Buildable)
import qualified Formatting.Buildable as Buildable
import NoThunks.Class (NoThunks (..))
import qualified Prelude

-- | Representation of unparsed fields in Attributes. Newtype wrapper is used
--   for clear backward compatibility between previous representation (which was
--   just a single ByteString) during transition from Store to CBOR.
newtype UnparsedFields
  = UnparsedFields (Map Word8 LBS.ByteString)
  deriving (UnparsedFields -> UnparsedFields -> Bool
(UnparsedFields -> UnparsedFields -> Bool)
-> (UnparsedFields -> UnparsedFields -> Bool) -> Eq UnparsedFields
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnparsedFields -> UnparsedFields -> Bool
$c/= :: UnparsedFields -> UnparsedFields -> Bool
== :: UnparsedFields -> UnparsedFields -> Bool
$c== :: UnparsedFields -> UnparsedFields -> Bool
Eq, Eq UnparsedFields
Eq UnparsedFields
-> (UnparsedFields -> UnparsedFields -> Ordering)
-> (UnparsedFields -> UnparsedFields -> Bool)
-> (UnparsedFields -> UnparsedFields -> Bool)
-> (UnparsedFields -> UnparsedFields -> Bool)
-> (UnparsedFields -> UnparsedFields -> Bool)
-> (UnparsedFields -> UnparsedFields -> UnparsedFields)
-> (UnparsedFields -> UnparsedFields -> UnparsedFields)
-> Ord UnparsedFields
UnparsedFields -> UnparsedFields -> Bool
UnparsedFields -> UnparsedFields -> Ordering
UnparsedFields -> UnparsedFields -> UnparsedFields
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UnparsedFields -> UnparsedFields -> UnparsedFields
$cmin :: UnparsedFields -> UnparsedFields -> UnparsedFields
max :: UnparsedFields -> UnparsedFields -> UnparsedFields
$cmax :: UnparsedFields -> UnparsedFields -> UnparsedFields
>= :: UnparsedFields -> UnparsedFields -> Bool
$c>= :: UnparsedFields -> UnparsedFields -> Bool
> :: UnparsedFields -> UnparsedFields -> Bool
$c> :: UnparsedFields -> UnparsedFields -> Bool
<= :: UnparsedFields -> UnparsedFields -> Bool
$c<= :: UnparsedFields -> UnparsedFields -> Bool
< :: UnparsedFields -> UnparsedFields -> Bool
$c< :: UnparsedFields -> UnparsedFields -> Bool
compare :: UnparsedFields -> UnparsedFields -> Ordering
$ccompare :: UnparsedFields -> UnparsedFields -> Ordering
$cp1Ord :: Eq UnparsedFields
Ord, Int -> UnparsedFields -> ShowS
[UnparsedFields] -> ShowS
UnparsedFields -> String
(Int -> UnparsedFields -> ShowS)
-> (UnparsedFields -> String)
-> ([UnparsedFields] -> ShowS)
-> Show UnparsedFields
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnparsedFields] -> ShowS
$cshowList :: [UnparsedFields] -> ShowS
show :: UnparsedFields -> String
$cshow :: UnparsedFields -> String
showsPrec :: Int -> UnparsedFields -> ShowS
$cshowsPrec :: Int -> UnparsedFields -> ShowS
Show, (forall x. UnparsedFields -> Rep UnparsedFields x)
-> (forall x. Rep UnparsedFields x -> UnparsedFields)
-> Generic UnparsedFields
forall x. Rep UnparsedFields x -> UnparsedFields
forall x. UnparsedFields -> Rep UnparsedFields x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep UnparsedFields x -> UnparsedFields
$cfrom :: forall x. UnparsedFields -> Rep UnparsedFields x
Generic)
  deriving newtype (UnparsedFields -> Int
(UnparsedFields -> Int) -> HeapWords UnparsedFields
forall a. (a -> Int) -> HeapWords a
heapWords :: UnparsedFields -> Int
$cheapWords :: UnparsedFields -> Int
HeapWords)
  deriving anyclass (UnparsedFields -> ()
(UnparsedFields -> ()) -> NFData UnparsedFields
forall a. (a -> ()) -> NFData a
rnf :: UnparsedFields -> ()
$crnf :: UnparsedFields -> ()
NFData, Context -> UnparsedFields -> IO (Maybe ThunkInfo)
Proxy UnparsedFields -> String
(Context -> UnparsedFields -> IO (Maybe ThunkInfo))
-> (Context -> UnparsedFields -> IO (Maybe ThunkInfo))
-> (Proxy UnparsedFields -> String)
-> NoThunks UnparsedFields
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy UnparsedFields -> String
$cshowTypeOf :: Proxy UnparsedFields -> String
wNoThunks :: Context -> UnparsedFields -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> UnparsedFields -> IO (Maybe ThunkInfo)
noThunks :: Context -> UnparsedFields -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> UnparsedFields -> IO (Maybe ThunkInfo)
NoThunks)

-- Used for debugging purposes only
instance ToJSON UnparsedFields where
  toJSON :: UnparsedFields -> Value
toJSON (UnparsedFields Map Word8 ByteString
map') = Map Word8 String -> Value
forall a. ToJSON a => a -> Value
toJSON (Map Word8 String -> Value) -> Map Word8 String -> Value
forall a b. (a -> b) -> a -> b
$ (ByteString -> String) -> Map Word8 ByteString -> Map Word8 String
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ByteString -> String
LChar8.unpack Map Word8 ByteString
map'

fromUnparsedFields :: UnparsedFields -> Map Word8 LBS.ByteString
fromUnparsedFields :: UnparsedFields -> Map Word8 ByteString
fromUnparsedFields (UnparsedFields Map Word8 ByteString
m) = Map Word8 ByteString
m

----------------------------------------

mkAttributes :: h -> Attributes h
mkAttributes :: h -> Attributes h
mkAttributes h
dat = h -> UnparsedFields -> Attributes h
forall h. h -> UnparsedFields -> Attributes h
Attributes h
dat (Map Word8 ByteString -> UnparsedFields
UnparsedFields Map Word8 ByteString
forall k a. Map k a
M.empty)

-- | Convenient wrapper for the datatype to represent it (in binary format) as
--   k-v map
data Attributes h = Attributes
  { -- | Data, containing known keys (deserialized)
    Attributes h -> h
attrData :: !h,
    -- | Remaining, unparsed fields
    Attributes h -> UnparsedFields
attrRemain :: !UnparsedFields
  }
  deriving (Attributes h -> Attributes h -> Bool
(Attributes h -> Attributes h -> Bool)
-> (Attributes h -> Attributes h -> Bool) -> Eq (Attributes h)
forall h. Eq h => Attributes h -> Attributes h -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Attributes h -> Attributes h -> Bool
$c/= :: forall h. Eq h => Attributes h -> Attributes h -> Bool
== :: Attributes h -> Attributes h -> Bool
$c== :: forall h. Eq h => Attributes h -> Attributes h -> Bool
Eq, Eq (Attributes h)
Eq (Attributes h)
-> (Attributes h -> Attributes h -> Ordering)
-> (Attributes h -> Attributes h -> Bool)
-> (Attributes h -> Attributes h -> Bool)
-> (Attributes h -> Attributes h -> Bool)
-> (Attributes h -> Attributes h -> Bool)
-> (Attributes h -> Attributes h -> Attributes h)
-> (Attributes h -> Attributes h -> Attributes h)
-> Ord (Attributes h)
Attributes h -> Attributes h -> Bool
Attributes h -> Attributes h -> Ordering
Attributes h -> Attributes h -> Attributes h
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall h. Ord h => Eq (Attributes h)
forall h. Ord h => Attributes h -> Attributes h -> Bool
forall h. Ord h => Attributes h -> Attributes h -> Ordering
forall h. Ord h => Attributes h -> Attributes h -> Attributes h
min :: Attributes h -> Attributes h -> Attributes h
$cmin :: forall h. Ord h => Attributes h -> Attributes h -> Attributes h
max :: Attributes h -> Attributes h -> Attributes h
$cmax :: forall h. Ord h => Attributes h -> Attributes h -> Attributes h
>= :: Attributes h -> Attributes h -> Bool
$c>= :: forall h. Ord h => Attributes h -> Attributes h -> Bool
> :: Attributes h -> Attributes h -> Bool
$c> :: forall h. Ord h => Attributes h -> Attributes h -> Bool
<= :: Attributes h -> Attributes h -> Bool
$c<= :: forall h. Ord h => Attributes h -> Attributes h -> Bool
< :: Attributes h -> Attributes h -> Bool
$c< :: forall h. Ord h => Attributes h -> Attributes h -> Bool
compare :: Attributes h -> Attributes h -> Ordering
$ccompare :: forall h. Ord h => Attributes h -> Attributes h -> Ordering
$cp1Ord :: forall h. Ord h => Eq (Attributes h)
Ord, (forall x. Attributes h -> Rep (Attributes h) x)
-> (forall x. Rep (Attributes h) x -> Attributes h)
-> Generic (Attributes h)
forall x. Rep (Attributes h) x -> Attributes h
forall x. Attributes h -> Rep (Attributes h) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall h x. Rep (Attributes h) x -> Attributes h
forall h x. Attributes h -> Rep (Attributes h) x
$cto :: forall h x. Rep (Attributes h) x -> Attributes h
$cfrom :: forall h x. Attributes h -> Rep (Attributes h) x
Generic, Context -> Attributes h -> IO (Maybe ThunkInfo)
Proxy (Attributes h) -> String
(Context -> Attributes h -> IO (Maybe ThunkInfo))
-> (Context -> Attributes h -> IO (Maybe ThunkInfo))
-> (Proxy (Attributes h) -> String)
-> NoThunks (Attributes h)
forall h.
NoThunks h =>
Context -> Attributes h -> IO (Maybe ThunkInfo)
forall h. NoThunks h => Proxy (Attributes h) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (Attributes h) -> String
$cshowTypeOf :: forall h. NoThunks h => Proxy (Attributes h) -> String
wNoThunks :: Context -> Attributes h -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall h.
NoThunks h =>
Context -> Attributes h -> IO (Maybe ThunkInfo)
noThunks :: Context -> Attributes h -> IO (Maybe ThunkInfo)
$cnoThunks :: forall h.
NoThunks h =>
Context -> Attributes h -> IO (Maybe ThunkInfo)
NoThunks)
  deriving anyclass (Attributes h -> ()
(Attributes h -> ()) -> NFData (Attributes h)
forall h. NFData h => Attributes h -> ()
forall a. (a -> ()) -> NFData a
rnf :: Attributes h -> ()
$crnf :: forall h. NFData h => Attributes h -> ()
NFData)

instance Show h => Show (Attributes h) where
  show :: Attributes h -> String
show Attributes h
attr =
    let remain :: Prelude.String
        remain :: String
remain
          | Attributes h -> Bool
forall a. Attributes a -> Bool
attributesAreKnown Attributes h
attr =
              String
""
          | Bool
otherwise =
              String
", remain: <" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a b. (Show a, ConvertText String b) => a -> b
show (Attributes h -> Int
forall a. Attributes a -> Int
unknownAttributesLength Attributes h
attr) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" bytes>"
     in Context -> String
forall a. Monoid a => [a] -> a
mconcat [String
"Attributes { data_ = ", h -> String
forall a b. (Show a, ConvertText String b) => a -> b
show (Attributes h -> h
forall h. Attributes h -> h
attrData Attributes h
attr), String
remain, String
" }"]

instance {-# OVERLAPPABLE #-} Buildable h => Buildable (Attributes h) where
  build :: Attributes h -> Builder
build Attributes h
attr =
    if Attributes h -> Bool
forall a. Attributes a -> Bool
attributesAreKnown Attributes h
attr
      then h -> Builder
forall p. Buildable p => p -> Builder
Buildable.build (Attributes h -> h
forall h. Attributes h -> h
attrData Attributes h
attr)
      else
        Format Builder (h -> Int -> Builder) -> h -> Int -> Builder
forall a. Format Builder a -> a
bprint
          (Format (h -> Int -> Builder) (h -> Int -> Builder)
"Attributes { data: " Format (h -> Int -> Builder) (h -> Int -> Builder)
-> Format Builder (h -> Int -> Builder)
-> Format Builder (h -> Int -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (Int -> Builder) (h -> Int -> Builder)
forall a r. Buildable a => Format r (a -> r)
build Format (Int -> Builder) (h -> Int -> Builder)
-> Format Builder (Int -> Builder)
-> Format Builder (h -> Int -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (Int -> Builder) (Int -> Builder)
", remain: <" Format (Int -> Builder) (Int -> Builder)
-> Format Builder (Int -> Builder)
-> Format Builder (Int -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder (Int -> Builder)
forall a r. Integral a => Format r (a -> r)
int Format Builder (Int -> Builder)
-> Format Builder Builder -> Format Builder (Int -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder Builder
" bytes> }")
          (Attributes h -> h
forall h. Attributes h -> h
attrData Attributes h
attr)
          (Attributes h -> Int
forall a. Attributes a -> Int
unknownAttributesLength Attributes h
attr)

instance Buildable (Attributes ()) where
  build :: Attributes () -> Builder
build Attributes ()
attr
    | Attributes () -> Bool
forall a. Attributes a -> Bool
attributesAreKnown Attributes ()
attr = Builder
"<no attributes>"
    | Bool
otherwise =
        Format Builder (Int -> Builder) -> Int -> Builder
forall a. Format Builder a -> a
bprint
          (Format (Int -> Builder) (Int -> Builder)
"Attributes { data: (), remain: <" Format (Int -> Builder) (Int -> Builder)
-> Format Builder (Int -> Builder)
-> Format Builder (Int -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder (Int -> Builder)
forall a r. Integral a => Format r (a -> r)
int Format Builder (Int -> Builder)
-> Format Builder Builder -> Format Builder (Int -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder Builder
" bytes> }")
          (Attributes () -> Int
forall a. Attributes a -> Int
unknownAttributesLength Attributes ()
attr)

-- Used for debugging purposes only
instance ToJSON a => ToJSON (Attributes a)

instance ToCBOR (Attributes ()) where
  toCBOR :: Attributes () -> Encoding
toCBOR = [(Word8, () -> ByteString)] -> Attributes () -> Encoding
forall t. [(Word8, t -> ByteString)] -> Attributes t -> Encoding
toCBORAttributes []

instance FromCBOR (Attributes ()) where
  fromCBOR :: Decoder s (Attributes ())
fromCBOR = ()
-> (Word8 -> ByteString -> () -> Decoder s (Maybe ()))
-> Decoder s (Attributes ())
forall t s.
t
-> (Word8 -> ByteString -> t -> Decoder s (Maybe t))
-> Decoder s (Attributes t)
fromCBORAttributes () ((Word8 -> ByteString -> () -> Decoder s (Maybe ()))
 -> Decoder s (Attributes ()))
-> (Word8 -> ByteString -> () -> Decoder s (Maybe ()))
-> Decoder s (Attributes ())
forall a b. (a -> b) -> a -> b
$ \Word8
_ ByteString
_ ()
_ -> Maybe () -> Decoder s (Maybe ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ()
forall a. Maybe a
Nothing

instance HeapWords h => HeapWords (Attributes h) where
  heapWords :: Attributes h -> Int
heapWords (Attributes h
dat UnparsedFields
unparsed) = h -> UnparsedFields -> Int
forall a1 a. (HeapWords a1, HeapWords a) => a -> a1 -> Int
heapWords2 h
dat UnparsedFields
unparsed

-- | Check whether all data from 'Attributes' is known, i. e. was successfully
--   parsed into some structured data
attributesAreKnown :: Attributes a -> Bool
attributesAreKnown :: Attributes a -> Bool
attributesAreKnown = Map Word8 ByteString -> Bool
forall k a. Map k a -> Bool
M.null (Map Word8 ByteString -> Bool)
-> (Attributes a -> Map Word8 ByteString) -> Attributes a -> Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UnparsedFields -> Map Word8 ByteString
fromUnparsedFields (UnparsedFields -> Map Word8 ByteString)
-> (Attributes a -> UnparsedFields)
-> Attributes a
-> Map Word8 ByteString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Attributes a -> UnparsedFields
forall h. Attributes h -> UnparsedFields
attrRemain

unknownAttributesLength :: Attributes a -> Int
unknownAttributesLength :: Attributes a -> Int
unknownAttributesLength =
  Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> (Attributes a -> Int64) -> Attributes a -> Int
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Map Word8 Int64 -> Int64
forall (f :: * -> *) a. (Foldable f, Num a) => f a -> a
sum (Map Word8 Int64 -> Int64)
-> (Attributes a -> Map Word8 Int64) -> Attributes a -> Int64
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (ByteString -> Int64) -> Map Word8 ByteString -> Map Word8 Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ByteString -> Int64
LBS.length (Map Word8 ByteString -> Map Word8 Int64)
-> (Attributes a -> Map Word8 ByteString)
-> Attributes a
-> Map Word8 Int64
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UnparsedFields -> Map Word8 ByteString
fromUnparsedFields (UnparsedFields -> Map Word8 ByteString)
-> (Attributes a -> UnparsedFields)
-> Attributes a
-> Map Word8 ByteString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Attributes a -> UnparsedFields
forall h. Attributes h -> UnparsedFields
attrRemain

{- NOTE: Attributes serialization
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Attributes are a way to add fields to datatypes while maintaining backwards
compatibility. Suppose that you have this datatype:

    data Foo = Foo {
        x :: Int,
        y :: Int,
        attrs :: Attributes FooAttrs }

@Attributes FooAttrs@ is a key-value map that deserializes into @FooAttrs@.
Each key is a single byte, and each value is an arbitary bytestring. It's
serialized like this:

    <length of following data>
    <k1><first attribute>
    <k2><second attribute>
    <attrRemain>

The attributes are read as long as their keys are “known” (i.e. as long as we
know how to interpret those keys), and the rest is stored separately. For
instance, let's say that in first version of CSL, @FooAttrs@ looks like this:

    data FooAttrs = FooAttrs {
        foo :: Text,
        bar :: [Int] }

It would be serialized as follows:

    <length> <0x00><foo> <0x01><bar>

In the next version of CSL we add a new field @quux@. The new version would
serialize it like this:

    <length> <0x00><foo> <0x01><bar> <0x02><quux>

And the old version would treat it like this:

    <length> <0x00><foo> <0x01><bar> <attrRemain>

This way the old version can serialize and deserialize data received from the
new version in a lossless way (i.e. when the old version does serialization
it would just put @attrRemain@ back after other attributes and the new
version would be able to parse it).

-}

toCBORAttributes ::
  forall t. [(Word8, t -> LBS.ByteString)] -> Attributes t -> Encoding
toCBORAttributes :: [(Word8, t -> ByteString)] -> Attributes t -> Encoding
toCBORAttributes [(Word8, t -> ByteString)]
encs Attributes t
attr =
  Map Word8 ByteString -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Map Word8 ByteString -> Encoding)
-> Map Word8 ByteString -> Encoding
forall a b. (a -> b) -> a -> b
$
    ((Word8, t -> ByteString)
 -> Map Word8 ByteString -> Map Word8 ByteString)
-> Map Word8 ByteString
-> [(Word8, t -> ByteString)]
-> Map Word8 ByteString
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Word8, t -> ByteString)
-> Map Word8 ByteString -> Map Word8 ByteString
go (UnparsedFields -> Map Word8 ByteString
fromUnparsedFields (UnparsedFields -> Map Word8 ByteString)
-> UnparsedFields -> Map Word8 ByteString
forall a b. (a -> b) -> a -> b
$ Attributes t -> UnparsedFields
forall h. Attributes h -> UnparsedFields
attrRemain Attributes t
attr) [(Word8, t -> ByteString)]
encs
  where
    go ::
      (Word8, t -> LBS.ByteString) ->
      Map Word8 LBS.ByteString ->
      Map Word8 LBS.ByteString
    go :: (Word8, t -> ByteString)
-> Map Word8 ByteString -> Map Word8 ByteString
go (Word8
k, t -> ByteString
f) = (Maybe ByteString -> Maybe ByteString)
-> Word8 -> Map Word8 ByteString -> Map Word8 ByteString
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (ByteString -> Maybe ByteString -> Maybe ByteString
forall a. a -> Maybe ByteString -> Maybe a
insertCheck (ByteString -> Maybe ByteString -> Maybe ByteString)
-> ByteString -> Maybe ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ t -> ByteString
f (Attributes t -> t
forall h. Attributes h -> h
attrData Attributes t
attr)) Word8
k
      where
        insertCheck :: a -> Maybe LByteString -> Maybe a
        insertCheck :: a -> Maybe ByteString -> Maybe a
insertCheck a
v Maybe ByteString
Nothing = a -> Maybe a
forall a. a -> Maybe a
Just a
v
        insertCheck a
_ (Just ByteString
v') =
          Text -> Maybe a
forall a. HasCallStack => Text -> a
panic (Text -> Maybe a) -> Text -> Maybe a
forall a b. (a -> b) -> a -> b
$
            Text
"toCBORAttributes: impossible: field no. "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word8 -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show Word8
k
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is already encoded as unparsed field: "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show ByteString
v'

fromCBORAttributes ::
  forall t s.
  t ->
  (Word8 -> LBS.ByteString -> t -> Decoder s (Maybe t)) ->
  Decoder s (Attributes t)
fromCBORAttributes :: t
-> (Word8 -> ByteString -> t -> Decoder s (Maybe t))
-> Decoder s (Attributes t)
fromCBORAttributes t
initval Word8 -> ByteString -> t -> Decoder s (Maybe t)
updater = do
  Map Word8 ByteString
raw <- forall s.
FromCBOR (Map Word8 ByteString) =>
Decoder s (Map Word8 ByteString)
forall a s. FromCBOR a => Decoder s a
fromCBOR @(Map Word8 LBS.ByteString)
  ((Word8, ByteString) -> Attributes t -> Decoder s (Attributes t))
-> Attributes t
-> [(Word8, ByteString)]
-> Decoder s (Attributes t)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (Word8, ByteString) -> Attributes t -> Decoder s (Attributes t)
go (t -> UnparsedFields -> Attributes t
forall h. h -> UnparsedFields -> Attributes h
Attributes t
initval (UnparsedFields -> Attributes t) -> UnparsedFields -> Attributes t
forall a b. (a -> b) -> a -> b
$ Map Word8 ByteString -> UnparsedFields
UnparsedFields Map Word8 ByteString
raw) ([(Word8, ByteString)] -> Decoder s (Attributes t))
-> [(Word8, ByteString)] -> Decoder s (Attributes t)
forall a b. (a -> b) -> a -> b
$ Map Word8 ByteString -> [(Word8, ByteString)]
forall k a. Map k a -> [(k, a)]
M.toList Map Word8 ByteString
raw
  where
    go :: (Word8, LBS.ByteString) -> Attributes t -> Decoder s (Attributes t)
    go :: (Word8, ByteString) -> Attributes t -> Decoder s (Attributes t)
go (Word8
k, ByteString
v) Attributes t
attr = do
      Maybe t
updaterData <- Word8 -> ByteString -> t -> Decoder s (Maybe t)
updater Word8
k ByteString
v (t -> Decoder s (Maybe t)) -> t -> Decoder s (Maybe t)
forall a b. (a -> b) -> a -> b
$ Attributes t -> t
forall h. Attributes h -> h
attrData Attributes t
attr
      Attributes t -> Decoder s (Attributes t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attributes t -> Decoder s (Attributes t))
-> Attributes t -> Decoder s (Attributes t)
forall a b. (a -> b) -> a -> b
$ case Maybe t
updaterData of
        Maybe t
Nothing -> Attributes t
attr
        Just t
newData ->
          Attributes :: forall h. h -> UnparsedFields -> Attributes h
Attributes
            { attrData :: t
attrData = t
newData,
              attrRemain :: UnparsedFields
attrRemain =
                Map Word8 ByteString -> UnparsedFields
UnparsedFields
                  (Map Word8 ByteString -> UnparsedFields)
-> (UnparsedFields -> Map Word8 ByteString)
-> UnparsedFields
-> UnparsedFields
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Word8 -> Map Word8 ByteString -> Map Word8 ByteString
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Word8
k
                  (Map Word8 ByteString -> Map Word8 ByteString)
-> (UnparsedFields -> Map Word8 ByteString)
-> UnparsedFields
-> Map Word8 ByteString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UnparsedFields -> Map Word8 ByteString
fromUnparsedFields
                  (UnparsedFields -> UnparsedFields)
-> UnparsedFields -> UnparsedFields
forall a b. (a -> b) -> a -> b
$ Attributes t -> UnparsedFields
forall h. Attributes h -> UnparsedFields
attrRemain Attributes t
attr
            }

dropAttributes :: Dropper s
dropAttributes :: Dropper s
dropAttributes = Dropper s -> Dropper s -> Dropper s
forall s. Dropper s -> Dropper s -> Dropper s
dropMap Dropper s
forall s. Dropper s
dropWord8 Dropper s
forall s. Dropper s
dropBytes

-- | Drop `Attributes ()` making sure that the `UnparsedFields` are empty
dropEmptyAttributes :: Dropper s
dropEmptyAttributes :: Dropper s
dropEmptyAttributes = do
  Int
len <- Decoder s Int
forall s. Decoder s Int
decodeMapLen
  Bool -> Dropper s -> Dropper s
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (Dropper s -> Dropper s) -> Dropper s -> Dropper s
forall a b. (a -> b) -> a -> b
$ DecoderError -> Dropper s
forall e s a. Buildable e => e -> Decoder s a
cborError (DecoderError -> Dropper s) -> DecoderError -> Dropper s
forall a b. (a -> b) -> a -> b
$ Text -> Int -> Int -> DecoderError
DecoderErrorSizeMismatch Text
"Attributes" Int
0 Int
len