{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

module Cardano.Ledger.Serialization
  ( ToCBORGroup (..),
    FromCBORGroup (..),
    CBORGroup (..),
    CborSeq (..),
    decodeList,
    decodeSeq,
    decodeStrictSeq,
    decodeSet,
    decodeMap,
    decodeMapContents,
    decodeMapTraverse,
    decodeMaybe,
    decodeRecordNamed,
    decodeRecordNamedT,
    decodeRecordSum,
    decodeNullMaybe,
    encodeFoldable,
    encodeFoldableEncoder,
    encodeFoldableMapEncoder,
    encodeNullMaybe,
    encodeMap,
    groupRecord,
    ratioToCBOR,
    ratioFromCBOR,
    mapToCBOR,
    mapFromCBOR,
    translateViaCBORAnn,
    -- IPv4
    ipv4ToBytes,
    ipv4FromBytes,
    ipv4ToCBOR,
    ipv4FromCBOR,
    -- IPv6
    ipv6ToBytes,
    ipv6FromBytes,
    ipv6ToCBOR,
    ipv6FromCBOR,
    -- Raw
    listLenInt,
    runByteBuilder,
    -- UTC Time
    utcTimeToCBOR,
    utcTimeFromCBOR,
    -- This abstraction can/should be moved into cardano-binary
    Sized (..),
    mkSized,
    sizedDecoder,
  )
where

import Cardano.Binary
  ( Annotated (..),
    ByteSpan (..),
    Decoder,
    DecoderError (..),
    Encoding,
    FromCBOR (..),
    Size,
    ToCBOR (..),
    annotatedDecoder,
    decodeAnnotator,
    decodeListLenOrIndef,
    decodeTag,
    encodeListLen,
    encodeTag,
    serialize,
    withWordSize,
  )
import Control.Monad (unless, when)
import Control.Monad.Except (Except, MonadError (throwError))
import Data.Binary.Get (Get, getWord32le, runGetOrFail)
import Data.Binary.Put (putWord32le, runPut)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BS
import qualified Data.ByteString.Builder.Extra as BS
import qualified Data.ByteString.Lazy as BSL
import Data.Coders
  ( Annotator,
    cborError,
    decodeCollectionWithLen,
    decodeList,
    decodeMap,
    decodeMapContents,
    decodeMapTraverse,
    decodeNullMaybe,
    decodeRecordNamed,
    decodeRecordNamedT,
    decodeRecordSum,
    decodeSeq,
    decodeSet,
    decodeStrictSeq,
    encodeFoldable,
    encodeFoldableEncoder,
    encodeMap,
    encodeNullMaybe,
    wrapCBORArray,
    wrapCBORMap,
  )
import Data.Foldable (foldl')
import Data.IP
  ( IPv4,
    IPv6,
    fromHostAddress,
    fromHostAddress6,
    toHostAddress,
    toHostAddress6,
  )
import Data.Int (Int64)
import Data.Map.Strict (Map)
import Data.Ratio (Ratio, denominator, numerator, (%))
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Time (UTCTime (..))
import Data.Time.Calendar.OrdinalDate (fromOrdinalDate, toOrdinalDate)
import Data.Time.Clock (diffTimeToPicoseconds, picosecondsToDiffTime)
import Data.Typeable
import GHC.Generics
import Network.Socket (HostAddress6)
import NoThunks.Class (NoThunks)
import Prelude

class Typeable a => ToCBORGroup a where
  toCBORGroup :: a -> Encoding
  encodedGroupSizeExpr ::
    (forall x. ToCBOR x => Proxy x -> Size) ->
    Proxy a ->
    Size

  listLen :: a -> Word

  -- | an upper bound for 'listLen', used in 'Size' expressions.
  listLenBound :: Proxy a -> Word

listLenInt :: ToCBORGroup a => a -> Int
listLenInt :: a -> Int
listLenInt a
x = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Word
forall a. ToCBORGroup a => a -> Word
listLen a
x)

newtype CBORGroup a = CBORGroup {CBORGroup a -> a
unCBORGroup :: a}

instance ToCBORGroup a => ToCBOR (CBORGroup a) where
  toCBOR :: CBORGroup a -> Encoding
toCBOR (CBORGroup a
x) = Word -> Encoding
encodeListLen (a -> Word
forall a. ToCBORGroup a => a -> Word
listLen a
x) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> a -> Encoding
forall a. ToCBORGroup a => a -> Encoding
toCBORGroup a
x
  encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (CBORGroup a) -> Size
encodedSizeExpr forall t. ToCBOR t => Proxy t -> Size
size Proxy (CBORGroup a)
proxy =
    Integer -> Size
forall a. Num a => Integer -> a
fromInteger (Word -> Integer
forall s a. (Integral s, Integral a) => s -> a
withWordSize (Proxy a -> Word
forall a. ToCBORGroup a => Proxy a -> Word
listLenBound Proxy a
proxy'))
      Size -> Size -> Size
forall a. Num a => a -> a -> a
+ (forall t. ToCBOR t => Proxy t -> Size) -> Proxy a -> Size
forall a.
ToCBORGroup a =>
(forall t. ToCBOR t => Proxy t -> Size) -> Proxy a -> Size
encodedGroupSizeExpr forall t. ToCBOR t => Proxy t -> Size
size Proxy a
proxy'
    where
      proxy' :: Proxy a
proxy' = CBORGroup a -> a
forall a. CBORGroup a -> a
unCBORGroup (CBORGroup a -> a) -> Proxy (CBORGroup a) -> Proxy a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy (CBORGroup a)
proxy

class Typeable a => FromCBORGroup a where
  fromCBORGroup :: Decoder s a

instance (FromCBORGroup a, ToCBORGroup a) => FromCBOR (CBORGroup a) where
  fromCBOR :: Decoder s (CBORGroup a)
fromCBOR = a -> CBORGroup a
forall a. a -> CBORGroup a
CBORGroup (a -> CBORGroup a) -> Decoder s a -> Decoder s (CBORGroup a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s a
forall a s. (ToCBORGroup a, FromCBORGroup a) => Decoder s a
groupRecord

groupRecord :: forall a s. (ToCBORGroup a, FromCBORGroup a) => Decoder s a
groupRecord :: Decoder s a
groupRecord = Text -> (a -> Int) -> Decoder s a -> Decoder s a
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"CBORGroup" (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> (a -> Integer) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Integer
forall a. Integral a => a -> Integer
toInteger (Word -> Integer) -> (a -> Word) -> a -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Word
forall a. ToCBORGroup a => a -> Word
listLen) Decoder s a
forall a s. FromCBORGroup a => Decoder s a
fromCBORGroup

mapToCBOR :: (ToCBOR a, ToCBOR b) => Map a b -> Encoding
mapToCBOR :: Map a b -> Encoding
mapToCBOR = (a -> Encoding) -> (b -> Encoding) -> Map a b -> Encoding
forall a b.
(a -> Encoding) -> (b -> Encoding) -> Map a b -> Encoding
encodeMap a -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR b -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR

mapFromCBOR :: (Ord a, FromCBOR a, FromCBOR b) => Decoder s (Map a b)
mapFromCBOR :: Decoder s (Map a b)
mapFromCBOR = Decoder s a -> Decoder s b -> Decoder s (Map a b)
forall a s b.
Ord a =>
Decoder s a -> Decoder s b -> Decoder s (Map a b)
decodeMap Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s b
forall a s. FromCBOR a => Decoder s a
fromCBOR

newtype CborSeq a = CborSeq {CborSeq a -> Seq a
unwrapCborSeq :: Seq a}
  deriving (a -> CborSeq a -> Bool
CborSeq m -> m
CborSeq a -> [a]
CborSeq a -> Bool
CborSeq a -> Int
CborSeq a -> a
CborSeq a -> a
CborSeq a -> a
CborSeq a -> a
(a -> m) -> CborSeq a -> m
(a -> m) -> CborSeq a -> m
(a -> b -> b) -> b -> CborSeq a -> b
(a -> b -> b) -> b -> CborSeq a -> b
(b -> a -> b) -> b -> CborSeq a -> b
(b -> a -> b) -> b -> CborSeq a -> b
(a -> a -> a) -> CborSeq a -> a
(a -> a -> a) -> CborSeq a -> a
(forall m. Monoid m => CborSeq m -> m)
-> (forall m a. Monoid m => (a -> m) -> CborSeq a -> m)
-> (forall m a. Monoid m => (a -> m) -> CborSeq a -> m)
-> (forall a b. (a -> b -> b) -> b -> CborSeq a -> b)
-> (forall a b. (a -> b -> b) -> b -> CborSeq a -> b)
-> (forall b a. (b -> a -> b) -> b -> CborSeq a -> b)
-> (forall b a. (b -> a -> b) -> b -> CborSeq a -> b)
-> (forall a. (a -> a -> a) -> CborSeq a -> a)
-> (forall a. (a -> a -> a) -> CborSeq a -> a)
-> (forall a. CborSeq a -> [a])
-> (forall a. CborSeq a -> Bool)
-> (forall a. CborSeq a -> Int)
-> (forall a. Eq a => a -> CborSeq a -> Bool)
-> (forall a. Ord a => CborSeq a -> a)
-> (forall a. Ord a => CborSeq a -> a)
-> (forall a. Num a => CborSeq a -> a)
-> (forall a. Num a => CborSeq a -> a)
-> Foldable CborSeq
forall a. Eq a => a -> CborSeq a -> Bool
forall a. Num a => CborSeq a -> a
forall a. Ord a => CborSeq a -> a
forall m. Monoid m => CborSeq m -> m
forall a. CborSeq a -> Bool
forall a. CborSeq a -> Int
forall a. CborSeq a -> [a]
forall a. (a -> a -> a) -> CborSeq a -> a
forall m a. Monoid m => (a -> m) -> CborSeq a -> m
forall b a. (b -> a -> b) -> b -> CborSeq a -> b
forall a b. (a -> b -> b) -> b -> CborSeq a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: CborSeq a -> a
$cproduct :: forall a. Num a => CborSeq a -> a
sum :: CborSeq a -> a
$csum :: forall a. Num a => CborSeq a -> a
minimum :: CborSeq a -> a
$cminimum :: forall a. Ord a => CborSeq a -> a
maximum :: CborSeq a -> a
$cmaximum :: forall a. Ord a => CborSeq a -> a
elem :: a -> CborSeq a -> Bool
$celem :: forall a. Eq a => a -> CborSeq a -> Bool
length :: CborSeq a -> Int
$clength :: forall a. CborSeq a -> Int
null :: CborSeq a -> Bool
$cnull :: forall a. CborSeq a -> Bool
toList :: CborSeq a -> [a]
$ctoList :: forall a. CborSeq a -> [a]
foldl1 :: (a -> a -> a) -> CborSeq a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> CborSeq a -> a
foldr1 :: (a -> a -> a) -> CborSeq a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> CborSeq a -> a
foldl' :: (b -> a -> b) -> b -> CborSeq a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> CborSeq a -> b
foldl :: (b -> a -> b) -> b -> CborSeq a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> CborSeq a -> b
foldr' :: (a -> b -> b) -> b -> CborSeq a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> CborSeq a -> b
foldr :: (a -> b -> b) -> b -> CborSeq a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> CborSeq a -> b
foldMap' :: (a -> m) -> CborSeq a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> CborSeq a -> m
foldMap :: (a -> m) -> CborSeq a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> CborSeq a -> m
fold :: CborSeq m -> m
$cfold :: forall m. Monoid m => CborSeq m -> m
Foldable)

instance ToCBOR a => ToCBOR (CborSeq a) where
  toCBOR :: CborSeq a -> Encoding
toCBOR (CborSeq Seq a
xs) =
    let l :: Word
l = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ Seq a -> Int
forall a. Seq a -> Int
Seq.length Seq a
xs
        contents :: Encoding
contents = (a -> Encoding) -> Seq a -> Encoding
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Seq a
xs
     in Word -> Encoding -> Encoding
wrapCBORArray Word
l Encoding
contents

instance FromCBOR a => FromCBOR (CborSeq a) where
  fromCBOR :: Decoder s (CborSeq a)
fromCBOR = Seq a -> CborSeq a
forall a. Seq a -> CborSeq a
CborSeq (Seq a -> CborSeq a) -> Decoder s (Seq a) -> Decoder s (CborSeq a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s a -> Decoder s (Seq a)
forall s a. Decoder s a -> Decoder s (Seq a)
decodeSeq Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR

encodeFoldableMapEncoder ::
  Foldable f =>
  (Word -> a -> Maybe Encoding) ->
  f a ->
  Encoding
encodeFoldableMapEncoder :: (Word -> a -> Maybe Encoding) -> f a -> Encoding
encodeFoldableMapEncoder Word -> a -> Maybe Encoding
encode f a
xs = Word -> Encoding -> Encoding
wrapCBORMap Word
len Encoding
contents
  where
    (Word
len, Word
_, Encoding
contents) = ((Word, Word, Encoding) -> a -> (Word, Word, Encoding))
-> (Word, Word, Encoding) -> f a -> (Word, Word, Encoding)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Word, Word, Encoding) -> a -> (Word, Word, Encoding)
forall a. Num a => (a, Word, Encoding) -> a -> (a, Word, Encoding)
go (Word
0, Word
0, Encoding
forall a. Monoid a => a
mempty) f a
xs
    go :: (a, Word, Encoding) -> a -> (a, Word, Encoding)
go (!a
l, !Word
i, !Encoding
enc) a
next = case Word -> a -> Maybe Encoding
encode Word
i a
next of
      Maybe Encoding
Nothing -> (a
l, Word
i Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1, Encoding
enc)
      Just Encoding
e -> (a
l a -> a -> a
forall a. Num a => a -> a -> a
+ a
1, Word
i Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1, Encoding
enc Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
e)

decodeMaybe :: Decoder s a -> Decoder s (Maybe a)
decodeMaybe :: Decoder s a -> Decoder s (Maybe a)
decodeMaybe Decoder s a
d =
  Decoder s a -> Decoder s [a]
forall s a. Decoder s a -> Decoder s [a]
decodeList Decoder s a
d Decoder s [a]
-> ([a] -> Decoder s (Maybe a)) -> Decoder s (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [] -> Maybe a -> Decoder s (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    [a
x] -> Maybe a -> Decoder s (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> Decoder s (Maybe a)) -> Maybe a -> Decoder s (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x
    [a]
_ ->
      DecoderError -> Decoder s (Maybe a)
forall e s a. Buildable e => e -> Decoder s a
cborError (DecoderError -> Decoder s (Maybe a))
-> DecoderError -> Decoder s (Maybe a)
forall a b. (a -> b) -> a -> b
$
        Text -> Text -> DecoderError
DecoderErrorCustom
          Text
"Maybe"
          Text
"Expected an array of length 0 or 1"

ratioToCBOR :: ToCBOR a => Ratio a -> Encoding
ratioToCBOR :: Ratio a -> Encoding
ratioToCBOR Ratio a
r =
  Word -> Encoding
encodeTag Word
30
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
encodeListLen Word
2
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> a -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Ratio a -> a
forall a. Ratio a -> a
numerator Ratio a
r)
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> a -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Ratio a -> a
forall a. Ratio a -> a
denominator Ratio a
r)

ratioFromCBOR :: (Bounded a, Integral a, FromCBOR a) => Decoder s (Ratio a)
ratioFromCBOR :: Decoder s (Ratio a)
ratioFromCBOR = Decoder s a -> Decoder s (Ratio a)
forall a s. Integral a => Decoder s a -> Decoder s (Ratio a)
decodeFraction Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR

decodeFraction :: Integral a => Decoder s a -> Decoder s (Ratio a)
decodeFraction :: Decoder s a -> Decoder s (Ratio a)
decodeFraction Decoder s a
decoder = do
  Word
t <- Decoder s Word
forall s. Decoder s Word
decodeTag
  Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word
t Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
30) (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$ DecoderError -> Decoder s ()
forall e s a. Buildable e => e -> Decoder s a
cborError (DecoderError -> Decoder s ()) -> DecoderError -> Decoder s ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> DecoderError
DecoderErrorCustom Text
"rational" Text
"expected tag 30"
  (Int
numValues, [a]
values) <- Decoder s (Maybe Int) -> Decoder s a -> Decoder s (Int, [a])
forall s a.
Decoder s (Maybe Int) -> Decoder s a -> Decoder s (Int, [a])
decodeCollectionWithLen Decoder s (Maybe Int)
forall s. Decoder s (Maybe Int)
decodeListLenOrIndef Decoder s a
decoder
  case [a]
values of
    [a
n, a
d] -> do
      Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
d a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0) (String -> Decoder s ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"denominator cannot be 0")
      Ratio a -> Decoder s (Ratio a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ratio a -> Decoder s (Ratio a)) -> Ratio a -> Decoder s (Ratio a)
forall a b. (a -> b) -> a -> b
$ a
n a -> a -> Ratio a
forall a. Integral a => a -> a -> Ratio a
% a
d
    [a]
_ -> DecoderError -> Decoder s (Ratio a)
forall e s a. Buildable e => e -> Decoder s a
cborError (DecoderError -> Decoder s (Ratio a))
-> DecoderError -> Decoder s (Ratio a)
forall a b. (a -> b) -> a -> b
$ Text -> Int -> Int -> DecoderError
DecoderErrorSizeMismatch Text
"rational" Int
2 Int
numValues

ipv4ToBytes :: IPv4 -> BS.ByteString
ipv4ToBytes :: IPv4 -> ByteString
ipv4ToBytes = ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString)
-> (IPv4 -> ByteString) -> IPv4 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPut (Put -> ByteString) -> (IPv4 -> Put) -> IPv4 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Put
putWord32le (Word32 -> Put) -> (IPv4 -> Word32) -> IPv4 -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPv4 -> Word32
toHostAddress

ipv4FromBytes :: BS.ByteString -> Either String IPv4
ipv4FromBytes :: ByteString -> Either String IPv4
ipv4FromBytes ByteString
b =
  case Get Word32
-> ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, Word32)
forall a.
Get a
-> ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
runGetOrFail Get Word32
getWord32le (ByteString -> ByteString
BSL.fromStrict ByteString
b) of
    Left (ByteString
_, ByteOffset
_, String
err) -> String -> Either String IPv4
forall a b. a -> Either a b
Left String
err
    Right (ByteString
_, ByteOffset
_, Word32
ha) -> IPv4 -> Either String IPv4
forall a b. b -> Either a b
Right (IPv4 -> Either String IPv4) -> IPv4 -> Either String IPv4
forall a b. (a -> b) -> a -> b
$ Word32 -> IPv4
fromHostAddress Word32
ha

ipv4ToCBOR :: IPv4 -> Encoding
ipv4ToCBOR :: IPv4 -> Encoding
ipv4ToCBOR = ByteString -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (ByteString -> Encoding)
-> (IPv4 -> ByteString) -> IPv4 -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPv4 -> ByteString
ipv4ToBytes

byteDecoderToDecoder :: Text -> (BS.ByteString -> Either String a) -> Decoder s a
byteDecoderToDecoder :: Text -> (ByteString -> Either String a) -> Decoder s a
byteDecoderToDecoder Text
name ByteString -> Either String a
fromBytes = do
  ByteString
b <- Decoder s ByteString
forall a s. FromCBOR a => Decoder s a
fromCBOR
  case ByteString -> Either String a
fromBytes ByteString
b of
    Left String
err -> DecoderError -> Decoder s a
forall e s a. Buildable e => e -> Decoder s a
cborError (DecoderError -> Decoder s a) -> DecoderError -> Decoder s a
forall a b. (a -> b) -> a -> b
$ Text -> Text -> DecoderError
DecoderErrorCustom Text
name (String -> Text
Text.pack String
err)
    Right a
ip -> a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
ip

ipv4FromCBOR :: Decoder s IPv4
ipv4FromCBOR :: Decoder s IPv4
ipv4FromCBOR = Text -> (ByteString -> Either String IPv4) -> Decoder s IPv4
forall a s. Text -> (ByteString -> Either String a) -> Decoder s a
byteDecoderToDecoder Text
"IPv4" ByteString -> Either String IPv4
ipv4FromBytes

ipv6ToBytes :: IPv6 -> BS.ByteString
ipv6ToBytes :: IPv6 -> ByteString
ipv6ToBytes IPv6
ipv6 = ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString)
-> (Put -> ByteString) -> Put -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ do
  let (Word32
w1, Word32
w2, Word32
w3, Word32
w4) = IPv6 -> (Word32, Word32, Word32, Word32)
toHostAddress6 IPv6
ipv6
  Word32 -> Put
putWord32le Word32
w1
  Word32 -> Put
putWord32le Word32
w2
  Word32 -> Put
putWord32le Word32
w3
  Word32 -> Put
putWord32le Word32
w4

getHostAddress6 :: Get HostAddress6
getHostAddress6 :: Get (Word32, Word32, Word32, Word32)
getHostAddress6 = do
  Word32
w1 <- Get Word32
getWord32le
  Word32
w2 <- Get Word32
getWord32le
  Word32
w3 <- Get Word32
getWord32le
  Word32
w4 <- Get Word32
getWord32le
  (Word32, Word32, Word32, Word32)
-> Get (Word32, Word32, Word32, Word32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
w1, Word32
w2, Word32
w3, Word32
w4)

ipv6FromBytes :: BS.ByteString -> Either String IPv6
ipv6FromBytes :: ByteString -> Either String IPv6
ipv6FromBytes ByteString
b =
  case Get (Word32, Word32, Word32, Word32)
-> ByteString
-> Either
     (ByteString, ByteOffset, String)
     (ByteString, ByteOffset, (Word32, Word32, Word32, Word32))
forall a.
Get a
-> ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
runGetOrFail Get (Word32, Word32, Word32, Word32)
getHostAddress6 (ByteString -> ByteString
BSL.fromStrict ByteString
b) of
    Left (ByteString
_, ByteOffset
_, String
err) -> String -> Either String IPv6
forall a b. a -> Either a b
Left String
err
    Right (ByteString
_, ByteOffset
_, (Word32, Word32, Word32, Word32)
ha) -> IPv6 -> Either String IPv6
forall a b. b -> Either a b
Right (IPv6 -> Either String IPv6) -> IPv6 -> Either String IPv6
forall a b. (a -> b) -> a -> b
$ (Word32, Word32, Word32, Word32) -> IPv6
fromHostAddress6 (Word32, Word32, Word32, Word32)
ha

ipv6ToCBOR :: IPv6 -> Encoding
ipv6ToCBOR :: IPv6 -> Encoding
ipv6ToCBOR = ByteString -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (ByteString -> Encoding)
-> (IPv6 -> ByteString) -> IPv6 -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPv6 -> ByteString
ipv6ToBytes

ipv6FromCBOR :: Decoder s IPv6
ipv6FromCBOR :: Decoder s IPv6
ipv6FromCBOR = Text -> (ByteString -> Either String IPv6) -> Decoder s IPv6
forall a s. Text -> (ByteString -> Either String a) -> Decoder s a
byteDecoderToDecoder Text
"IPv6" ByteString -> Either String IPv6
ipv6FromBytes

--
-- Raw serialisation
--

-- | Run a ByteString 'BS.Builder' using a strategy aimed at making smaller
-- things efficiently.
--
-- It takes a size hint and produces a strict 'ByteString'. This will be fast
-- when the size hint is the same or slightly bigger than the true size.
runByteBuilder :: Int -> BS.Builder -> BS.ByteString
runByteBuilder :: Int -> Builder -> ByteString
runByteBuilder !Int
sizeHint =
  ByteString -> ByteString
BSL.toStrict
    (ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AllocationStrategy -> ByteString -> Builder -> ByteString
BS.toLazyByteStringWith
      (Int -> Int -> AllocationStrategy
BS.safeStrategy Int
sizeHint (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sizeHint))
      ByteString
forall a. Monoid a => a
mempty
{-# NOINLINE runByteBuilder #-}

utcTimeToCBOR :: UTCTime -> Encoding
utcTimeToCBOR :: UTCTime -> Encoding
utcTimeToCBOR UTCTime
t =
  Word -> Encoding
encodeListLen Word
3
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Integer -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Integer
year
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Int -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Int
dayOfYear
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> (Integer -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Integer -> Encoding)
-> (UTCTime -> Integer) -> UTCTime -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> Integer
diffTimeToPicoseconds (DiffTime -> Integer)
-> (UTCTime -> DiffTime) -> UTCTime -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> DiffTime
utctDayTime) UTCTime
t
  where
    (Integer
year, Int
dayOfYear) = Day -> (Integer, Int)
toOrdinalDate (Day -> (Integer, Int))
-> (UTCTime -> Day) -> UTCTime -> (Integer, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Day
utctDay (UTCTime -> (Integer, Int)) -> UTCTime -> (Integer, Int)
forall a b. (a -> b) -> a -> b
$ UTCTime
t

utcTimeFromCBOR :: Decoder s UTCTime
utcTimeFromCBOR :: Decoder s UTCTime
utcTimeFromCBOR = do
  Text -> (UTCTime -> Int) -> Decoder s UTCTime -> Decoder s UTCTime
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"UTCTime" (Int -> UTCTime -> Int
forall a b. a -> b -> a
const Int
3) (Decoder s UTCTime -> Decoder s UTCTime)
-> Decoder s UTCTime -> Decoder s UTCTime
forall a b. (a -> b) -> a -> b
$ do
    Integer
year <- Decoder s Integer
forall a s. FromCBOR a => Decoder s a
fromCBOR
    Int
dayOfYear <- Decoder s Int
forall a s. FromCBOR a => Decoder s a
fromCBOR
    Integer
diff <- Decoder s Integer
forall a s. FromCBOR a => Decoder s a
fromCBOR
    UTCTime -> Decoder s UTCTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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
diff)

translateViaCBORAnn :: (ToCBOR a, FromCBOR (Annotator b)) => Text -> a -> Except DecoderError b
translateViaCBORAnn :: Text -> a -> Except DecoderError b
translateViaCBORAnn Text
name a
x =
  case Text
-> (forall s. Decoder s (Annotator b))
-> ByteString
-> Either DecoderError b
forall a.
Text
-> (forall s. Decoder s (Annotator a))
-> ByteString
-> Either DecoderError a
decodeAnnotator Text
name forall s. Decoder s (Annotator b)
forall a s. FromCBOR a => Decoder s a
fromCBOR (a -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize a
x) of
    Right b
newx -> b -> Except DecoderError b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
newx
    Left DecoderError
decoderError -> DecoderError -> Except DecoderError b
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DecoderError
decoderError

-- | A CBOR deserialized value together with its size. When deserializing use
-- either `sizedDecoder` or its `FromCBOR` instance.
--
-- Use `mkSized` to construct such value.
data Sized a = Sized
  { Sized a -> a
sizedValue :: !a,
    -- | Overhead in bytes. The field is lazy on purpose, because it might not
    -- be needed, but it can be expensive to compute.
    Sized a -> ByteOffset
sizedSize :: Int64
  }
  deriving (Sized a -> Sized a -> Bool
(Sized a -> Sized a -> Bool)
-> (Sized a -> Sized a -> Bool) -> Eq (Sized a)
forall a. Eq a => Sized a -> Sized a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Sized a -> Sized a -> Bool
$c/= :: forall a. Eq a => Sized a -> Sized a -> Bool
== :: Sized a -> Sized a -> Bool
$c== :: forall a. Eq a => Sized a -> Sized a -> Bool
Eq, Int -> Sized a -> ShowS
[Sized a] -> ShowS
Sized a -> String
(Int -> Sized a -> ShowS)
-> (Sized a -> String) -> ([Sized a] -> ShowS) -> Show (Sized a)
forall a. Show a => Int -> Sized a -> ShowS
forall a. Show a => [Sized a] -> ShowS
forall a. Show a => Sized a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Sized a] -> ShowS
$cshowList :: forall a. Show a => [Sized a] -> ShowS
show :: Sized a -> String
$cshow :: forall a. Show a => Sized a -> String
showsPrec :: Int -> Sized a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Sized a -> ShowS
Show, (forall x. Sized a -> Rep (Sized a) x)
-> (forall x. Rep (Sized a) x -> Sized a) -> Generic (Sized a)
forall x. Rep (Sized a) x -> Sized a
forall x. Sized a -> Rep (Sized a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Sized a) x -> Sized a
forall a x. Sized a -> Rep (Sized a) x
$cto :: forall a x. Rep (Sized a) x -> Sized a
$cfrom :: forall a x. Sized a -> Rep (Sized a) x
Generic)

instance NoThunks a => NoThunks (Sized a)

-- | Construct a `Sized` value by serializing it first and recording the amount
-- of bytes it requires. Note, however, CBOR serialization is not canonical,
-- therefore it is *NOT* a requirement that this property holds:
--
-- > sizedSize (mkSized a) === sizedSize (unsafeDeserialize (serialize a) :: a)
mkSized :: ToCBOR a => a -> Sized a
mkSized :: a -> Sized a
mkSized a
a =
  Sized :: forall a. a -> ByteOffset -> Sized a
Sized
    { sizedValue :: a
sizedValue = a
a,
      sizedSize :: ByteOffset
sizedSize = ByteString -> ByteOffset
BSL.length (a -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize a
a)
    }

sizedDecoder :: Decoder s a -> Decoder s (Sized a)
sizedDecoder :: Decoder s a -> Decoder s (Sized a)
sizedDecoder Decoder s a
decoder = do
  Annotated a
v (ByteSpan ByteOffset
start ByteOffset
end) <- Decoder s a -> Decoder s (Annotated a ByteSpan)
forall s a. Decoder s a -> Decoder s (Annotated a ByteSpan)
annotatedDecoder Decoder s a
decoder
  Sized a -> Decoder s (Sized a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sized a -> Decoder s (Sized a)) -> Sized a -> Decoder s (Sized a)
forall a b. (a -> b) -> a -> b
$ a -> ByteOffset -> Sized a
forall a. a -> ByteOffset -> Sized a
Sized a
v (ByteOffset -> Sized a) -> ByteOffset -> Sized a
forall a b. (a -> b) -> a -> b
$! ByteOffset
end ByteOffset -> ByteOffset -> ByteOffset
forall a. Num a => a -> a -> a
- ByteOffset
start

instance FromCBOR a => FromCBOR (Sized a) where
  fromCBOR :: Decoder s (Sized a)
fromCBOR = Decoder s a -> Decoder s (Sized a)
forall s a. Decoder s a -> Decoder s (Sized a)
sizedDecoder Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR

-- | Discards the size.
instance ToCBOR a => ToCBOR (Sized a) where
  -- Size is an auxiliary value and should not be transmitted over the wire,
  -- therefore it is ignored.
  toCBOR :: Sized a -> Encoding
toCBOR (Sized a
v ByteOffset
_) = a -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR a
v