{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Shelley.Spec.Ledger.Serialization
  ( ToCBORGroup (..),
    FromCBORGroup (..),
    CBORGroup (..),
    CborSeq (..),
    decodeList,
    decodeSeq,
    decodeStrictSeq,
    decodeSet,
    decodeMap,
    decodeMapContents,
    decodeMapTraverse,
    decodeMaybe,
    decodeRecordNamed,
    decodeRecordSum,
    decodeNullMaybe,
    encodeFoldable,
    encodeFoldableEncoder,
    encodeFoldableMapEncoder,
    encodeNullMaybe,
    groupRecord,
    ratioToCBOR,
    ratioFromCBOR,
    mapToCBOR,
    mapFromCBOR,
    -- IPv4
    ipv4ToBytes,
    ipv4FromBytes,
    ipv4ToCBOR,
    ipv4FromCBOR,
    -- IPv6
    ipv6ToBytes,
    ipv6FromBytes,
    ipv6ToCBOR,
    ipv6FromCBOR,
    -- Raw
    listLenInt,
    runByteBuilder,
    -- UTC Time
    utcTimeToCBOR,
    utcTimeFromCBOR,
  )
where

import Cardano.Binary
  ( Decoder,
    DecoderError (..),
    Encoding,
    FromCBOR (..),
    Size,
    ToCBOR (..),
    decodeListLenOrIndef,
    decodeMapLenOrIndef,
    decodeTag,
    encodeBreak,
    encodeListLen,
    encodeMapLen,
    encodeMapLenIndef,
    encodeTag,
    withWordSize,
  )
import Cardano.Prelude (cborError)
import Control.Monad (unless)
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
  ( decodeCollection,
    decodeCollectionWithLen,
    decodeList,
    decodeNullMaybe,
    decodeRecordNamed,
    decodeRecordSum,
    decodeSeq,
    decodeSet,
    decodeStrictSeq,
    encodeFoldable,
    encodeFoldableEncoder,
    encodeNullMaybe,
    wrapCBORArray,
  )
import Data.Foldable (foldl')
import Data.Functor.Compose (Compose (..))
import Data.IP
  ( IPv4,
    IPv6,
    fromHostAddress,
    fromHostAddress6,
    toHostAddress,
    toHostAddress6,
  )
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as 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 Network.Socket (HostAddress6)
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 Map a b
m =
  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
$ Map a b -> Int
forall k a. Map k a -> Int
Map.size Map a b
m
      contents :: Encoding
contents = (a -> b -> Encoding) -> Map a b -> Encoding
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey (\a
k b
v -> a -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR a
k Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> b -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR b
v) Map a b
m
   in Word -> Encoding -> Encoding
wrapCBORMap Word
l Encoding
contents

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

decodeMap :: Ord a => Decoder s a -> Decoder s b -> Decoder s (Map a b)
decodeMap :: Decoder s a -> Decoder s b -> Decoder s (Map a b)
decodeMap Decoder s a
decodeKey Decoder s b
decodeValue =
  [(a, b)] -> Map a b
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    ([(a, b)] -> Map a b) -> Decoder s [(a, b)] -> Decoder s (Map a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (a, b) -> Decoder s [(a, b)]
forall s a. Decoder s a -> Decoder s [a]
decodeMapContents Decoder s (a, b)
decodePair
  where
    decodePair :: Decoder s (a, b)
decodePair = (,) (a -> b -> (a, b)) -> Decoder s a -> Decoder s (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s a
decodeKey Decoder s (b -> (a, b)) -> Decoder s b -> Decoder s (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s b
decodeValue

decodeMapTraverse ::
  (Ord a, Applicative t) =>
  Decoder s (t a) ->
  Decoder s (t b) ->
  Decoder s (t (Map a b))
decodeMapTraverse :: Decoder s (t a) -> Decoder s (t b) -> Decoder s (t (Map a b))
decodeMapTraverse Decoder s (t a)
decodeKey Decoder s (t b)
decodeValue =
  ([(a, b)] -> Map a b) -> t [(a, b)] -> t (Map a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(a, b)] -> Map a b
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (t [(a, b)] -> t (Map a b))
-> ([t (a, b)] -> t [(a, b)]) -> [t (a, b)] -> t (Map a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [t (a, b)] -> t [(a, b)]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
    ([t (a, b)] -> t (Map a b))
-> Decoder s [t (a, b)] -> Decoder s (t (Map a b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (t (a, b)) -> Decoder s [t (a, b)]
forall s a. Decoder s a -> Decoder s [a]
decodeMapContents Decoder s (t (a, b))
decodePair
  where
    decodePair :: Decoder s (t (a, b))
decodePair = Compose (Decoder s) t (a, b) -> Decoder s (t (a, b))
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose (Decoder s) t (a, b) -> Decoder s (t (a, b)))
-> Compose (Decoder s) t (a, b) -> Decoder s (t (a, b))
forall a b. (a -> b) -> a -> b
$ (,) (a -> b -> (a, b))
-> Compose (Decoder s) t a -> Compose (Decoder s) t (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (t a) -> Compose (Decoder s) t a
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose Decoder s (t a)
decodeKey Compose (Decoder s) t (b -> (a, b))
-> Compose (Decoder s) t b -> Compose (Decoder s) t (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (t b) -> Compose (Decoder s) t b
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose Decoder s (t b)
decodeValue

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)

wrapCBORMap :: Word -> Encoding -> Encoding
wrapCBORMap :: Word -> Encoding -> Encoding
wrapCBORMap Word
len Encoding
contents =
  if Word
len Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
23
    then Word -> Encoding
encodeMapLen Word
len Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
contents
    else Encoding
encodeMapLenIndef Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
contents Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
encodeBreak

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"

decodeMapContents :: Decoder s a -> Decoder s [a]
decodeMapContents :: Decoder s a -> Decoder s [a]
decodeMapContents = 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)
decodeMapLenOrIndef

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 :: (Integral a, FromCBOR a) => Decoder s (Ratio a)
ratioFromCBOR :: Decoder s (Ratio a)
ratioFromCBOR = 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
forall a s. FromCBOR a => Decoder s a
fromCBOR
  case [a]
values of
    a
n : a
d : [] -> 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 -> Either String IPv4) -> String -> Either String IPv4
forall a b. (a -> b) -> a -> b
$ 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, Word32, Word32, Word32)
 -> Get (Word32, Word32, Word32, Word32))
-> (Word32, Word32, Word32, Word32)
-> Get (Word32, Word32, Word32, Word32)
forall a b. (a -> b) -> a -> b
$ (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 -> Either String IPv6) -> String -> Either String IPv6
forall a b. (a -> b) -> a -> b
$ 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)