{-# 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 (String -> Text) -> (Proxy a -> String) -> Proxy a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> (Proxy a -> TypeRep) -> Proxy a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep

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

instance FromCBOR TermToken where
  fromCBOR :: forall s. Decoder s TermToken
fromCBOR = Decoder s TermToken
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
(DecoderError -> DecoderError -> Bool)
-> (DecoderError -> DecoderError -> Bool) -> Eq DecoderError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DecoderError -> DecoderError -> Bool
== :: DecoderError -> DecoderError -> Bool
$c/= :: DecoderError -> DecoderError -> Bool
/= :: DecoderError -> DecoderError -> Bool
Eq, Int -> DecoderError -> ShowS
[DecoderError] -> ShowS
DecoderError -> String
(Int -> DecoderError -> ShowS)
-> (DecoderError -> String)
-> ([DecoderError] -> ShowS)
-> Show DecoderError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DecoderError -> ShowS
showsPrec :: Int -> DecoderError -> ShowS
$cshow :: DecoderError -> String
show :: DecoderError -> String
$cshowList :: [DecoderError] -> ShowS
showList :: [DecoderError] -> ShowS
Show)

instance Exception DecoderError

instance B.Buildable DecoderError where
  build :: DecoderError -> Builder
build = \case
    DecoderErrorCanonicityViolation Text
lbl ->
      Format Builder (Text -> Builder) -> Text -> Builder
forall a. Format Builder a -> a
bprint (Format (Text -> Builder) (Text -> Builder)
"Canonicity violation while decoding " Format (Text -> Builder) (Text -> Builder)
-> Format Builder (Text -> Builder)
-> Format Builder (Text -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder (Text -> Builder)
forall r. Format r (Text -> r)
stext) Text
lbl
    DecoderErrorCustom Text
lbl Text
err ->
      Format Builder (Text -> Text -> Builder) -> Text -> Text -> Builder
forall a. Format Builder a -> a
bprint
        ( Format (Text -> Text -> Builder) (Text -> Text -> Builder)
"An error occured while decoding "
            Format (Text -> Text -> Builder) (Text -> Text -> Builder)
-> Format Builder (Text -> Text -> Builder)
-> Format Builder (Text -> Text -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
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 -> Text -> Builder)
forall r. Format r (Text -> r)
stext
            Format (Text -> Builder) (Text -> Text -> Builder)
-> Format Builder (Text -> Builder)
-> Format Builder (Text -> Text -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
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"
            Format (Text -> Builder) (Text -> Builder)
-> Format Builder (Text -> Builder)
-> Format Builder (Text -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
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: "
            Format (Text -> Builder) (Text -> Builder)
-> Format Builder (Text -> Builder)
-> Format Builder (Text -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder (Text -> Builder)
forall r. Format r (Text -> r)
stext
        )
        Text
lbl
        Text
err
    DecoderErrorDeserialiseFailure Text
lbl DeserialiseFailure
failure ->
      Format Builder (Text -> DeserialiseFailure -> Builder)
-> Text -> DeserialiseFailure -> Builder
forall a. Format Builder a -> a
bprint
        ( Format
  (Text -> DeserialiseFailure -> Builder)
  (Text -> DeserialiseFailure -> Builder)
"Deserialisation failure while decoding "
            Format
  (Text -> DeserialiseFailure -> Builder)
  (Text -> DeserialiseFailure -> Builder)
-> Format Builder (Text -> DeserialiseFailure -> Builder)
-> Format Builder (Text -> DeserialiseFailure -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
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)
  (Text -> DeserialiseFailure -> Builder)
forall r. Format r (Text -> r)
stext
            Format
  (DeserialiseFailure -> Builder)
  (Text -> DeserialiseFailure -> Builder)
-> Format Builder (DeserialiseFailure -> Builder)
-> Format Builder (Text -> DeserialiseFailure -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
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"
            Format
  (DeserialiseFailure -> Builder) (DeserialiseFailure -> Builder)
-> Format Builder (DeserialiseFailure -> Builder)
-> Format Builder (DeserialiseFailure -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
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: "
            Format
  (DeserialiseFailure -> Builder) (DeserialiseFailure -> Builder)
-> Format Builder (DeserialiseFailure -> Builder)
-> Format Builder (DeserialiseFailure -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder (DeserialiseFailure -> Builder)
forall a r. Show a => Format r (a -> r)
shown
        )
        Text
lbl
        DeserialiseFailure
failure
    DecoderErrorEmptyList Text
lbl ->
      Format Builder (Text -> Builder) -> Text -> Builder
forall a. Format Builder a -> a
bprint (Format (Text -> Builder) (Text -> Builder)
"Found unexpected empty list while decoding " Format (Text -> Builder) (Text -> Builder)
-> Format Builder (Text -> Builder)
-> Format Builder (Text -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder (Text -> Builder)
forall r. Format r (Text -> r)
stext) Text
lbl
    DecoderErrorLeftover Text
lbl ByteString
leftover ->
      Format Builder (Text -> ByteString -> Builder)
-> Text -> ByteString -> Builder
forall a. Format Builder a -> a
bprint
        ( Format
  (Text -> ByteString -> Builder) (Text -> ByteString -> Builder)
"Found unexpected leftover bytes while decoding "
            Format
  (Text -> ByteString -> Builder) (Text -> ByteString -> Builder)
-> Format Builder (Text -> ByteString -> Builder)
-> Format Builder (Text -> ByteString -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
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) (Text -> ByteString -> Builder)
forall r. Format r (Text -> r)
stext
            Format (ByteString -> Builder) (Text -> ByteString -> Builder)
-> Format Builder (ByteString -> Builder)
-> Format Builder (Text -> ByteString -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
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"
            Format (ByteString -> Builder) (ByteString -> Builder)
-> Format Builder (ByteString -> Builder)
-> Format Builder (ByteString -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
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: "
            Format (ByteString -> Builder) (ByteString -> Builder)
-> Format Builder (ByteString -> Builder)
-> Format Builder (ByteString -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder (ByteString -> Builder)
forall a r. Show a => Format r (a -> r)
shown
        )
        Text
lbl
        ByteString
leftover
    DecoderErrorSizeMismatch Text
lbl Int
requested Int
actual ->
      Format Builder (Text -> Int -> Int -> Builder)
-> Text -> Int -> Int -> Builder
forall a. Format Builder a -> a
bprint
        ( Format
  (Text -> Int -> Int -> Builder) (Text -> Int -> Int -> Builder)
"Size mismatch when decoding "
            Format
  (Text -> Int -> Int -> Builder) (Text -> Int -> Int -> Builder)
-> Format Builder (Text -> Int -> Int -> Builder)
-> Format Builder (Text -> Int -> Int -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
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) (Text -> Int -> Int -> Builder)
forall r. Format r (Text -> r)
stext
            Format (Int -> Int -> Builder) (Text -> Int -> Int -> Builder)
-> Format Builder (Int -> Int -> Builder)
-> Format Builder (Text -> Int -> Int -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
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"
            Format (Int -> Int -> Builder) (Int -> Int -> Builder)
-> Format Builder (Int -> Int -> Builder)
-> Format Builder (Int -> Int -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
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 "
            Format (Int -> Int -> Builder) (Int -> Int -> Builder)
-> Format Builder (Int -> Int -> Builder)
-> Format Builder (Int -> Int -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
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 -> Int -> Builder)
forall a r. Integral a => Format r (a -> r)
int
            Format (Int -> Builder) (Int -> Int -> Builder)
-> Format Builder (Int -> Builder)
-> Format Builder (Int -> Int -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
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 "
            Format (Int -> Builder) (Int -> Builder)
-> Format Builder (Int -> Builder)
-> Format Builder (Int -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder (Int -> Builder)
forall a r. Integral a => Format r (a -> r)
int
            Format Builder (Int -> Builder)
-> Format Builder Builder -> Format Builder (Int -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
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 ->
      Format Builder (Word8 -> Text -> Builder)
-> Word8 -> Text -> Builder
forall a. Format Builder a -> a
bprint (Format (Word8 -> Text -> Builder) (Word8 -> Text -> Builder)
"Found unknown tag " Format (Word8 -> Text -> Builder) (Word8 -> Text -> Builder)
-> Format Builder (Word8 -> Text -> Builder)
-> Format Builder (Word8 -> Text -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
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) (Word8 -> Text -> Builder)
forall a r. Integral a => Format r (a -> r)
int Format (Text -> Builder) (Word8 -> Text -> Builder)
-> Format Builder (Text -> Builder)
-> Format Builder (Word8 -> Text -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
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 " Format (Text -> Builder) (Text -> Builder)
-> Format Builder (Text -> Builder)
-> Format Builder (Text -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder (Text -> Builder)
forall r. Format r (Text -> r)
stext) Word8
t Text
lbl
    DecoderError
DecoderErrorVoid -> Format Builder Builder -> Builder
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 = Decoder s Int
forall s. Decoder s Int
D.decodeListLen Decoder s Int -> (Int -> Decoder s ()) -> Decoder s ()
forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Int -> Int -> Decoder s ()
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 =
  Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
actualSize Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
requestedSize) (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$
    DecoderError -> Decoder s ()
forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError (DecoderError -> Decoder s ()) -> DecoderError -> Decoder s ()
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
  Decoder s ()
forall s. Decoder s ()
D.decodeListLenIndef
  ([a] -> a -> [a])
-> [a] -> ([a] -> [a]) -> Decoder s a -> Decoder s [a]
forall r a r' s.
(r -> a -> r) -> r -> (r -> r') -> Decoder s a -> Decoder s r'
D.decodeSequenceLenIndef ((a -> [a] -> [a]) -> [a] -> a -> [a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) [] [a] -> [a]
forall a. [a] -> [a]
reverse Decoder s a
d

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

instance FromCBOR Rational where
  fromCBOR :: forall s. Decoder s Rational
fromCBOR = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"Rational" Int
2
    Integer
n <- Decoder s Integer
forall s. Decoder s Integer
forall a s. FromCBOR a => Decoder s a
fromCBOR
    Integer
d <- Decoder s Integer
forall s. Decoder s Integer
forall a s. FromCBOR a => Decoder s a
fromCBOR
    if Integer
d Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0
      then DecoderError -> Decoder s Rational
forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError (DecoderError -> Decoder s Rational)
-> DecoderError -> Decoder s Rational
forall a b. (a -> b) -> a -> b
$ Text -> Text -> DecoderError
DecoderErrorCustom Text
"Rational" Text
"invalid denominator"
      else Rational -> Decoder s Rational
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Rational -> Decoder s Rational) -> Rational -> Decoder s Rational
forall a b. (a -> b) -> a -> b
$! Integer
n Integer -> Integer -> Rational
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 = Integer -> Fixed a
forall k (a :: k). Integer -> Fixed a
MkFixed (Integer -> Fixed a) -> Decoder s Integer -> Decoder s (Fixed a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Integer
forall s. Decoder s Integer
forall a s. FromCBOR a => Decoder s a
fromCBOR

decodeNominalDiffTime :: Decoder s NominalDiffTime
decodeNominalDiffTime :: forall s. Decoder s NominalDiffTime
decodeNominalDiffTime = Pico -> NominalDiffTime
secondsToNominalDiffTime (Pico -> NominalDiffTime)
-> Decoder s Pico -> Decoder s NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Pico
forall s. Decoder s Pico
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 = Rational -> NominalDiffTime
forall a. Fractional a => Rational -> a
fromRational (Rational -> NominalDiffTime)
-> (Integer -> Rational) -> Integer -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
1e6) (Integer -> NominalDiffTime)
-> Decoder s Integer -> Decoder s NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Integer
forall s. Decoder s Integer
forall a s. FromCBOR a => Decoder s a
fromCBOR

instance FromCBOR Natural where
  fromCBOR :: forall s. Decoder s Natural
fromCBOR = do
    !Integer
n <- Decoder s Integer
forall s. Decoder s Integer
forall a s. FromCBOR a => Decoder s a
fromCBOR
    if Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0
      then Natural -> Decoder s Natural
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Natural -> Decoder s Natural) -> Natural -> Decoder s Natural
forall a b. (a -> b) -> a -> b
$! Integer -> Natural
forall a. Num a => Integer -> a
fromInteger Integer
n
      else DecoderError -> Decoder s Natural
forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError (DecoderError -> Decoder s Natural)
-> DecoderError -> Decoder s Natural
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 = DecoderError -> Decoder s Void
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 = a -> Tagged s a
forall {k} (s :: k) b. b -> Tagged s b
Tagged (a -> Tagged s a) -> Decoder s a -> Decoder s (Tagged s a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s a
forall s. Decoder s a
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
    Int -> Decoder s ()
forall s. Int -> Decoder s ()
D.decodeListLenOf Int
2
    !a
x <- Decoder s a
forall s. Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !b
y <- Decoder s b
forall s. Decoder s b
forall a s. FromCBOR a => Decoder s a
fromCBOR
    (a, b) -> Decoder s (a, b)
forall a. a -> Decoder s a
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
    Int -> Decoder s ()
forall s. Int -> Decoder s ()
D.decodeListLenOf Int
3
    !a
x <- Decoder s a
forall s. Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !b
y <- Decoder s b
forall s. Decoder s b
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !c
z <- Decoder s c
forall s. Decoder s c
forall a s. FromCBOR a => Decoder s a
fromCBOR
    (a, b, c) -> Decoder s (a, b, c)
forall a. a -> Decoder s a
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
    Int -> Decoder s ()
forall s. Int -> Decoder s ()
D.decodeListLenOf Int
4
    !a
a <- Decoder s a
forall s. Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !b
b <- Decoder s b
forall s. Decoder s b
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !c
c <- Decoder s c
forall s. Decoder s c
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !d
d <- Decoder s d
forall s. Decoder s d
forall a s. FromCBOR a => Decoder s a
fromCBOR
    (a, b, c, d) -> Decoder s (a, b, c, d)
forall a. a -> Decoder s a
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
    Int -> Decoder s ()
forall s. Int -> Decoder s ()
D.decodeListLenOf Int
5
    !a
a <- Decoder s a
forall s. Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !b
b <- Decoder s b
forall s. Decoder s b
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !c
c <- Decoder s c
forall s. Decoder s c
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !d
d <- Decoder s d
forall s. Decoder s d
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !e
e <- Decoder s e
forall s. Decoder s e
forall a s. FromCBOR a => Decoder s a
fromCBOR
    (a, b, c, d, e) -> Decoder s (a, b, c, d, e)
forall a. a -> Decoder s a
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
    Int -> Decoder s ()
forall s. Int -> Decoder s ()
D.decodeListLenOf Int
6
    !a
a <- Decoder s a
forall s. Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !b
b <- Decoder s b
forall s. Decoder s b
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !c
c <- Decoder s c
forall s. Decoder s c
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !d
d <- Decoder s d
forall s. Decoder s d
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !e
e <- Decoder s e
forall s. Decoder s e
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !f
f <- Decoder s f
forall s. Decoder s f
forall a s. FromCBOR a => Decoder s a
fromCBOR
    (a, b, c, d, e, f) -> Decoder s (a, b, c, d, e, f)
forall a. a -> Decoder s a
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
    Int -> Decoder s ()
forall s. Int -> Decoder s ()
D.decodeListLenOf Int
7
    !a
a <- Decoder s a
forall s. Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !b
b <- Decoder s b
forall s. Decoder s b
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !c
c <- Decoder s c
forall s. Decoder s c
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !d
d <- Decoder s d
forall s. Decoder s d
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !e
e <- Decoder s e
forall s. Decoder s e
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !f
f <- Decoder s f
forall s. Decoder s f
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !g
g <- Decoder s g
forall s. Decoder s g
forall a s. FromCBOR a => Decoder s a
fromCBOR
    (a, b, c, d, e, f, g) -> Decoder s (a, b, c, d, e, f, g)
forall a. a -> Decoder s a
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
    Int -> Decoder s ()
forall s. Int -> Decoder s ()
D.decodeListLenOf Int
8
    !a
a <- Decoder s a
forall s. Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !b
b <- Decoder s b
forall s. Decoder s b
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !c
c <- Decoder s c
forall s. Decoder s c
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !d
d <- Decoder s d
forall s. Decoder s d
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !e
e <- Decoder s e
forall s. Decoder s e
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !f
f <- Decoder s f
forall s. Decoder s f
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !g
g <- Decoder s g
forall s. Decoder s g
forall a s. FromCBOR a => Decoder s a
fromCBOR
    !h
h <- Decoder s h
forall s. Decoder s h
forall a s. FromCBOR a => Decoder s a
fromCBOR
    (a, b, c, d, e, f, g, h) -> Decoder s (a, b, c, d, e, f, g, h)
forall a. a -> Decoder s a
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 = Decoder s ByteString
forall s. Decoder s ByteString
D.decodeBytes

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

instance FromCBOR BSL.ByteString where
  fromCBOR :: forall s. Decoder s ByteString
fromCBOR = ByteString -> ByteString
BSL.fromStrict (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
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) <- Decoder s ByteArray
forall s. Decoder s ByteArray
D.decodeByteArray
    ShortByteString -> Decoder s ShortByteString
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return (ShortByteString -> Decoder s ShortByteString)
-> ShortByteString -> Decoder s ShortByteString
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 = Decoder s a -> Decoder s [a]
forall s a. Decoder s a -> Decoder s [a]
decodeListWith Decoder s a
forall s. Decoder s a
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
    Int -> Decoder s ()
forall s. Int -> Decoder s ()
D.decodeListLenOf Int
2
    Word
t <- Decoder s Word
forall s. Decoder s Word
D.decodeWord
    case Word
t of
      Word
0 -> do
        !a
x <- Decoder s a
forall s. Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR
        Either a b -> Decoder s (Either a b)
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either a b
forall a b. a -> Either a b
Left a
x)
      Word
1 -> do
        !b
x <- Decoder s b
forall s. Decoder s b
forall a s. FromCBOR a => Decoder s a
fromCBOR
        Either a b -> Decoder s (Either a b)
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Either a b
forall a b. b -> Either a b
Right b
x)
      Word
_ -> DecoderError -> Decoder s (Either a b)
forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError (DecoderError -> Decoder s (Either a b))
-> DecoderError -> Decoder s (Either a b)
forall a b. (a -> b) -> a -> b
$ Text -> Word8 -> DecoderError
DecoderErrorUnknownTag Text
"Either" (Word -> Word8
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 =
    [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([a] -> Maybe (NonEmpty a))
-> Decoder s [a] -> Decoder s (Maybe (NonEmpty a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s [a]
forall s. Decoder s [a]
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Decoder s (Maybe (NonEmpty a))
-> (Maybe (NonEmpty a) -> Decoder s (NonEmpty a))
-> Decoder s (NonEmpty a)
forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either DecoderError (NonEmpty a) -> Decoder s (NonEmpty a)
forall (m :: * -> *) e a.
(MonadFail m, Buildable e) =>
Either e a -> m a
toCborError (Either DecoderError (NonEmpty a) -> Decoder s (NonEmpty a))
-> (Maybe (NonEmpty a) -> Either DecoderError (NonEmpty a))
-> Maybe (NonEmpty a)
-> Decoder s (NonEmpty a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
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 -> DecoderError -> Either DecoderError (NonEmpty a)
forall a b. a -> Either a b
Left (DecoderError -> Either DecoderError (NonEmpty a))
-> DecoderError -> Either DecoderError (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ Text -> DecoderError
DecoderErrorEmptyList Text
"NonEmpty"
        Just NonEmpty a
xs -> NonEmpty a -> Either DecoderError (NonEmpty a)
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 = Decoder s a -> Decoder s (Maybe a)
forall s a. Decoder s a -> Decoder s (Maybe a)
decodeMaybe Decoder s a
forall s. Decoder s a
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 = Decoder s a -> Decoder s (Maybe a)
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 <- Decoder s Int
forall s. Decoder s Int
D.decodeListLen
  case Int
n of
    Int
0 -> Maybe a -> Decoder s (Maybe a)
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    Int
1 -> do
      !a
x <- Decoder s a
decodeValue
      Maybe a -> Decoder s (Maybe a)
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
x)
    Int
_ -> DecoderError -> Decoder s (Maybe a)
forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError (DecoderError -> Decoder s (Maybe a))
-> DecoderError -> Decoder s (Maybe a)
forall a b. (a -> b) -> a -> b
$ Text -> Word8 -> DecoderError
DecoderErrorUnknownTag Text
"Maybe" (Int -> Word8
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
  Decoder s TokenType
forall s. Decoder s TokenType
D.peekTokenType Decoder s TokenType
-> (TokenType -> Decoder s (Maybe a)) -> Decoder s (Maybe a)
forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    TokenType
D.TypeNull -> do
      Decoder s ()
forall s. Decoder s ()
D.decodeNull
      Maybe a -> Decoder s (Maybe a)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    TokenType
_ -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Decoder s a -> Decoder s (Maybe a)
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 <- Decoder s Int
forall s. Decoder s Int
D.peekAvailable
  if Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
limit
    then Int -> Decoder s a -> Decoder s container
replicateFun Int
size Decoder s a
forall s. Decoder s a
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 = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
limit Int
128
        (Int
d, Int
m) = Int
size Int -> Int -> (Int, Int)
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 Decoder s a
forall s. Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR
      [container]
containers <- [Decoder s container] -> Decoder s [container]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Decoder s container] -> Decoder s [container])
-> [Decoder s container] -> Decoder s [container]
forall a b. (a -> b) -> a -> b
$ Int -> Decoder s container
buildOne Int
m Decoder s container
-> [Decoder s container] -> [Decoder s container]
forall a. a -> [a] -> [a]
: Int -> Decoder s container -> [Decoder s container]
forall a. Int -> a -> [a]
replicate Int
d (Int -> Decoder s container
buildOne Int
chunkSize)
      container -> Decoder s container
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return (container -> Decoder s container)
-> container -> Decoder s container
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 <- Decoder s Int
forall s. Decoder s Int
D.decodeMapLen
  case Int
n of
    Int
0 -> m -> Decoder s m
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(k, v)] -> m
fromDistinctAscList [])
    Int
_ -> do
      (k
firstKey, v
firstValue) <- Decoder s (k, v)
forall k v s. (FromCBOR k, FromCBOR v) => Decoder s (k, v)
decodeEntry
      [(k, v)] -> m
fromDistinctAscList
        ([(k, v)] -> m) -> Decoder s [(k, v)] -> Decoder s m
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> k -> [(k, v)] -> Decoder s [(k, v)]
forall k v s.
(FromCBOR k, FromCBOR v, Ord k) =>
Int -> k -> [(k, v)] -> Decoder s [(k, v)]
decodeEntries (Int
n Int -> Int -> Int
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 <- Decoder s k
forall s. Decoder s k
forall a s. FromCBOR a => Decoder s a
fromCBOR
      !v
v <- Decoder s v
forall s. Decoder s v
forall a s. FromCBOR a => Decoder s a
fromCBOR
      (k, v) -> Decoder s (k, v)
forall a. a -> Decoder s a
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 = [(k, v)] -> Decoder s [(k, v)]
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(k, v)] -> Decoder s [(k, v)]) -> [(k, v)] -> Decoder s [(k, v)]
forall a b. (a -> b) -> a -> b
$ [(k, v)] -> [(k, v)]
forall a. [a] -> [a]
reverse [(k, v)]
acc
    decodeEntries !Int
remainingPairs k
previousKey ![(k, v)]
acc = do
      p :: (k, v)
p@(k
newKey, v
_) <- Decoder s (k, 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 k -> k -> Bool
forall a. Ord a => a -> a -> Bool
> k
previousKey
        then Int -> k -> [(k, v)] -> Decoder s [(k, v)]
forall k v s.
(FromCBOR k, FromCBOR v, Ord k) =>
Int -> k -> [(k, v)] -> Decoder s [(k, v)]
decodeEntries (Int
remainingPairs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) k
newKey ((k, v)
p (k, v) -> [(k, v)] -> [(k, v)]
forall a. a -> [a] -> [a]
: [(k, v)]
acc)
        else DecoderError -> Decoder s [(k, v)]
forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError (DecoderError -> Decoder s [(k, v)])
-> DecoderError -> Decoder s [(k, v)]
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 = ([(k, v)] -> Map k v) -> Decoder s (Map k v)
forall k v m s.
(Ord k, FromCBOR k, FromCBOR v) =>
([(k, v)] -> m) -> Decoder s m
decodeMapSkel [(k, v)] -> Map k v
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 <- Decoder s Word
forall s. Decoder s Word
D.decodeTag
  Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word
t Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
/= Word
setTag) (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$ DecoderError -> Decoder s ()
forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError (DecoderError -> Decoder s ()) -> DecoderError -> Decoder s ()
forall a b. (a -> b) -> a -> b
$ Text -> Word8 -> DecoderError
DecoderErrorUnknownTag Text
"Set" (Word -> Word8
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
  Decoder s ()
forall s. Decoder s ()
decodeSetTag
  Int
n <- Decoder s Int
forall s. Decoder s Int
D.decodeListLen
  case Int
n of
    Int
0 -> c -> Decoder s c
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> c
fromDistinctAscList [])
    Int
_ -> do
      a
firstValue <- Decoder s a
forall s. Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR
      [a] -> c
fromDistinctAscList ([a] -> c) -> Decoder s [a] -> Decoder s c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> a -> [a] -> Decoder s [a]
forall v s. (FromCBOR v, Ord v) => Int -> v -> [v] -> Decoder s [v]
decodeEntries (Int
n Int -> Int -> Int
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 = [v] -> Decoder s [v]
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([v] -> Decoder s [v]) -> [v] -> Decoder s [v]
forall a b. (a -> b) -> a -> b
$ [v] -> [v]
forall a. [a] -> [a]
reverse [v]
acc
    decodeEntries !Int
remainingEntries v
previousValue ![v]
acc = do
      v
newValue <- Decoder s v
forall s. Decoder s v
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 v -> v -> Bool
forall a. Ord a => a -> a -> Bool
> v
previousValue
        then Int -> v -> [v] -> Decoder s [v]
forall v s. (FromCBOR v, Ord v) => Int -> v -> [v] -> Decoder s [v]
decodeEntries (Int
remainingEntries Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) v
newValue (v
newValue v -> [v] -> [v]
forall a. a -> [a] -> [a]
: [v]
acc)
        else DecoderError -> Decoder s [v]
forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError (DecoderError -> Decoder s [v]) -> DecoderError -> Decoder s [v]
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 = ([a] -> Set a) -> Decoder s (Set a)
forall a c s. (Ord a, FromCBOR a) => ([a] -> c) -> Decoder s c
decodeSetSkel [a] -> Set a
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 =
  Decoder s Int
-> (Int -> Decoder s a -> Decoder s (v a))
-> ([v a] -> v a)
-> Decoder s (v a)
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
forall s. Decoder s Int
D.decodeListLen
    Int -> Decoder s a -> Decoder s (v a)
forall (m :: * -> *) (v :: * -> *) a.
(Monad m, Vector v a) =>
Int -> m a -> m (v a)
Vector.Generic.replicateM
    [v a] -> v a
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 = Decoder s (Vector a)
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 = Decoder s a -> Decoder s (Seq a)
forall s a. Decoder s a -> Decoder s (Seq a)
decodeSeq Decoder s a
forall s. Decoder s a
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 = [a] -> Seq a
forall a. [a] -> Seq a
Seq.fromList ([a] -> Seq a) -> Decoder s [a] -> Decoder s (Seq a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Maybe Int) -> Decoder s a -> Decoder s [a]
forall s a. Decoder s (Maybe Int) -> Decoder s a -> Decoder s [a]
decodeCollection Decoder s (Maybe Int)
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 = (Int, [a]) -> [a]
forall a b. (a, b) -> b
snd ((Int, [a]) -> [a]) -> Decoder s (Int, [a]) -> Decoder s [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Maybe Int) -> Decoder s a -> Decoder s (Int, [a])
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 Decoder s (Maybe Int)
-> (Maybe Int -> Decoder s (Int, [v])) -> Decoder s (Int, [v])
forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Int
len -> (,) Int
len ([v] -> (Int, [v])) -> Decoder s [v] -> Decoder s (Int, [v])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Decoder s v -> Decoder s [v]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
len Decoder s v
el
    Maybe Int
Nothing -> (Int, [v]) -> Decoder s Bool -> Decoder s v -> Decoder s (Int, [v])
forall {m :: * -> *} {a} {a}.
(Monad m, Num a) =>
(a, [a]) -> m Bool -> m a -> m (a, [a])
loop (Int
0, []) (Bool -> Bool
not (Bool -> Bool) -> Decoder s Bool -> Decoder s Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Bool
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 m Bool -> (Bool -> m (a, [a])) -> m (a, [a])
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
False -> (a, [a]) -> m (a, [a])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
n, [a] -> [a]
forall a. [a] -> [a]
reverse [a]
acc)
        Bool
True -> m a
action m a -> (a -> m (a, [a])) -> m (a, [a])
forall a b. m a -> (a -> m b) -> m b
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 a -> a -> a
forall a. Num a => a -> a -> a
+ a
1, a
v a -> [a] -> [a]
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
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"UTCTime" Int
3
    Integer
year <- Decoder s Integer
forall s. Decoder s Integer
decodeInteger
    Int
dayOfYear <- Decoder s Int
forall s. Decoder s Int
decodeInt
    Integer
timeOfDayPico <- Decoder s Integer
forall s. Decoder s Integer
decodeInteger
    UTCTime -> Decoder s UTCTime
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime -> Decoder s UTCTime) -> UTCTime -> Decoder s UTCTime
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 = (e -> m a) -> (a -> m a) -> Either e a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> m a
forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError a -> m a
forall a. a -> m a
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 = String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> (e -> String) -> e -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format String (e -> String) -> e -> String
forall a. Format String a -> a
formatToString Format String (e -> String)
forall a r. Buildable a => Format r (a -> r)
build