{-# LANGUAGE BangPatterns       #-}
{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TypeApplications   #-}

module PlutusCore.Data (Data (..)) where

import Codec.CBOR.Decoding (Decoder)
import Codec.CBOR.Decoding qualified as CBOR
import Codec.CBOR.Encoding (Encoding)
import Codec.CBOR.Encoding qualified as CBOR
import Codec.CBOR.Magic qualified as CBOR
import Codec.Serialise (Serialise (decode, encode))
import Codec.Serialise.Decoding (decodeSequenceLenIndef, decodeSequenceLenN)
import Control.DeepSeq (NFData)
import Control.Monad.Except
import Data.Bits (shiftR)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BSL
import Data.Data qualified
import Data.Word (Word64, Word8)
import GHC.Generics
import Prelude
import Prettyprinter

-- | A generic "data" type.
--
-- The main constructor 'Constr' represents a datatype value in sum-of-products
-- form: @Constr i args@ represents a use of the @i@th constructor along with its arguments.
--
-- The other constructors are various primitives.
data Data =
      Constr Integer [Data]
    | Map [(Data, Data)]
    | List [Data]
    | I Integer
    | B BS.ByteString
    deriving stock (Int -> Data -> ShowS
[Data] -> ShowS
Data -> String
(Int -> Data -> ShowS)
-> (Data -> String) -> ([Data] -> ShowS) -> Show Data
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Data] -> ShowS
$cshowList :: [Data] -> ShowS
show :: Data -> String
$cshow :: Data -> String
showsPrec :: Int -> Data -> ShowS
$cshowsPrec :: Int -> Data -> ShowS
Show, Data -> Data -> Bool
(Data -> Data -> Bool) -> (Data -> Data -> Bool) -> Eq Data
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Data -> Data -> Bool
$c/= :: Data -> Data -> Bool
== :: Data -> Data -> Bool
$c== :: Data -> Data -> Bool
Eq, Eq Data
Eq Data
-> (Data -> Data -> Ordering)
-> (Data -> Data -> Bool)
-> (Data -> Data -> Bool)
-> (Data -> Data -> Bool)
-> (Data -> Data -> Bool)
-> (Data -> Data -> Data)
-> (Data -> Data -> Data)
-> Ord Data
Data -> Data -> Bool
Data -> Data -> Ordering
Data -> Data -> Data
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 :: Data -> Data -> Data
$cmin :: Data -> Data -> Data
max :: Data -> Data -> Data
$cmax :: Data -> Data -> Data
>= :: Data -> Data -> Bool
$c>= :: Data -> Data -> Bool
> :: Data -> Data -> Bool
$c> :: Data -> Data -> Bool
<= :: Data -> Data -> Bool
$c<= :: Data -> Data -> Bool
< :: Data -> Data -> Bool
$c< :: Data -> Data -> Bool
compare :: Data -> Data -> Ordering
$ccompare :: Data -> Data -> Ordering
$cp1Ord :: Eq Data
Ord, (forall x. Data -> Rep Data x)
-> (forall x. Rep Data x -> Data) -> Generic Data
forall x. Rep Data x -> Data
forall x. Data -> Rep Data x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Data x -> Data
$cfrom :: forall x. Data -> Rep Data x
Generic, Typeable Data
DataType
Constr
Typeable Data
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> Data -> c Data)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c Data)
-> (Data -> Constr)
-> (Data -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c Data))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Data))
-> ((forall b. Data b => b -> b) -> Data -> Data)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Data -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Data -> r)
-> (forall u. (forall d. Data d => d -> u) -> Data -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Data -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Data -> m Data)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Data -> m Data)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Data -> m Data)
-> Data Data
Data -> DataType
Data -> Constr
(forall b. Data b => b -> b) -> Data -> Data
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Data -> c Data
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Data
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Data -> u
forall u. (forall d. Data d => d -> u) -> Data -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Data -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Data -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Data -> m Data
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Data -> m Data
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Data
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Data -> c Data
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Data)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Data)
$cB :: Constr
$cI :: Constr
$cList :: Constr
$cMap :: Constr
$cConstr :: Constr
$tData :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> Data -> m Data
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Data -> m Data
gmapMp :: (forall d. Data d => d -> m d) -> Data -> m Data
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Data -> m Data
gmapM :: (forall d. Data d => d -> m d) -> Data -> m Data
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Data -> m Data
gmapQi :: Int -> (forall d. Data d => d -> u) -> Data -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Data -> u
gmapQ :: (forall d. Data d => d -> u) -> Data -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Data -> [u]
gmapQr :: (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Data -> r
$cgmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Data -> r
gmapQl :: (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Data -> r
$cgmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Data -> r
gmapT :: (forall b. Data b => b -> b) -> Data -> Data
$cgmapT :: (forall b. Data b => b -> b) -> Data -> Data
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Data)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Data)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c Data)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Data)
dataTypeOf :: Data -> DataType
$cdataTypeOf :: Data -> DataType
toConstr :: Data -> Constr
$ctoConstr :: Data -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Data
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Data
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Data -> c Data
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Data -> c Data
$cp1Data :: Typeable Data
Data.Data.Data)
    deriving anyclass (Data -> ()
(Data -> ()) -> NFData Data
forall a. (a -> ()) -> NFData a
rnf :: Data -> ()
$crnf :: Data -> ()
NFData)

instance Pretty Data where
    pretty :: Data -> Doc ann
pretty = \case
        Constr Integer
_ [Data]
ds -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
angles ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
sep (Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
forall ann. Doc ann
comma ((Data -> Doc ann) -> [Data] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Data -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Data]
ds)))
        Map [(Data, Data)]
entries -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
braces ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
sep (Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
forall ann. Doc ann
comma (((Data, Data) -> Doc ann) -> [(Data, Data)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Data
k, Data
v) -> Data -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Data
k Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Data -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Data
v) [(Data, Data)]
entries)))
        List [Data]
ds     -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
brackets ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
sep (Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
forall ann. Doc ann
comma ((Data -> Doc ann) -> [Data] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Data -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Data]
ds)))
        I Integer
i         -> Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
i
        B ByteString
b         -> ByteString -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow ByteString
b

{- Note [Encoding via Term]
We want to write a custom encoder/decoder for Data (i.e. not use the Generic version), but actually
doing this is a pain. So instead we go via the CBOR 'Term' representation, which lets us process a
more structured representation, which is a lot easier.
-}

instance Serialise Data where
    -- See Note [Encoding via Term]
    encode :: Data -> Encoding
encode = Data -> Encoding
encodeData
    decode :: Decoder s Data
decode = Decoder s Data
forall s. Decoder s Data
decodeData

{- Note [CBOR alternative tags]
We've proposed to add additional tags to the CBOR standard to cover (essentially) sum types.
This is exactly what we need to encode the 'Constr' constructor of 'Data' in an unambiguous way.

The tags aren't *quite* accepted yet, but they're clearly going to accept so we might as well
start using them.

The scheme is:
- Alternatives 0-6 -> tags 121-127, followed by the arguments in a list
- Alternatives 7-127 -> tags 1280-1400, followed by the arguments in a list
- Any alternatives, including those that don't fit in the above -> tag 102 followed by a list containing
an unsigned integer for the actual alternative, and then the arguments in a (nested!) list.
-}

{- Note [The 64-byte limit]
We impose a 64-byte *on-the-wire* limit on the leaves of a serialized 'Data'. This prevents people from inserting
Mickey Mouse entire.

The simplest way of doing this is to check during deserialization that we never deserialize something that uses
more than 64-bytes, and this is largely what we do. Then it's the user's problem to not produce something too big.

But this is quite inconvenient, so see Note [Evading the 64-byte limit] for how we get around this.
-}

{- Note [Evading the 64-byte limit]
Implementing Note [The 64-byte limit] naively would be quite annoying:
- Users would be responsible for not creating Data values with leaves that were too big.
- If a script *required* such a thing (e.g. a counter that somehow got above 64 bytes), then the user is totally
stuck: the script demands something they cannot represent.

This is unpleasant and introduces limits. Probably limits that nobody will hit, but it's nicer to just not have them.
And it turns out that we can evade the problem with some clever encoding.

The fundamental argument is that an *indefinite-length* CBOR bytestring is just as obfuscated as a list of bytestrings,
since it consists of a list of chunks *with metadata*. Since we already allow people to make lists of <64 byte bytestrings,
we might as well let them make indefinite-length bytestrings too.

So that solves the problem for bytestrings: if they are >64bytes, we encode them as indefinite-length bytestrings
with 64-byte chunks. We have to write our own encoders/decoders so we can produce chunks of the right size and check
the sizes when we decode, but that's okay.

For integers, we have two cases. Small integers (<64bits) can be encoded normally. Big integers are already
encoded *with a byte string*. The spec allows this to be an indefinite-length bytestring (although cborg doesn't
like it), so we can reuse our trick. Again, we need to write some manual encoders/decoders.
-}

-- | Turn Data into a CBOR Term.
encodeData :: Data -> Encoding
encodeData :: Data -> Encoding
encodeData = \case
    -- See Note [CBOR alternative tags]
    Constr Integer
i [Data]
ds | Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
i Bool -> Bool -> Bool
&& Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
7   -> Word -> Encoding
CBOR.encodeTag (Integer -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
121 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
i)) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [Data] -> Encoding
forall a. Serialise a => a -> Encoding
encode [Data]
ds
    Constr Integer
i [Data]
ds | Integer
7 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
i Bool -> Bool -> Bool
&& Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
128 -> Word -> Encoding
CBOR.encodeTag (Integer -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
1280 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ (Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
7))) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [Data] -> Encoding
forall a. Serialise a => a -> Encoding
encode [Data]
ds
    Constr Integer
i [Data]
ds | Bool
otherwise         ->
                  let tagEncoding :: Encoding
tagEncoding = if Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Bounded Word64 => Word64
forall a. Bounded a => a
minBound @Word64) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
i Bool -> Bool -> Bool
&& Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Bounded Word64 => Word64
forall a. Bounded a => a
maxBound @Word64)
                                    then Word64 -> Encoding
CBOR.encodeWord64 (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
                                    -- This is a "correct"-ish encoding of the tag, but it will *not* deserialise, since we insist on a
                                    -- 'Word64' when we deserialise. So this is really a "soft" failure, without using 'error' or something.
                                    else Integer -> Encoding
CBOR.encodeInteger Integer
i
                  in Word -> Encoding
CBOR.encodeTag Word
102 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
tagEncoding Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [Data] -> Encoding
forall a. Serialise a => a -> Encoding
encode [Data]
ds
    Map [(Data, Data)]
es                          -> Word -> Encoding
CBOR.encodeMapLen (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ [(Data, Data)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Data, Data)]
es) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [ Data -> Encoding
forall a. Serialise a => a -> Encoding
encode Data
t Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Data -> Encoding
forall a. Serialise a => a -> Encoding
encode Data
t' | (Data
t, Data
t') <-[(Data, Data)]
es ]
    List [Data]
ds                         -> [Data] -> Encoding
forall a. Serialise a => a -> Encoding
encode [Data]
ds
    I Integer
i                             -> Integer -> Encoding
encodeInteger Integer
i
    B ByteString
b                             -> ByteString -> Encoding
encodeBs ByteString
b

-- Logic for choosing encoding borrowed from Codec.CBOR.Write
-- | Given an integer, create a 'CBOR.Term' that encodes it, following our size restrictions.
encodeInteger :: Integer -> Encoding
-- If it fits in a Word64, then it's less than 64 bytes for sure, and we can just send it off
-- as a normal integer for cborg to deal with
encodeInteger :: Integer -> Encoding
encodeInteger Integer
i | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 , Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
forall a. Bounded a => a
maxBound :: Word64) = Integer -> Encoding
CBOR.encodeInteger Integer
i
                | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<  Integer
0 , Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= -Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
forall a. Bounded a => a
maxBound :: Word64) = Integer -> Encoding
CBOR.encodeInteger Integer
i
-- Otherwise, it would be encoded as a bignum anyway, so we manually do the bignum
-- encoding with a bytestring inside, and since we use bsToTerm, that bytestring will
-- get chunked up if it's too big.
-- See Note [Evading the 64-byte limit]
encodeInteger Integer
i | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 = Word -> Encoding
CBOR.encodeTag Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ByteString -> Encoding
encodeBs (Integer -> ByteString
integerToBytes Integer
i)
encodeInteger Integer
i | Bool
otherwise = Word -> Encoding
CBOR.encodeTag Word
3 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ByteString -> Encoding
encodeBs (Integer -> ByteString
integerToBytes (-Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
i))

-- Taken exactly from Codec.CBOR.Write
integerToBytes :: Integer -> BS.ByteString
integerToBytes :: Integer -> ByteString
integerToBytes Integer
n0
  | Integer
n0 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0   = [Word8] -> ByteString
BS.pack [Word8
0]
  | Bool
otherwise = [Word8] -> ByteString
BS.pack ([Word8] -> [Word8]
forall a. [a] -> [a]
reverse (Integer -> [Word8]
go Integer
n0))
  where
    go :: Integer -> [Word8]
go Integer
n | Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0    = []
         | Bool
otherwise = Integer -> Word8
narrow Integer
n Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Integer -> [Word8]
go (Integer
n Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
8)

    narrow :: Integer -> Word8
    narrow :: Integer -> Word8
narrow = Integer -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | Given an bytestring, create a 'CBOR.Term' that encodes it, following our size restrictions.
encodeBs :: BS.ByteString -> Encoding
encodeBs :: ByteString -> Encoding
encodeBs ByteString
b | ByteString -> Int
BS.length ByteString
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
64 = ByteString -> Encoding
CBOR.encodeBytes ByteString
b
-- It's a bit tricky to get cborg to emit an indefinite-length bytestring with chunks that we control,
-- so we encode it manually
-- See Note [Evading the 64-byte limit]
encodeBs ByteString
b = Encoding
CBOR.encodeBytesIndef Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> (ByteString -> Encoding) -> [ByteString] -> Encoding
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ByteString -> Encoding
forall a. Serialise a => a -> Encoding
encode (ByteString -> [ByteString]
to64ByteChunks ByteString
b) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
CBOR.encodeBreak

-- | Turns a 'BS.ByteString' into a list of <=64 byte chunks.
to64ByteChunks :: BS.ByteString -> [BS.ByteString]
to64ByteChunks :: ByteString -> [ByteString]
to64ByteChunks ByteString
b | ByteString -> Int
BS.length ByteString
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
64 =
                   let (ByteString
chunk, ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
64 ByteString
b
                   in ByteString
chunkByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:ByteString -> [ByteString]
to64ByteChunks ByteString
rest
to64ByteChunks ByteString
b = [ByteString
b]

{- Note [Definite and indefinite forms of CBOR]
CBOR is annoying and you can have both definite (with a fixed length) and indefinite lists, maps, etc.

So we have to be careful to handle both cases when decoding. When encoding we mostly don't make
the indefinite kinds, but see Note [Avoiding the 64-byte limit] for some cases where we do.
-}

-- | Turn a CBOR Term into Data if possible.
decodeData :: Decoder s Data
decodeData :: Decoder s Data
decodeData = Decoder s TokenType
forall s. Decoder s TokenType
CBOR.peekTokenType Decoder s TokenType
-> (TokenType -> Decoder s Data) -> Decoder s Data
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  -- These integers are at most 64 *bits*, so certainly less than 64 *bytes*
  TokenType
CBOR.TypeUInt         -> Integer -> Data
I (Integer -> Data) -> Decoder s Integer -> Decoder s Data
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Integer
forall s. Decoder s Integer
CBOR.decodeInteger
  TokenType
CBOR.TypeUInt64       -> Integer -> Data
I (Integer -> Data) -> Decoder s Integer -> Decoder s Data
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Integer
forall s. Decoder s Integer
CBOR.decodeInteger
  TokenType
CBOR.TypeNInt         -> Integer -> Data
I (Integer -> Data) -> Decoder s Integer -> Decoder s Data
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Integer
forall s. Decoder s Integer
CBOR.decodeInteger
  TokenType
CBOR.TypeNInt64       -> Integer -> Data
I (Integer -> Data) -> Decoder s Integer -> Decoder s Data
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Integer
forall s. Decoder s Integer
CBOR.decodeInteger
  -- See Note [The 64-byte limit]
  TokenType
CBOR.TypeInteger      -> Integer -> Data
I (Integer -> Data) -> Decoder s Integer -> Decoder s Data
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Integer
forall s. Decoder s Integer
decodeBoundedBigInteger

  -- See Note [The 64-byte limit]
  TokenType
CBOR.TypeBytes        -> ByteString -> Data
B (ByteString -> Data) -> Decoder s ByteString -> Decoder s Data
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s ByteString
forall s. Decoder s ByteString
decodeBoundedBytes
  TokenType
CBOR.TypeBytesIndef   -> ByteString -> Data
B (ByteString -> Data)
-> (ByteString -> ByteString) -> ByteString -> Data
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict (ByteString -> Data) -> Decoder s ByteString -> Decoder s Data
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s ByteString
forall s. Decoder s ByteString
decodeBoundedBytesIndef

  TokenType
CBOR.TypeListLen      -> Decoder s Data
forall s. Decoder s Data
decodeList
  TokenType
CBOR.TypeListLen64    -> Decoder s Data
forall s. Decoder s Data
decodeList
  TokenType
CBOR.TypeListLenIndef -> Decoder s Data
forall s. Decoder s Data
decodeList

  TokenType
CBOR.TypeMapLen       -> Decoder s Data
forall s. Decoder s Data
decodeMap
  TokenType
CBOR.TypeMapLen64     -> Decoder s Data
forall s. Decoder s Data
decodeMap
  TokenType
CBOR.TypeMapLenIndef  -> Decoder s Data
forall s. Decoder s Data
decodeMap

  TokenType
CBOR.TypeTag          -> Decoder s Data
forall s. Decoder s Data
decodeConstr
  TokenType
CBOR.TypeTag64        -> Decoder s Data
forall s. Decoder s Data
decodeConstr

  TokenType
t                     -> String -> Decoder s Data
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Unrecognized value of type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TokenType -> String
forall a. Show a => a -> String
show TokenType
t)

decodeBoundedBigInteger :: Decoder s Integer
decodeBoundedBigInteger :: Decoder s Integer
decodeBoundedBigInteger = do
    Word
tag <- Decoder s Word
forall s. Decoder s Word
CBOR.decodeTag
    -- Bignums contain a bytestring as the payload
    ByteString
bs <- Decoder s TokenType
forall s. Decoder s TokenType
CBOR.peekTokenType Decoder s TokenType
-> (TokenType -> Decoder s ByteString) -> Decoder s ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        TokenType
CBOR.TypeBytes      -> Decoder s ByteString
forall s. Decoder s ByteString
decodeBoundedBytes
        TokenType
CBOR.TypeBytesIndef -> ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString)
-> Decoder s ByteString -> Decoder s ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s ByteString
forall s. Decoder s ByteString
decodeBoundedBytesIndef
        TokenType
t                   -> String -> Decoder s ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Bignum must contain a byte string, got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TokenType -> String
forall a. Show a => a -> String
show TokenType
t)
    -- Depending on the tag, the bytestring is either a positive or negative integer
    case Word
tag of
        Word
2 -> Integer -> Decoder s Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Decoder s Integer) -> Integer -> Decoder s Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Integer
CBOR.uintegerFromBytes ByteString
bs
        Word
3 -> Integer -> Decoder s Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Decoder s Integer) -> Integer -> Decoder s Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Integer
CBOR.nintegerFromBytes ByteString
bs
        Word
t -> String -> Decoder s Integer
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Bignum tag must be one of 2 or 3, got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word -> String
forall a. Show a => a -> String
show Word
t)

-- Adapted from Codec.CBOR.Read
decodeBoundedBytesIndef :: Decoder s BSL.ByteString
decodeBoundedBytesIndef :: Decoder s ByteString
decodeBoundedBytesIndef = Decoder s ()
forall s. Decoder s ()
CBOR.decodeBytesIndef Decoder s () -> Decoder s ByteString -> Decoder s ByteString
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [ByteString] -> Decoder s ByteString
forall s. [ByteString] -> Decoder s ByteString
decodeBoundedBytesIndefLen []

-- Adapted from Codec.CBOR.Read, to call the size-checking bytestring decoder
decodeBoundedBytesIndefLen :: [BS.ByteString] -> Decoder s BSL.ByteString
decodeBoundedBytesIndefLen :: [ByteString] -> Decoder s ByteString
decodeBoundedBytesIndefLen [ByteString]
acc = do
    Bool
stop <- Decoder s Bool
forall s. Decoder s Bool
CBOR.decodeBreakOr
    if Bool
stop then ByteString -> Decoder s ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Decoder s ByteString)
-> ByteString -> Decoder s ByteString
forall a b. (a -> b) -> a -> b
$! [ByteString] -> ByteString
BSL.fromChunks ([ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
acc)
            else do !ByteString
bs <- Decoder s ByteString
forall s. Decoder s ByteString
decodeBoundedBytes
                    [ByteString] -> Decoder s ByteString
forall s. [ByteString] -> Decoder s ByteString
decodeBoundedBytesIndefLen (ByteString
bs ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
acc)

decodeBoundedBytes :: Decoder s BS.ByteString
decodeBoundedBytes :: Decoder s ByteString
decodeBoundedBytes =  do
  ByteString
b <- Decoder s ByteString
forall s. Decoder s ByteString
CBOR.decodeBytes
  -- See Note [The 64-byte limit]
  Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Int
BS.length ByteString
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
64) (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$ String -> Decoder s ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"ByteString exceeds 64 bytes"
  ByteString -> Decoder s ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
b

decodeList :: Decoder s Data
decodeList :: Decoder s Data
decodeList = [Data] -> Data
List ([Data] -> Data) -> Decoder s [Data] -> Decoder s Data
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Data -> Decoder s [Data]
forall s x. Decoder s x -> Decoder s [x]
decodeListOf Decoder s Data
forall s. Decoder s Data
decodeData

decodeListOf :: Decoder s x -> Decoder s [x]
decodeListOf :: Decoder s x -> Decoder s [x]
decodeListOf Decoder s x
decoder = Decoder s (Maybe Int)
forall s. Decoder s (Maybe Int)
CBOR.decodeListLenOrIndef Decoder s (Maybe Int)
-> (Maybe Int -> Decoder s [x]) -> Decoder s [x]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Maybe Int
Nothing -> ([x] -> x -> [x])
-> [x] -> ([x] -> [x]) -> Decoder s x -> Decoder s [x]
forall r a r' s.
(r -> a -> r) -> r -> (r -> r') -> Decoder s a -> Decoder s r'
decodeSequenceLenIndef ((x -> [x] -> [x]) -> [x] -> x -> [x]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) [] [x] -> [x]
forall a. [a] -> [a]
reverse   Decoder s x
decoder
  Just Int
n  -> ([x] -> x -> [x])
-> [x] -> ([x] -> [x]) -> Int -> Decoder s x -> Decoder s [x]
forall r a r' s.
(r -> a -> r)
-> r -> (r -> r') -> Int -> Decoder s a -> Decoder s r'
decodeSequenceLenN     ((x -> [x] -> [x]) -> [x] -> x -> [x]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) [] [x] -> [x]
forall a. [a] -> [a]
reverse Int
n Decoder s x
decoder

decodeMap :: Decoder s Data
decodeMap :: Decoder s Data
decodeMap = Decoder s (Maybe Int)
forall s. Decoder s (Maybe Int)
CBOR.decodeMapLenOrIndef Decoder s (Maybe Int)
-> (Maybe Int -> Decoder s Data) -> Decoder s Data
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Maybe Int
Nothing -> [(Data, Data)] -> Data
Map ([(Data, Data)] -> Data)
-> Decoder s [(Data, Data)] -> Decoder s Data
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(Data, Data)] -> (Data, Data) -> [(Data, Data)])
-> [(Data, Data)]
-> ([(Data, Data)] -> [(Data, Data)])
-> Decoder s (Data, Data)
-> Decoder s [(Data, Data)]
forall r a r' s.
(r -> a -> r) -> r -> (r -> r') -> Decoder s a -> Decoder s r'
decodeSequenceLenIndef (((Data, Data) -> [(Data, Data)] -> [(Data, Data)])
-> [(Data, Data)] -> (Data, Data) -> [(Data, Data)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) [] [(Data, Data)] -> [(Data, Data)]
forall a. [a] -> [a]
reverse   Decoder s (Data, Data)
forall s. Decoder s (Data, Data)
decodePair
  Just Int
n  -> [(Data, Data)] -> Data
Map ([(Data, Data)] -> Data)
-> Decoder s [(Data, Data)] -> Decoder s Data
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(Data, Data)] -> (Data, Data) -> [(Data, Data)])
-> [(Data, Data)]
-> ([(Data, Data)] -> [(Data, Data)])
-> Int
-> Decoder s (Data, Data)
-> Decoder s [(Data, Data)]
forall r a r' s.
(r -> a -> r)
-> r -> (r -> r') -> Int -> Decoder s a -> Decoder s r'
decodeSequenceLenN     (((Data, Data) -> [(Data, Data)] -> [(Data, Data)])
-> [(Data, Data)] -> (Data, Data) -> [(Data, Data)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) [] [(Data, Data)] -> [(Data, Data)]
forall a. [a] -> [a]
reverse Int
n Decoder s (Data, Data)
forall s. Decoder s (Data, Data)
decodePair
  where
  decodePair :: Decoder s (Data, Data)
decodePair = (,) (Data -> Data -> (Data, Data))
-> Decoder s Data -> Decoder s (Data -> (Data, Data))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Data
forall s. Decoder s Data
decodeData Decoder s (Data -> (Data, Data))
-> Decoder s Data -> Decoder s (Data, Data)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s Data
forall s. Decoder s Data
decodeData

-- See note [CBOR alternative tags] for the encoding scheme.
decodeConstr :: Decoder s Data
decodeConstr :: Decoder s Data
decodeConstr = Decoder s Word64
forall s. Decoder s Word64
CBOR.decodeTag64 Decoder s Word64 -> (Word64 -> Decoder s Data) -> Decoder s Data
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Word64
102 -> Decoder s Data
forall s. Decoder s Data
decodeConstrExtended
  Word64
t | Word64
121 Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
t Bool -> Bool -> Bool
&& Word64
t Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
128 ->
         Integer -> [Data] -> Data
Constr (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
t Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
121) ([Data] -> Data) -> Decoder s [Data] -> Decoder s Data
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Data -> Decoder s [Data]
forall s x. Decoder s x -> Decoder s [x]
decodeListOf Decoder s Data
forall s. Decoder s Data
decodeData
  Word64
t | Word64
1280 Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
t Bool -> Bool -> Bool
&& Word64
t Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
1401 ->
         Integer -> [Data] -> Data
Constr ((Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
t Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1280) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
7) ([Data] -> Data) -> Decoder s [Data] -> Decoder s Data
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Data -> Decoder s [Data]
forall s x. Decoder s x -> Decoder s [x]
decodeListOf Decoder s Data
forall s. Decoder s Data
decodeData
  Word64
t -> String -> Decoder s Data
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Unrecognized tag " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show Word64
t)
  where
  decodeConstrExtended :: Decoder s Data
decodeConstrExtended = do
    Maybe Int
len <- Decoder s (Maybe Int)
forall s. Decoder s (Maybe Int)
CBOR.decodeListLenOrIndef
    Word64
i <- Decoder s Word64
forall s. Decoder s Word64
CBOR.decodeWord64
    [Data]
args <- Decoder s Data -> Decoder s [Data]
forall s x. Decoder s x -> Decoder s [x]
decodeListOf Decoder s Data
forall s. Decoder s Data
decodeData
    case Maybe Int
len of
      Maybe Int
Nothing -> do
        Bool
done <- Decoder s Bool
forall s. Decoder s Bool
CBOR.decodeBreakOr
        Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
done (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$ String -> Decoder s ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected exactly two elements"
      Just Int
n -> Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2) (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$ String -> Decoder s ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected exactly two elements"
    Data -> Decoder s Data
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Data -> Decoder s Data) -> Data -> Decoder s Data
forall a b. (a -> b) -> a -> b
$ Integer -> [Data] -> Data
Constr (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i) [Data]
args