{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-missed-specialisations #-}
module Cardano.Chain.Common.Attributes (
UnparsedFields (..),
Attributes (..),
attributesAreKnown,
unknownAttributesLength,
encCBORAttributes,
decCBORAttributes,
mkAttributes,
dropAttributes,
dropEmptyAttributes,
)
where
import Cardano.HeapWords (HeapWords (..), heapWords2)
import Cardano.Ledger.Binary (
DecCBOR (..),
Decoder,
DecoderError (..),
Dropper,
EncCBOR (..),
Encoding,
FromCBOR (..),
ToCBOR (..),
cborError,
decodeMapLen,
dropBytes,
dropMap,
dropWord8,
fromByronCBOR,
toByronCBOR,
)
import Cardano.Prelude hiding (cborError)
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
newtype UnparsedFields
= UnparsedFields (Map Word8 LBS.ByteString)
deriving (UnparsedFields -> UnparsedFields -> Bool
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
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
Ord, Int -> UnparsedFields -> ShowS
[UnparsedFields] -> ShowS
UnparsedFields -> String
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. 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
forall a. (a -> Int) -> HeapWords a
heapWords :: UnparsedFields -> Int
$cheapWords :: UnparsedFields -> Int
HeapWords)
deriving anyclass (UnparsedFields -> ()
forall a. (a -> ()) -> NFData a
rnf :: UnparsedFields -> ()
$crnf :: UnparsedFields -> ()
NFData, Context -> UnparsedFields -> IO (Maybe ThunkInfo)
Proxy UnparsedFields -> String
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)
instance ToJSON UnparsedFields where
toJSON :: UnparsedFields -> Value
toJSON (UnparsedFields Map Word8 ByteString
map') = forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ 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 :: forall h. h -> Attributes h
mkAttributes h
dat = forall h. h -> UnparsedFields -> Attributes h
Attributes h
dat (Map Word8 ByteString -> UnparsedFields
UnparsedFields forall k a. Map k a
M.empty)
data Attributes h = Attributes
{ forall h. Attributes h -> h
attrData :: !h
, forall h. Attributes h -> UnparsedFields
attrRemain :: !UnparsedFields
}
deriving (Attributes h -> Attributes h -> Bool
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, Attributes h -> Attributes h -> Bool
Attributes h -> Attributes h -> Ordering
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
Ord, 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, 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 (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
| forall a. Attributes a -> Bool
attributesAreKnown Attributes h
attr =
String
""
| Bool
otherwise =
String
", remain: <" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, ConvertText String b) => a -> b
show (forall a. Attributes a -> Int
unknownAttributesLength Attributes h
attr) forall a. Semigroup a => a -> a -> a
<> String
" bytes>"
in forall a. Monoid a => [a] -> a
mconcat [String
"Attributes { data_ = ", forall a b. (Show a, ConvertText String b) => a -> b
show (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 forall a. Attributes a -> Bool
attributesAreKnown Attributes h
attr
then forall p. Buildable p => p -> Builder
Buildable.build (forall h. Attributes h -> h
attrData Attributes h
attr)
else
forall a. Format Builder a -> a
bprint
(Format (h -> Int -> Builder) (h -> Int -> Builder)
"Attributes { data: " forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a r. Buildable a => Format r (a -> r)
build 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: <" forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a r. Integral a => Format r (a -> r)
int 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> }")
(forall h. Attributes h -> h
attrData Attributes h
attr)
(forall a. Attributes a -> Int
unknownAttributesLength Attributes h
attr)
instance Buildable (Attributes ()) where
build :: Attributes () -> Builder
build Attributes ()
attr
| forall a. Attributes a -> Bool
attributesAreKnown Attributes ()
attr = Builder
"<no attributes>"
| Bool
otherwise =
forall a. Format Builder a -> a
bprint
(Format (Int -> Builder) (Int -> Builder)
"Attributes { data: (), remain: <" forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a r. Integral a => Format r (a -> r)
int 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> }")
(forall a. Attributes a -> Int
unknownAttributesLength Attributes ()
attr)
instance ToJSON a => ToJSON (Attributes a)
instance ToCBOR (Attributes ()) where
toCBOR :: Attributes () -> Encoding
toCBOR = forall a. EncCBOR a => a -> Encoding
toByronCBOR
instance FromCBOR (Attributes ()) where
fromCBOR :: forall s. Decoder s (Attributes ())
fromCBOR = forall a s. DecCBOR a => Decoder s a
fromByronCBOR
instance EncCBOR (Attributes ()) where
encCBOR :: Attributes () -> Encoding
encCBOR = forall t. [(Word8, t -> ByteString)] -> Attributes t -> Encoding
encCBORAttributes []
instance DecCBOR (Attributes ()) where
decCBOR :: forall s. Decoder s (Attributes ())
decCBOR = forall t s.
t
-> (Word8 -> ByteString -> t -> Decoder s (Maybe t))
-> Decoder s (Attributes t)
decCBORAttributes () forall a b. (a -> b) -> a -> b
$ \Word8
_ ByteString
_ ()
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
instance HeapWords h => HeapWords (Attributes h) where
heapWords :: Attributes h -> Int
heapWords (Attributes h
dat UnparsedFields
unparsed) = forall a1 a. (HeapWords a1, HeapWords a) => a -> a1 -> Int
heapWords2 h
dat UnparsedFields
unparsed
attributesAreKnown :: Attributes a -> Bool
attributesAreKnown :: forall a. Attributes a -> Bool
attributesAreKnown = forall k a. Map k a -> Bool
M.null 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 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall h. Attributes h -> UnparsedFields
attrRemain
unknownAttributesLength :: Attributes a -> Int
unknownAttributesLength :: forall a. Attributes a -> Int
unknownAttributesLength =
forall a b. (Integral a, Num b) => a -> b
fromIntegral forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ByteString -> Int64
LBS.length 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 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall h. Attributes h -> UnparsedFields
attrRemain
encCBORAttributes ::
forall t. [(Word8, t -> LBS.ByteString)] -> Attributes t -> Encoding
encCBORAttributes :: forall t. [(Word8, t -> ByteString)] -> Attributes t -> Encoding
encCBORAttributes [(Word8, t -> ByteString)]
encs Attributes t
attr =
forall a. EncCBOR a => a -> Encoding
encCBOR
forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ 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) = forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (forall a. a -> Maybe ByteString -> Maybe a
insertCheck forall a b. (a -> b) -> a -> b
$ t -> ByteString
f (forall h. Attributes h -> h
attrData Attributes t
attr)) Word8
k
where
insertCheck :: a -> Maybe LByteString -> Maybe a
insertCheck :: forall a. a -> Maybe ByteString -> Maybe a
insertCheck a
v Maybe ByteString
Nothing = forall a. a -> Maybe a
Just a
v
insertCheck a
_ (Just ByteString
v') =
forall a. HasCallStack => Text -> a
panic
forall a b. (a -> b) -> a -> b
$ Text
"encCBORAttributes: impossible: field no. "
forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, ConvertText String b) => a -> b
show Word8
k
forall a. Semigroup a => a -> a -> a
<> Text
" is already encoded as unparsed field: "
forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, ConvertText String b) => a -> b
show ByteString
v'
decCBORAttributes ::
forall t s.
t ->
(Word8 -> LBS.ByteString -> t -> Decoder s (Maybe t)) ->
Decoder s (Attributes t)
decCBORAttributes :: forall t s.
t
-> (Word8 -> ByteString -> t -> Decoder s (Maybe t))
-> Decoder s (Attributes t)
decCBORAttributes t
initval Word8 -> ByteString -> t -> Decoder s (Maybe t)
updater = do
Map Word8 ByteString
raw <- forall a s. DecCBOR a => Decoder s a
decCBOR @(Map Word8 LBS.ByteString)
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 (forall h. h -> UnparsedFields -> Attributes h
Attributes t
initval forall a b. (a -> b) -> a -> b
$ Map Word8 ByteString -> UnparsedFields
UnparsedFields Map Word8 ByteString
raw) forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ forall h. Attributes h -> h
attrData Attributes t
attr
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Maybe t
updaterData of
Maybe t
Nothing -> Attributes t
attr
Just t
newData ->
Attributes
{ attrData :: t
attrData = t
newData
, attrRemain :: UnparsedFields
attrRemain =
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
. forall k a. Ord k => k -> Map k a -> Map k a
M.delete Word8
k
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
forall a b. (a -> b) -> a -> b
$ forall h. Attributes h -> UnparsedFields
attrRemain Attributes t
attr
}
dropAttributes :: Dropper s
dropAttributes :: forall s. Dropper s
dropAttributes = forall s. Dropper s -> Dropper s -> Dropper s
dropMap forall s. Dropper s
dropWord8 forall s. Dropper s
dropBytes
dropEmptyAttributes :: Dropper s
dropEmptyAttributes :: forall s. Dropper s
dropEmptyAttributes = do
Int
len <- forall s. Decoder s Int
decodeMapLen
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
len forall a. Eq a => a -> a -> Bool
== Int
0) 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 -> Int -> Int -> DecoderError
DecoderErrorSizeMismatch Text
"Attributes" Int
0 Int
len