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

module Cardano.Binary.FromCBOR
  ( FromCBOR(..)
  , DecoderError(..)
  , enforceSize
  , matchSize
  , module D
  , fromCBORMaybe
  , decodeListWith
    -- * Helper tools to build instances
  , decodeMapSkel
  , cborError
  , toCborError
  )
where

import Prelude hiding ((.))

import Codec.CBOR.Decoding as D
import Codec.CBOR.ByteArray as BA ( ByteArray(BA) )
import Control.Category (Category((.)))
import Control.Exception (Exception)
import Control.Monad (when)
import qualified Codec.CBOR.Read as CBOR.Read
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(..), Nano, Pico)
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 ( Ratio, (%) )
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)
import Data.Typeable ( Typeable, typeRep, Proxy )
import qualified Data.Vector as Vector
import qualified Data.Vector.Generic as Vector.Generic
import Data.Void (Void)
import Data.Word ( Word8, Word16, Word32, Word64 )
import Formatting
    ( bprint, int, shown, stext, build, formatToString )
import qualified Formatting.Buildable as B (Buildable(..))
import Numeric.Natural (Natural)


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

--------------------------------------------------------------------------------
-- FromCBOR
--------------------------------------------------------------------------------

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


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

data DecoderError
  = DecoderErrorCanonicityViolation Text
  | DecoderErrorCustom Text Text
  -- ^ Custom decoding error, usually due to some validation failure
  | DecoderErrorDeserialiseFailure Text CBOR.Read.DeserialiseFailure
  | DecoderErrorEmptyList Text
  | DecoderErrorLeftover Text BS.ByteString
  | DecoderErrorSizeMismatch Text Int Int
  -- ^ A size mismatch @DecoderErrorSizeMismatch label expectedSize actualSize@
  | 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 e s a. Buildable e => e -> Decoder s 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 Float where
  fromCBOR :: forall s. Decoder s Float
fromCBOR = forall s. Decoder s Float
D.decodeFloat

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

instance FromCBOR Nano where
  fromCBOR :: forall s. Decoder s Nano
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

instance FromCBOR Pico where
  fromCBOR :: forall s. Decoder s Pico
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

-- | For backwards compatibility we round pico precision to micro
instance FromCBOR NominalDiffTime where
  fromCBOR :: forall s. Decoder s NominalDiffTime
fromCBOR = 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 e s a. Buildable e => e -> Decoder s 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 e s a. Buildable e => e -> Decoder s 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 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 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 e s a. Buildable e => e -> Decoder s 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 e a s. Buildable e => Either e a -> Decoder s 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)
fromCBORMaybe 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
fromCBORA = 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
fromCBORA
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
x)
    Int
_ -> forall e s a. Buildable e => e -> Decoder s 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)

decodeContainerSkelWithReplicate
  :: FromCBOR a
  => D.Decoder s Int
  -- ^ How to get the size of the container
  -> (Int -> D.Decoder s a -> D.Decoder s container)
  -- ^ replicateM for the container
  -> ([container] -> container)
  -- ^ concat for the 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 e s a. Buildable e => e -> Decoder s 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 e s a. Buildable e => e -> Decoder s 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 e s a. Buildable e => e -> Decoder s 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 #-}


--------------------------------------------------------------------------------
-- 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 'cborg' decoder failure
toCborError :: B.Buildable e => Either e a -> D.Decoder s a
toCborError :: forall e a s. Buildable e => Either e a -> Decoder s a
toCborError = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e s a. Buildable e => e -> Decoder s a
cborError forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Convert a @Buildable@ error into a 'cborg' decoder error
cborError :: B.Buildable e => e -> D.Decoder s a
cborError :: forall e s a. Buildable e => e -> Decoder s 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