{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumDecimals #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

module Cardano.Binary.FromCBOR (
  FromCBOR (..),
  DecoderError (..),
  enforceSize,
  matchSize,
  module D,
  decodeMaybe,
  fromCBORMaybe,
  decodeNullMaybe,
  decodeSeq,
  decodeListWith,
  decodeNominalDiffTime,
  decodeNominalDiffTimeMicro,

  -- * Helper tools to build instances
  decodeMapSkel,
  decodeCollection,
  decodeCollectionWithLen,
  cborError,
  toCborError,
)
where

import Prelude hiding ((.))

import Codec.CBOR.ByteArray as BA (ByteArray (BA))
import Codec.CBOR.Decoding as D
import Codec.CBOR.FlatTerm
import qualified Codec.CBOR.Read as CBOR.Read
import Codec.CBOR.Term
import Control.Category (Category ((.)))
import Control.Exception (Exception)
import Control.Monad (replicateM, when)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Short as SBS
import Data.ByteString.Short.Internal (ShortByteString (SBS))
import Data.Fixed (Fixed (..))
import Data.Int (Int32, Int64)
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import qualified Data.Map as M
import qualified Data.Primitive.ByteArray as Prim
import Data.Ratio ((%))
import qualified Data.Sequence as Seq
import qualified Data.Set as S
import Data.Tagged (Tagged (..))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar.OrdinalDate (fromOrdinalDate)
import Data.Time.Clock (
  NominalDiffTime,
  UTCTime (..),
  picosecondsToDiffTime,
  secondsToNominalDiffTime,
 )
import Data.Typeable (Proxy, Typeable, typeRep)
import qualified Data.Vector as Vector
import qualified Data.Vector.Generic as Vector.Generic
import Data.Void (Void)
import Data.Word (Word16, Word32, Word64, Word8)
import Formatting (
  bprint,
  build,
  formatToString,
  int,
  shown,
  stext,
 )
import qualified Formatting.Buildable as B (Buildable (..))
import Numeric.Natural (Natural)

{- HLINT ignore "Reduce duplication" -}
{- HLINT ignore "Redundant <$>" -}

class Typeable a => FromCBOR a where
  fromCBOR :: D.Decoder s a

  label :: Proxy a -> Text
  label = String -> Text
T.pack forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Show a => a -> String
show forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep

instance FromCBOR Term where
  fromCBOR :: forall s. Decoder s Term
fromCBOR = forall s. Decoder s Term
decodeTerm

instance FromCBOR TermToken where
  fromCBOR :: forall s. Decoder s TermToken
fromCBOR = forall s. Decoder s TermToken
decodeTermToken

--------------------------------------------------------------------------------
-- DecoderError
--------------------------------------------------------------------------------

data DecoderError
  = DecoderErrorCanonicityViolation Text
  | -- | Custom decoding error, usually due to some validation failure
    DecoderErrorCustom Text Text
  | DecoderErrorDeserialiseFailure Text CBOR.Read.DeserialiseFailure
  | DecoderErrorEmptyList Text
  | DecoderErrorLeftover Text BS.ByteString
  | -- | A size mismatch @DecoderErrorSizeMismatch label expectedSize actualSize@
    DecoderErrorSizeMismatch Text Int Int
  | DecoderErrorUnknownTag Text Word8
  | DecoderErrorVoid
  deriving (DecoderError -> DecoderError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DecoderError -> DecoderError -> Bool
$c/= :: DecoderError -> DecoderError -> Bool
== :: DecoderError -> DecoderError -> Bool
$c== :: DecoderError -> DecoderError -> Bool
Eq, Int -> DecoderError -> ShowS
[DecoderError] -> ShowS
DecoderError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DecoderError] -> ShowS
$cshowList :: [DecoderError] -> ShowS
show :: DecoderError -> String
$cshow :: DecoderError -> String
showsPrec :: Int -> DecoderError -> ShowS
$cshowsPrec :: Int -> DecoderError -> ShowS
Show)

instance Exception DecoderError

instance B.Buildable DecoderError where
  build :: DecoderError -> Builder
build = \case
    DecoderErrorCanonicityViolation Text
lbl ->
      forall a. Format Builder a -> a
bprint (Format (Text -> Builder) (Text -> Builder)
"Canonicity violation while decoding " forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall r. Format r (Text -> r)
stext) Text
lbl
    DecoderErrorCustom Text
lbl Text
err ->
      forall a. Format Builder a -> a
bprint
        ( Format (Text -> Text -> Builder) (Text -> Text -> Builder)
"An error occured while decoding "
            forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall r. Format r (Text -> r)
stext
            forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (Text -> Builder) (Text -> Builder)
".\n"
            forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (Text -> Builder) (Text -> Builder)
"Error: "
            forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall r. Format r (Text -> r)
stext
        )
        Text
lbl
        Text
err
    DecoderErrorDeserialiseFailure Text
lbl DeserialiseFailure
failure ->
      forall a. Format Builder a -> a
bprint
        ( Format
  (Text -> DeserialiseFailure -> Builder)
  (Text -> DeserialiseFailure -> Builder)
"Deserialisation failure while decoding "
            forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall r. Format r (Text -> r)
stext
            forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format
  (DeserialiseFailure -> Builder) (DeserialiseFailure -> Builder)
".\n"
            forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format
  (DeserialiseFailure -> Builder) (DeserialiseFailure -> Builder)
"CBOR failed with error: "
            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. Show a => Format r (a -> r)
shown
        )
        Text
lbl
        DeserialiseFailure
failure
    DecoderErrorEmptyList Text
lbl ->
      forall a. Format Builder a -> a
bprint (Format (Text -> Builder) (Text -> Builder)
"Found unexpected empty list while decoding " forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall r. Format r (Text -> r)
stext) Text
lbl
    DecoderErrorLeftover Text
lbl ByteString
leftover ->
      forall a. Format Builder a -> a
bprint
        ( Format
  (Text -> ByteString -> Builder) (Text -> ByteString -> Builder)
"Found unexpected leftover bytes while decoding "
            forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall r. Format r (Text -> r)
stext
            forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (ByteString -> Builder) (ByteString -> Builder)
"./n"
            forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (ByteString -> Builder) (ByteString -> Builder)
"Leftover: "
            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. Show a => Format r (a -> r)
shown
        )
        Text
lbl
        ByteString
leftover
    DecoderErrorSizeMismatch Text
lbl Int
requested Int
actual ->
      forall a. Format Builder a -> a
bprint
        ( Format
  (Text -> Int -> Int -> Builder) (Text -> Int -> Int -> Builder)
"Size mismatch when decoding "
            forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall r. Format r (Text -> r)
stext
            forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (Int -> Int -> Builder) (Int -> Int -> Builder)
".\n"
            forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (Int -> Int -> Builder) (Int -> Int -> Builder)
"Expected "
            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 (Int -> Builder) (Int -> Builder)
", but found "
            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
"."
        )
        Text
lbl
        Int
requested
        Int
actual
    DecoderErrorUnknownTag Text
lbl Word8
t ->
      forall a. Format Builder a -> a
bprint (Format (Word8 -> Text -> Builder) (Word8 -> Text -> Builder)
"Found unknown tag " 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 (Text -> Builder) (Text -> Builder)
" while decoding " forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall r. Format r (Text -> r)
stext) Word8
t Text
lbl
    DecoderError
DecoderErrorVoid -> forall a. Format Builder a -> a
bprint Format Builder Builder
"Attempted to decode Void"

--------------------------------------------------------------------------------
-- Useful primitives
--------------------------------------------------------------------------------

-- | Enforces that the input size is the same as the decoded one, failing in
--   case it's not
enforceSize :: Text -> Int -> D.Decoder s ()
enforceSize :: forall s. Text -> Int -> Decoder s ()
enforceSize Text
lbl Int
requestedSize = forall s. Decoder s Int
D.decodeListLen forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall s. Text -> Int -> Int -> Decoder s ()
matchSize Text
lbl Int
requestedSize

-- | Compare two sizes, failing if they are not equal
matchSize :: Text -> Int -> Int -> D.Decoder s ()
matchSize :: forall s. Text -> Int -> Int -> Decoder s ()
matchSize Text
lbl Int
requestedSize Int
actualSize =
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
actualSize forall a. Eq a => a -> a -> Bool
/= Int
requestedSize) 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
lbl
        Int
requestedSize
        Int
actualSize

-- | @'D.Decoder'@ for list.
decodeListWith :: D.Decoder s a -> D.Decoder s [a]
decodeListWith :: forall s a. Decoder s a -> Decoder s [a]
decodeListWith Decoder s a
d = do
  forall s. Decoder s ()
D.decodeListLenIndef
  forall r a r' s.
(r -> a -> r) -> r -> (r -> r') -> Decoder s a -> Decoder s r'
D.decodeSequenceLenIndef (forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) [] forall a. [a] -> [a]
reverse Decoder s a
d

--------------------------------------------------------------------------------
-- Primitive types
--------------------------------------------------------------------------------

instance FromCBOR () where
  fromCBOR :: forall s. Decoder s ()
fromCBOR = forall s. Decoder s ()
D.decodeNull

instance FromCBOR Bool where
  fromCBOR :: forall s. Decoder s Bool
fromCBOR = forall s. Decoder s Bool
D.decodeBool

--------------------------------------------------------------------------------
-- Numeric data
--------------------------------------------------------------------------------

instance FromCBOR Integer where
  fromCBOR :: forall s. Decoder s Integer
fromCBOR = forall s. Decoder s Integer
D.decodeInteger

instance FromCBOR Word where
  fromCBOR :: forall s. Decoder s Word
fromCBOR = forall s. Decoder s Word
D.decodeWord

instance FromCBOR Word8 where
  fromCBOR :: forall s. Decoder s Word8
fromCBOR = forall s. Decoder s Word8
D.decodeWord8

instance FromCBOR Word16 where
  fromCBOR :: forall s. Decoder s Word16
fromCBOR = forall s. Decoder s Word16
D.decodeWord16

instance FromCBOR Word32 where
  fromCBOR :: forall s. Decoder s Word32
fromCBOR = forall s. Decoder s Word32
D.decodeWord32

instance FromCBOR Word64 where
  fromCBOR :: forall s. Decoder s Word64
fromCBOR = forall s. Decoder s Word64
D.decodeWord64

instance FromCBOR Int where
  fromCBOR :: forall s. Decoder s Int
fromCBOR = forall s. Decoder s Int
D.decodeInt

instance FromCBOR Int32 where
  fromCBOR :: forall s. Decoder s Int32
fromCBOR = forall s. Decoder s Int32
D.decodeInt32

instance FromCBOR Int64 where
  fromCBOR :: forall s. Decoder s Int64
fromCBOR = forall s. Decoder s Int64
D.decodeInt64

instance FromCBOR Float where
  fromCBOR :: forall s. Decoder s Float
fromCBOR = forall s. Decoder s Float
D.decodeFloat

instance FromCBOR Double where
  fromCBOR :: forall s. Decoder s Double
fromCBOR = forall s. Decoder s Double
D.decodeDouble

instance FromCBOR Rational where
  fromCBOR :: forall s. Decoder s Rational
fromCBOR = do
    forall s. Text -> Int -> Decoder s ()
enforceSize Text
"Rational" Int
2
    Integer
n <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    Integer
d <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    if Integer
d forall a. Ord a => a -> a -> Bool
<= Integer
0
      then forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError forall a b. (a -> b) -> a -> b
$ Text -> Text -> DecoderError
DecoderErrorCustom Text
"Rational" Text
"invalid denominator"
      else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Integer
n forall a. Integral a => a -> a -> Ratio a
% Integer
d

instance Typeable a => FromCBOR (Fixed a) where
  fromCBOR :: forall s. Decoder s (Fixed a)
fromCBOR = forall k (a :: k). Integer -> Fixed a
MkFixed forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. FromCBOR a => Decoder s a
fromCBOR

decodeNominalDiffTime :: Decoder s NominalDiffTime
decodeNominalDiffTime :: forall s. Decoder s NominalDiffTime
decodeNominalDiffTime = Pico -> NominalDiffTime
secondsToNominalDiffTime forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. FromCBOR a => Decoder s a
fromCBOR

-- | For backwards compatibility we round pico precision to micro
decodeNominalDiffTimeMicro :: Decoder s NominalDiffTime
decodeNominalDiffTimeMicro :: forall s. Decoder s NominalDiffTime
decodeNominalDiffTimeMicro = forall a. Fractional a => Rational -> a
fromRational forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (forall a. Integral a => a -> a -> Ratio a
% Integer
1e6) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. FromCBOR a => Decoder s a
fromCBOR

instance FromCBOR Natural where
  fromCBOR :: forall s. Decoder s Natural
fromCBOR = do
    !Integer
n <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    if Integer
n forall a. Ord a => a -> a -> Bool
>= Integer
0
      then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. Num a => Integer -> a
fromInteger Integer
n
      else forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError forall a b. (a -> b) -> a -> b
$ Text -> Text -> DecoderError
DecoderErrorCustom Text
"Natural" Text
"got a negative number"

instance FromCBOR Void where
  fromCBOR :: forall s. Decoder s Void
fromCBOR = forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError DecoderError
DecoderErrorVoid

--------------------------------------------------------------------------------
-- Tagged
--------------------------------------------------------------------------------

instance (Typeable s, FromCBOR a) => FromCBOR (Tagged s a) where
  fromCBOR :: forall s. Decoder s (Tagged s a)
fromCBOR = forall {k} (s :: k) b. b -> Tagged s b
Tagged forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. FromCBOR a => Decoder s a
fromCBOR

--------------------------------------------------------------------------------
-- Containers
--------------------------------------------------------------------------------

instance (FromCBOR a, FromCBOR b) => FromCBOR (a, b) where
  fromCBOR :: forall s. Decoder s (a, b)
fromCBOR = do
    forall s. Int -> Decoder s ()
D.decodeListLenOf Int
2
    !a
x <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !b
y <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, b
y)

instance (FromCBOR a, FromCBOR b, FromCBOR c) => FromCBOR (a, b, c) where
  fromCBOR :: forall s. Decoder s (a, b, c)
fromCBOR = do
    forall s. Int -> Decoder s ()
D.decodeListLenOf Int
3
    !a
x <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !b
y <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !c
z <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, b
y, c
z)

instance (FromCBOR a, FromCBOR b, FromCBOR c, FromCBOR d) => FromCBOR (a, b, c, d) where
  fromCBOR :: forall s. Decoder s (a, b, c, d)
fromCBOR = do
    forall s. Int -> Decoder s ()
D.decodeListLenOf Int
4
    !a
a <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !b
b <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !c
c <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !d
d <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
b, c
c, d
d)

instance
  (FromCBOR a, FromCBOR b, FromCBOR c, FromCBOR d, FromCBOR e) =>
  FromCBOR (a, b, c, d, e)
  where
  fromCBOR :: forall s. Decoder s (a, b, c, d, e)
fromCBOR = do
    forall s. Int -> Decoder s ()
D.decodeListLenOf Int
5
    !a
a <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !b
b <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !c
c <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !d
d <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !e
e <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
b, c
c, d
d, e
e)

instance
  (FromCBOR a, FromCBOR b, FromCBOR c, FromCBOR d, FromCBOR e, FromCBOR f) =>
  FromCBOR (a, b, c, d, e, f)
  where
  fromCBOR :: forall s. Decoder s (a, b, c, d, e, f)
fromCBOR = do
    forall s. Int -> Decoder s ()
D.decodeListLenOf Int
6
    !a
a <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !b
b <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !c
c <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !d
d <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !e
e <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !f
f <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
b, c
c, d
d, e
e, f
f)

instance
  ( FromCBOR a
  , FromCBOR b
  , FromCBOR c
  , FromCBOR d
  , FromCBOR e
  , FromCBOR f
  , FromCBOR g
  ) =>
  FromCBOR (a, b, c, d, e, f, g)
  where
  fromCBOR :: forall s. Decoder s (a, b, c, d, e, f, g)
fromCBOR = do
    forall s. Int -> Decoder s ()
D.decodeListLenOf Int
7
    !a
a <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !b
b <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !c
c <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !d
d <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !e
e <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !f
f <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !g
g <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
b, c
c, d
d, e
e, f
f, g
g)

instance
  ( FromCBOR a
  , FromCBOR b
  , FromCBOR c
  , FromCBOR d
  , FromCBOR e
  , FromCBOR f
  , FromCBOR g
  , FromCBOR h
  ) =>
  FromCBOR (a, b, c, d, e, f, g, h)
  where
  fromCBOR :: forall s. Decoder s (a, b, c, d, e, f, g, h)
fromCBOR = do
    forall s. Int -> Decoder s ()
D.decodeListLenOf Int
8
    !a
a <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !b
b <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !c
c <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !d
d <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !e
e <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !f
f <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !g
g <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    !h
h <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
b, c
c, d
d, e
e, f
f, g
g, h
h)

instance FromCBOR BS.ByteString where
  fromCBOR :: forall s. Decoder s ByteString
fromCBOR = forall s. Decoder s ByteString
D.decodeBytes

instance FromCBOR Text where
  fromCBOR :: forall s. Decoder s Text
fromCBOR = forall s. Decoder s Text
D.decodeString

instance FromCBOR BSL.ByteString where
  fromCBOR :: forall s. Decoder s ByteString
fromCBOR = ByteString -> ByteString
BSL.fromStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. FromCBOR a => Decoder s a
fromCBOR

instance FromCBOR SBS.ShortByteString where
  fromCBOR :: forall s. Decoder s ShortByteString
fromCBOR = do
    BA.BA (Prim.ByteArray ByteArray#
ba) <- forall s. Decoder s ByteArray
D.decodeByteArray
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteArray# -> ShortByteString
SBS ByteArray#
ba

instance FromCBOR a => FromCBOR [a] where
  fromCBOR :: forall s. Decoder s [a]
fromCBOR = forall s a. Decoder s a -> Decoder s [a]
decodeListWith forall a s. FromCBOR a => Decoder s a
fromCBOR

instance (FromCBOR a, FromCBOR b) => FromCBOR (Either a b) where
  fromCBOR :: forall s. Decoder s (Either a b)
fromCBOR = do
    forall s. Int -> Decoder s ()
D.decodeListLenOf Int
2
    Word
t <- forall s. Decoder s Word
D.decodeWord
    case Word
t of
      Word
0 -> do
        !a
x <- forall a s. FromCBOR a => Decoder s a
fromCBOR
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left a
x)
      Word
1 -> do
        !b
x <- forall a s. FromCBOR a => Decoder s a
fromCBOR
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right b
x)
      Word
_ -> forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError forall a b. (a -> b) -> a -> b
$ Text -> Word8 -> DecoderError
DecoderErrorUnknownTag Text
"Either" (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
t)

instance FromCBOR a => FromCBOR (NonEmpty a) where
  fromCBOR :: forall s. Decoder s (NonEmpty a)
fromCBOR =
    forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. FromCBOR a => Decoder s a
fromCBOR
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) e a.
(MonadFail m, Buildable e) =>
Either e a -> m a
toCborError forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. \case
        Maybe (NonEmpty a)
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> DecoderError
DecoderErrorEmptyList Text
"NonEmpty"
        Just NonEmpty a
xs -> forall a b. b -> Either a b
Right NonEmpty a
xs

instance FromCBOR a => FromCBOR (Maybe a) where
  fromCBOR :: forall s. Decoder s (Maybe a)
fromCBOR = forall s a. Decoder s a -> Decoder s (Maybe a)
decodeMaybe forall a s. FromCBOR a => Decoder s a
fromCBOR

fromCBORMaybe :: D.Decoder s a -> D.Decoder s (Maybe a)
fromCBORMaybe :: forall s a. Decoder s a -> Decoder s (Maybe a)
fromCBORMaybe = forall s a. Decoder s a -> Decoder s (Maybe a)
decodeMaybe
{-# DEPRECATED fromCBORMaybe "In favor of `decodeMaybe`" #-}

decodeMaybe :: D.Decoder s a -> D.Decoder s (Maybe a)
decodeMaybe :: forall s a. Decoder s a -> Decoder s (Maybe a)
decodeMaybe Decoder s a
decodeValue = do
  Int
n <- forall s. Decoder s Int
D.decodeListLen
  case Int
n of
    Int
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Int
1 -> do
      !a
x <- Decoder s a
decodeValue
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
x)
    Int
_ -> forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError forall a b. (a -> b) -> a -> b
$ Text -> Word8 -> DecoderError
DecoderErrorUnknownTag Text
"Maybe" (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)

decodeNullMaybe :: D.Decoder s a -> D.Decoder s (Maybe a)
decodeNullMaybe :: forall s a. Decoder s a -> Decoder s (Maybe a)
decodeNullMaybe Decoder s a
decoder = do
  forall s. Decoder s TokenType
D.peekTokenType forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    TokenType
D.TypeNull -> do
      forall s. Decoder s ()
D.decodeNull
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    TokenType
_ -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s a
decoder

decodeContainerSkelWithReplicate ::
  FromCBOR a =>
  -- | How to get the size of the container
  D.Decoder s Int ->
  -- | replicateM for the container
  (Int -> D.Decoder s a -> D.Decoder s container) ->
  -- | concat for the container
  ([container] -> container) ->
  D.Decoder s container
decodeContainerSkelWithReplicate :: forall a s container.
FromCBOR a =>
Decoder s Int
-> (Int -> Decoder s a -> Decoder s container)
-> ([container] -> container)
-> Decoder s container
decodeContainerSkelWithReplicate Decoder s Int
decodeLen Int -> Decoder s a -> Decoder s container
replicateFun [container] -> container
fromList = do
  -- Look at how much data we have at the moment and use it as the limit for
  -- the size of a single call to replicateFun. We don't want to use
  -- replicateFun directly on the result of decodeLen since this might lead to
  -- DOS attack (attacker providing a huge value for length). So if it's above
  -- our limit, we'll do manual chunking and then combine the containers into
  -- one.
  Int
size <- Decoder s Int
decodeLen
  Int
limit <- forall s. Decoder s Int
D.peekAvailable
  if Int
size forall a. Ord a => a -> a -> Bool
<= Int
limit
    then Int -> Decoder s a -> Decoder s container
replicateFun Int
size forall a s. FromCBOR a => Decoder s a
fromCBOR
    else do
      -- Take the max of limit and a fixed chunk size (note: limit can be
      -- 0). This basically means that the attacker can make us allocate a
      -- container of size 128 even though there's no actual input.
      let
        chunkSize :: Int
chunkSize = forall a. Ord a => a -> a -> a
max Int
limit Int
128
        (Int
d, Int
m) = Int
size forall a. Integral a => a -> a -> (a, a)
`divMod` Int
chunkSize
        buildOne :: Int -> Decoder s container
buildOne Int
s = Int -> Decoder s a -> Decoder s container
replicateFun Int
s forall a s. FromCBOR a => Decoder s a
fromCBOR
      [container]
containers <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ Int -> Decoder s container
buildOne Int
m forall a. a -> [a] -> [a]
: forall a. Int -> a -> [a]
replicate Int
d (Int -> Decoder s container
buildOne Int
chunkSize)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! [container] -> container
fromList [container]
containers
{-# INLINE decodeContainerSkelWithReplicate #-}

-- | Checks canonicity by comparing the new key being decoded with
--   the previous one, to enfore these are sorted the correct way.
--   See: https://tools.ietf.org/html/rfc7049#section-3.9
--   "[..]The keys in every map must be sorted lowest value to highest.[...]"
decodeMapSkel ::
  (Ord k, FromCBOR k, FromCBOR v) => ([(k, v)] -> m) -> D.Decoder s m
decodeMapSkel :: forall k v m s.
(Ord k, FromCBOR k, FromCBOR v) =>
([(k, v)] -> m) -> Decoder s m
decodeMapSkel [(k, v)] -> m
fromDistinctAscList = do
  Int
n <- forall s. Decoder s Int
D.decodeMapLen
  case Int
n of
    Int
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return ([(k, v)] -> m
fromDistinctAscList [])
    Int
_ -> do
      (k
firstKey, v
firstValue) <- forall k v s. (FromCBOR k, FromCBOR v) => Decoder s (k, v)
decodeEntry
      [(k, v)] -> m
fromDistinctAscList
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v s.
(FromCBOR k, FromCBOR v, Ord k) =>
Int -> k -> [(k, v)] -> Decoder s [(k, v)]
decodeEntries (Int
n forall a. Num a => a -> a -> a
- Int
1) k
firstKey [(k
firstKey, v
firstValue)]
  where
    -- Decode a single (k,v).
    decodeEntry :: (FromCBOR k, FromCBOR v) => D.Decoder s (k, v)
    decodeEntry :: forall k v s. (FromCBOR k, FromCBOR v) => Decoder s (k, v)
decodeEntry = do
      !k
k <- forall a s. FromCBOR a => Decoder s a
fromCBOR
      !v
v <- forall a s. FromCBOR a => Decoder s a
fromCBOR
      forall (m :: * -> *) a. Monad m => a -> m a
return (k
k, v
v)

    -- Decode all the entries, enforcing canonicity by ensuring that the
    -- previous key is smaller than the next one.
    decodeEntries ::
      (FromCBOR k, FromCBOR v, Ord k) =>
      Int ->
      k ->
      [(k, v)] ->
      D.Decoder s [(k, v)]
    decodeEntries :: forall k v s.
(FromCBOR k, FromCBOR v, Ord k) =>
Int -> k -> [(k, v)] -> Decoder s [(k, v)]
decodeEntries Int
0 k
_ [(k, v)]
acc = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [(k, v)]
acc
    decodeEntries !Int
remainingPairs k
previousKey ![(k, v)]
acc = do
      p :: (k, v)
p@(k
newKey, v
_) <- forall k v s. (FromCBOR k, FromCBOR v) => Decoder s (k, v)
decodeEntry
      -- Order of keys needs to be strictly increasing, because otherwise it's
      -- possible to supply lists with various amount of duplicate keys which
      -- will result in the same map as long as the last value of the given
      -- key on the list is the same in all of them.
      if k
newKey forall a. Ord a => a -> a -> Bool
> k
previousKey
        then forall k v s.
(FromCBOR k, FromCBOR v, Ord k) =>
Int -> k -> [(k, v)] -> Decoder s [(k, v)]
decodeEntries (Int
remainingPairs forall a. Num a => a -> a -> a
- Int
1) k
newKey ((k, v)
p forall a. a -> [a] -> [a]
: [(k, v)]
acc)
        else forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError forall a b. (a -> b) -> a -> b
$ Text -> DecoderError
DecoderErrorCanonicityViolation Text
"Map"
{-# INLINE decodeMapSkel #-}

instance (Ord k, FromCBOR k, FromCBOR v) => FromCBOR (M.Map k v) where
  fromCBOR :: forall s. Decoder s (Map k v)
fromCBOR = forall k v m s.
(Ord k, FromCBOR k, FromCBOR v) =>
([(k, v)] -> m) -> Decoder s m
decodeMapSkel forall k a. [(k, a)] -> Map k a
M.fromDistinctAscList

-- We stitch a `258` in from of a (Hash)Set, so that tools which
-- programmatically check for canonicity can recognise it from a normal
-- array. Why 258? This will be formalised pretty soon, but IANA allocated
-- 256...18446744073709551615 to "First come, first served":
-- https://www.iana.org/assignments/cbor-tags/cbor-tags.xhtml Currently `258` is
-- the first unassigned tag and as it requires 2 bytes to be encoded, it sounds
-- like the best fit.
setTag :: Word
setTag :: Word
setTag = Word
258

decodeSetTag :: D.Decoder s ()
decodeSetTag :: forall s. Decoder s ()
decodeSetTag = do
  Word
t <- forall s. Decoder s Word
D.decodeTag
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word
t forall a. Eq a => a -> a -> Bool
/= Word
setTag) 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 -> Word8 -> DecoderError
DecoderErrorUnknownTag Text
"Set" (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
t)

decodeSetSkel :: (Ord a, FromCBOR a) => ([a] -> c) -> D.Decoder s c
decodeSetSkel :: forall a c s. (Ord a, FromCBOR a) => ([a] -> c) -> Decoder s c
decodeSetSkel [a] -> c
fromDistinctAscList = do
  forall s. Decoder s ()
decodeSetTag
  Int
n <- forall s. Decoder s Int
D.decodeListLen
  case Int
n of
    Int
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> c
fromDistinctAscList [])
    Int
_ -> do
      a
firstValue <- forall a s. FromCBOR a => Decoder s a
fromCBOR
      [a] -> c
fromDistinctAscList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v s. (FromCBOR v, Ord v) => Int -> v -> [v] -> Decoder s [v]
decodeEntries (Int
n forall a. Num a => a -> a -> a
- Int
1) a
firstValue [a
firstValue]
  where
    decodeEntries :: (FromCBOR v, Ord v) => Int -> v -> [v] -> D.Decoder s [v]
    decodeEntries :: forall v s. (FromCBOR v, Ord v) => Int -> v -> [v] -> Decoder s [v]
decodeEntries Int
0 v
_ [v]
acc = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [v]
acc
    decodeEntries !Int
remainingEntries v
previousValue ![v]
acc = do
      v
newValue <- forall a s. FromCBOR a => Decoder s a
fromCBOR
      -- Order of values needs to be strictly increasing, because otherwise
      -- it's possible to supply lists with various amount of duplicates which
      -- will result in the same set.
      if v
newValue forall a. Ord a => a -> a -> Bool
> v
previousValue
        then forall v s. (FromCBOR v, Ord v) => Int -> v -> [v] -> Decoder s [v]
decodeEntries (Int
remainingEntries forall a. Num a => a -> a -> a
- Int
1) v
newValue (v
newValue forall a. a -> [a] -> [a]
: [v]
acc)
        else forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError forall a b. (a -> b) -> a -> b
$ Text -> DecoderError
DecoderErrorCanonicityViolation Text
"Set"
{-# INLINE decodeSetSkel #-}

instance (Ord a, FromCBOR a) => FromCBOR (S.Set a) where
  fromCBOR :: forall s. Decoder s (Set a)
fromCBOR = forall a c s. (Ord a, FromCBOR a) => ([a] -> c) -> Decoder s c
decodeSetSkel forall a. [a] -> Set a
S.fromDistinctAscList

-- | Generic decoder for vectors. Its intended use is to allow easy
-- definition of 'Serialise' instances for custom vector
decodeVector :: (FromCBOR a, Vector.Generic.Vector v a) => D.Decoder s (v a)
decodeVector :: forall a (v :: * -> *) s.
(FromCBOR a, Vector v a) =>
Decoder s (v a)
decodeVector =
  forall a s container.
FromCBOR a =>
Decoder s Int
-> (Int -> Decoder s a -> Decoder s container)
-> ([container] -> container)
-> Decoder s container
decodeContainerSkelWithReplicate
    forall s. Decoder s Int
D.decodeListLen
    forall (m :: * -> *) (v :: * -> *) a.
(Monad m, Vector v a) =>
Int -> m a -> m (v a)
Vector.Generic.replicateM
    forall (v :: * -> *) a. Vector v a => [v a] -> v a
Vector.Generic.concat
{-# INLINE decodeVector #-}

instance FromCBOR a => FromCBOR (Vector.Vector a) where
  fromCBOR :: forall s. Decoder s (Vector a)
fromCBOR = forall a (v :: * -> *) s.
(FromCBOR a, Vector v a) =>
Decoder s (v a)
decodeVector
  {-# INLINE fromCBOR #-}

instance FromCBOR a => FromCBOR (Seq.Seq a) where
  fromCBOR :: forall s. Decoder s (Seq a)
fromCBOR = forall s a. Decoder s a -> Decoder s (Seq a)
decodeSeq forall a s. FromCBOR a => Decoder s a
fromCBOR
  {-# INLINE fromCBOR #-}

decodeSeq :: Decoder s a -> Decoder s (Seq.Seq a)
decodeSeq :: forall s a. Decoder s a -> Decoder s (Seq a)
decodeSeq Decoder s a
decoder = forall a. [a] -> Seq a
Seq.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a. Decoder s (Maybe Int) -> Decoder s a -> Decoder s [a]
decodeCollection forall s. Decoder s (Maybe Int)
decodeListLenOrIndef Decoder s a
decoder

decodeCollection :: Decoder s (Maybe Int) -> Decoder s a -> Decoder s [a]
decodeCollection :: forall s a. Decoder s (Maybe Int) -> Decoder s a -> Decoder s [a]
decodeCollection Decoder s (Maybe Int)
lenOrIndef Decoder s a
el = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s v.
Decoder s (Maybe Int) -> Decoder s v -> Decoder s (Int, [v])
decodeCollectionWithLen Decoder s (Maybe Int)
lenOrIndef Decoder s a
el

decodeCollectionWithLen ::
  Decoder s (Maybe Int) ->
  Decoder s v ->
  Decoder s (Int, [v])
decodeCollectionWithLen :: forall s v.
Decoder s (Maybe Int) -> Decoder s v -> Decoder s (Int, [v])
decodeCollectionWithLen Decoder s (Maybe Int)
lenOrIndef Decoder s v
el = do
  Decoder s (Maybe Int)
lenOrIndef forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Int
len -> (,) Int
len forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
len Decoder s v
el
    Maybe Int
Nothing -> forall {m :: * -> *} {a} {a}.
(Monad m, Num a) =>
(a, [a]) -> m Bool -> m a -> m (a, [a])
loop (Int
0, []) (Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Bool
decodeBreakOr) Decoder s v
el
  where
    loop :: (a, [a]) -> m Bool -> m a -> m (a, [a])
loop (!a
n, ![a]
acc) m Bool
condition m a
action =
      m Bool
condition forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
False -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
n, forall a. [a] -> [a]
reverse [a]
acc)
        Bool
True -> m a
action forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
v -> (a, [a]) -> m Bool -> m a -> m (a, [a])
loop (a
n forall a. Num a => a -> a -> a
+ a
1, a
v forall a. a -> [a] -> [a]
: [a]
acc) m Bool
condition m a
action

--------------------------------------------------------------------------------
-- Time
--------------------------------------------------------------------------------

instance FromCBOR UTCTime where
  fromCBOR :: forall s. Decoder s UTCTime
fromCBOR = do
    forall s. Text -> Int -> Decoder s ()
enforceSize Text
"UTCTime" Int
3
    Integer
year <- forall s. Decoder s Integer
decodeInteger
    Int
dayOfYear <- forall s. Decoder s Int
decodeInt
    Integer
timeOfDayPico <- forall s. Decoder s Integer
decodeInteger
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
      Day -> DiffTime -> UTCTime
UTCTime
        (Integer -> Int -> Day
fromOrdinalDate Integer
year Int
dayOfYear)
        (Integer -> DiffTime
picosecondsToDiffTime Integer
timeOfDayPico)

-- | Convert an 'Either'-encoded failure to a 'MonadFail' failure using the `B.Buildable`
-- insatance
toCborError :: (MonadFail m, B.Buildable e) => Either e a -> m a
toCborError :: forall (m :: * -> *) e a.
(MonadFail m, Buildable e) =>
Either e a -> m a
toCborError = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Convert a `B.Buildable` error message into a 'MonadFail' failure.
cborError :: (MonadFail m, B.Buildable e) => e -> m a
cborError :: forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Format String a -> a
formatToString forall a r. Buildable a => Format r (a -> r)
build