{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}

module Cardano.Ledger.Binary.Encoding.Encoder (
  -- * Decoders
  Encoding,
  toBuilder,
  C.Tokens (..),
  toPlainEncoding,
  fromPlainEncoding,
  fromPlainEncodingWithVersion,
  withCurrentEncodingVersion,
  enforceEncodingVersion,
  ifEncodingVersionAtLeast,

  -- ** Custom
  encodeVersion,
  encodeMaybe,
  encodeNullMaybe,
  encodeStrictMaybe,
  encodeNullStrictMaybe,
  encodeTuple,
  encodeRatio,
  encodeRatioNoTag,
  encodeRatioWithTag,
  encodeEnum,
  encodeWithOrigin,

  -- *** Containers
  encodeList,
  encodeSeq,
  encodeStrictSeq,
  encodeSet,
  encodeMap,
  encodeVMap,
  encodeVector,
  variableListLenEncoding,

  -- **** Helpers
  encodeFoldableEncoder,
  encodeFoldableAsDefLenList,
  encodeFoldableAsIndefLenList,
  encodeFoldableMapEncoder,
  lengthThreshold,

  -- *** Time
  encodeUTCTime,

  -- *** Network
  encodeIPv4,
  ipv4ToBytes,
  encodeIPv6,
  ipv6ToBytes,

  -- ** Original
  encodeWord,
  encodeWord8,
  encodeWord16,
  encodeWord32,
  encodeWord64,
  encodeInt,
  encodeInt8,
  encodeInt16,
  encodeInt32,
  encodeInt64,
  encodeInteger,
  encodeBytes,
  encodeBytesIndef,
  encodeByteArray,
  encodeString,
  encodeStringIndef,
  encodeUtf8ByteArray,
  encodeListLen,
  encodeListLenIndef,
  encodeMapLen,
  encodeMapLenIndef,
  encodeBreak,
  encodeTag,
  encodeTag64,
  encodeBool,
  encodeUndef,
  encodeNull,
  encodeSimple,
  encodeFloat16,
  encodeFloat,
  encodeDouble,
  encodePreEncoded,
  encodeTerm,
)
where

import qualified Cardano.Binary as C
import Cardano.Ledger.Binary.Decoding.Decoder (setTag)
import Cardano.Ledger.Binary.Version (Version, getVersion64, natVersion)
import Cardano.Slotting.Slot (WithOrigin, withOriginToMaybe)
import Codec.CBOR.ByteArray.Sliced (SlicedByteArray)
import qualified Codec.CBOR.Term as C (Term (..), encodeTerm)
import qualified Codec.CBOR.Write as CBOR (toBuilder)
import Data.Binary.Put (putWord32le, runPut)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Lazy as BSL
import Data.Foldable as F (foldMap', foldl')
import Data.IP (IPv4, IPv6, toHostAddress, toHostAddress6)
import Data.Int (Int16, Int32, Int64, Int8)
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (StrictMaybe (..))
import Data.Monoid (Sum (..))
import Data.Ratio (Ratio, denominator, numerator)
import qualified Data.Sequence as Seq
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Data.Text (Text)
import Data.Time.Calendar.OrdinalDate (toOrdinalDate)
import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds)
import qualified Data.VMap as VMap
import qualified Data.Vector.Generic as VG
import Data.Word (Word16, Word32, Word64, Word8)
import Prelude hiding (encodeFloat)

--------------------------------------------------------------------------------
-- Versioned Encoder
--------------------------------------------------------------------------------

newtype Encoding = Encoding (Version -> C.Encoding)
  deriving (NonEmpty Encoding -> Encoding
Encoding -> Encoding -> Encoding
forall b. Integral b => b -> Encoding -> Encoding
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Encoding -> Encoding
$cstimes :: forall b. Integral b => b -> Encoding -> Encoding
sconcat :: NonEmpty Encoding -> Encoding
$csconcat :: NonEmpty Encoding -> Encoding
<> :: Encoding -> Encoding -> Encoding
$c<> :: Encoding -> Encoding -> Encoding
Semigroup, Semigroup Encoding
Encoding
[Encoding] -> Encoding
Encoding -> Encoding -> Encoding
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Encoding] -> Encoding
$cmconcat :: [Encoding] -> Encoding
mappend :: Encoding -> Encoding -> Encoding
$cmappend :: Encoding -> Encoding -> Encoding
mempty :: Encoding
$cmempty :: Encoding
Monoid)

fromPlainEncoding :: C.Encoding -> Encoding
fromPlainEncoding :: Encoding -> Encoding
fromPlainEncoding Encoding
enc = (Version -> Encoding) -> Encoding
Encoding (forall a b. a -> b -> a
const Encoding
enc)

fromPlainEncodingWithVersion :: (Version -> C.Encoding) -> Encoding
fromPlainEncodingWithVersion :: (Version -> Encoding) -> Encoding
fromPlainEncodingWithVersion = (Version -> Encoding) -> Encoding
Encoding

toPlainEncoding :: Version -> Encoding -> C.Encoding
toPlainEncoding :: Version -> Encoding -> Encoding
toPlainEncoding Version
v (Encoding Version -> Encoding
enc) = Version -> Encoding
enc Version
v

toBuilder :: Version -> Encoding -> Builder
toBuilder :: Version -> Encoding -> Builder
toBuilder Version
version (Encoding Version -> Encoding
enc) = Encoding -> Builder
CBOR.toBuilder forall a b. (a -> b) -> a -> b
$ Version -> Encoding
enc Version
version

-- | Get access to the current version being used in the encoder
withCurrentEncodingVersion :: (Version -> Encoding) -> Encoding
withCurrentEncodingVersion :: (Version -> Encoding) -> Encoding
withCurrentEncodingVersion Version -> Encoding
f =
  (Version -> Encoding) -> Encoding
Encoding forall a b. (a -> b) -> a -> b
$ \Version
version -> Version -> Encoding -> Encoding
toPlainEncoding Version
version forall a b. (a -> b) -> a -> b
$ Version -> Encoding
f Version
version

-- | Ignore the current version of the encoder and enforce the supplied one instead.
enforceEncodingVersion :: Version -> Encoding -> Encoding
enforceEncodingVersion :: Version -> Encoding -> Encoding
enforceEncodingVersion Version
version Encoding
encoding = Encoding -> Encoding
fromPlainEncoding (Version -> Encoding -> Encoding
toPlainEncoding Version
version Encoding
encoding)

-- | Conditionoly choose the encoder newer or older deceder, depending on the current
-- version. Supplied version acts as a pivot.
--
-- =====__Example__
ifEncodingVersionAtLeast ::
  Version ->
  -- | Use this encoder if current encoder version is larger or equal to the supplied
  -- `Version`
  Encoding ->
  -- | Use this encoder if current encoder version is lower than the supplied `Version`
  Encoding ->
  Encoding
ifEncodingVersionAtLeast :: Version -> Encoding -> Encoding -> Encoding
ifEncodingVersionAtLeast Version
atLeast (Encoding Version -> Encoding
newerEncoding) (Encoding Version -> Encoding
olderEncoding) =
  (Version -> Encoding) -> Encoding
Encoding forall a b. (a -> b) -> a -> b
$ \Version
cur ->
    if Version
cur forall a. Ord a => a -> a -> Bool
>= Version
atLeast
      then Version -> Encoding
newerEncoding Version
cur
      else Version -> Encoding
olderEncoding Version
cur

--------------------------------------------------------------------------------
-- Wrapped CBORG encoders
--------------------------------------------------------------------------------

encodeWord :: Word -> Encoding
encodeWord :: Word -> Encoding
encodeWord Word
e = Encoding -> Encoding
fromPlainEncoding (Word -> Encoding
C.encodeWord Word
e)

encodeWord8 :: Word8 -> Encoding
encodeWord8 :: Word8 -> Encoding
encodeWord8 Word8
e = Encoding -> Encoding
fromPlainEncoding (Word8 -> Encoding
C.encodeWord8 Word8
e)

encodeWord16 :: Word16 -> Encoding
encodeWord16 :: Word16 -> Encoding
encodeWord16 Word16
e = Encoding -> Encoding
fromPlainEncoding (Word16 -> Encoding
C.encodeWord16 Word16
e)

encodeWord32 :: Word32 -> Encoding
encodeWord32 :: Word32 -> Encoding
encodeWord32 Word32
e = Encoding -> Encoding
fromPlainEncoding (Word32 -> Encoding
C.encodeWord32 Word32
e)

encodeWord64 :: Word64 -> Encoding
encodeWord64 :: Word64 -> Encoding
encodeWord64 Word64
e = Encoding -> Encoding
fromPlainEncoding (Word64 -> Encoding
C.encodeWord64 Word64
e)

encodeInt :: Int -> Encoding
encodeInt :: Int -> Encoding
encodeInt Int
e = Encoding -> Encoding
fromPlainEncoding (Int -> Encoding
C.encodeInt Int
e)

encodeInt8 :: Int8 -> Encoding
encodeInt8 :: Int8 -> Encoding
encodeInt8 Int8
e = Encoding -> Encoding
fromPlainEncoding (Int8 -> Encoding
C.encodeInt8 Int8
e)

encodeInt16 :: Int16 -> Encoding
encodeInt16 :: Int16 -> Encoding
encodeInt16 Int16
e = Encoding -> Encoding
fromPlainEncoding (Int16 -> Encoding
C.encodeInt16 Int16
e)

encodeInt32 :: Int32 -> Encoding
encodeInt32 :: Int32 -> Encoding
encodeInt32 Int32
e = Encoding -> Encoding
fromPlainEncoding (Int32 -> Encoding
C.encodeInt32 Int32
e)

encodeInt64 :: Int64 -> Encoding
encodeInt64 :: Int64 -> Encoding
encodeInt64 Int64
e = Encoding -> Encoding
fromPlainEncoding (Int64 -> Encoding
C.encodeInt64 Int64
e)

encodeInteger :: Integer -> Encoding
encodeInteger :: Integer -> Encoding
encodeInteger Integer
e = Encoding -> Encoding
fromPlainEncoding (Integer -> Encoding
C.encodeInteger Integer
e)

encodeBytes :: ByteString -> Encoding
encodeBytes :: ByteString -> Encoding
encodeBytes ByteString
e = Encoding -> Encoding
fromPlainEncoding (ByteString -> Encoding
C.encodeBytes ByteString
e)

encodeBytesIndef :: Encoding
encodeBytesIndef :: Encoding
encodeBytesIndef = Encoding -> Encoding
fromPlainEncoding Encoding
C.encodeBytesIndef

encodeByteArray :: SlicedByteArray -> Encoding
encodeByteArray :: SlicedByteArray -> Encoding
encodeByteArray SlicedByteArray
e = Encoding -> Encoding
fromPlainEncoding (SlicedByteArray -> Encoding
C.encodeByteArray SlicedByteArray
e)

encodeString :: Text -> Encoding
encodeString :: Text -> Encoding
encodeString Text
e = Encoding -> Encoding
fromPlainEncoding (Text -> Encoding
C.encodeString Text
e)

encodeStringIndef :: Encoding
encodeStringIndef :: Encoding
encodeStringIndef = Encoding -> Encoding
fromPlainEncoding Encoding
C.encodeStringIndef

encodeUtf8ByteArray :: SlicedByteArray -> Encoding
encodeUtf8ByteArray :: SlicedByteArray -> Encoding
encodeUtf8ByteArray SlicedByteArray
e = Encoding -> Encoding
fromPlainEncoding (SlicedByteArray -> Encoding
C.encodeUtf8ByteArray SlicedByteArray
e)

encodeListLen :: Word -> Encoding
encodeListLen :: Word -> Encoding
encodeListLen Word
e = Encoding -> Encoding
fromPlainEncoding (Word -> Encoding
C.encodeListLen Word
e)

encodeListLenIndef :: Encoding
encodeListLenIndef :: Encoding
encodeListLenIndef = Encoding -> Encoding
fromPlainEncoding Encoding
C.encodeListLenIndef

encodeMapLen :: Word -> Encoding
encodeMapLen :: Word -> Encoding
encodeMapLen Word
e = Encoding -> Encoding
fromPlainEncoding (Word -> Encoding
C.encodeMapLen Word
e)

encodeMapLenIndef :: Encoding
encodeMapLenIndef :: Encoding
encodeMapLenIndef = Encoding -> Encoding
fromPlainEncoding Encoding
C.encodeMapLenIndef

encodeBreak :: Encoding
encodeBreak :: Encoding
encodeBreak = Encoding -> Encoding
fromPlainEncoding Encoding
C.encodeBreak

encodeTag :: Word -> Encoding
encodeTag :: Word -> Encoding
encodeTag Word
e = Encoding -> Encoding
fromPlainEncoding (Word -> Encoding
C.encodeTag Word
e)

encodeTag64 :: Word64 -> Encoding
encodeTag64 :: Word64 -> Encoding
encodeTag64 Word64
e = Encoding -> Encoding
fromPlainEncoding (Word64 -> Encoding
C.encodeTag64 Word64
e)

encodeBool :: Bool -> Encoding
encodeBool :: Bool -> Encoding
encodeBool Bool
e = Encoding -> Encoding
fromPlainEncoding (Bool -> Encoding
C.encodeBool Bool
e)

encodeUndef :: Encoding
encodeUndef :: Encoding
encodeUndef = Encoding -> Encoding
fromPlainEncoding Encoding
C.encodeUndef

encodeNull :: Encoding
encodeNull :: Encoding
encodeNull = Encoding -> Encoding
fromPlainEncoding Encoding
C.encodeNull

encodeSimple :: Word8 -> Encoding
encodeSimple :: Word8 -> Encoding
encodeSimple Word8
e = Encoding -> Encoding
fromPlainEncoding (Word8 -> Encoding
C.encodeSimple Word8
e)

encodeFloat16 :: Float -> Encoding
encodeFloat16 :: Float -> Encoding
encodeFloat16 Float
e = Encoding -> Encoding
fromPlainEncoding (Float -> Encoding
C.encodeFloat16 Float
e)

encodeFloat :: Float -> Encoding
encodeFloat :: Float -> Encoding
encodeFloat Float
e = Encoding -> Encoding
fromPlainEncoding (Float -> Encoding
C.encodeFloat Float
e)

encodeDouble :: Double -> Encoding
encodeDouble :: Double -> Encoding
encodeDouble Double
e = Encoding -> Encoding
fromPlainEncoding (Double -> Encoding
C.encodeDouble Double
e)

encodePreEncoded :: ByteString -> Encoding
encodePreEncoded :: ByteString -> Encoding
encodePreEncoded ByteString
e = Encoding -> Encoding
fromPlainEncoding (ByteString -> Encoding
C.encodePreEncoded ByteString
e)

encodeTerm :: C.Term -> Encoding
encodeTerm :: Term -> Encoding
encodeTerm = Encoding -> Encoding
fromPlainEncoding forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Encoding
C.encodeTerm

--------------------------------------------------------------------------------
-- Custom
--------------------------------------------------------------------------------

encodeVersion :: Version -> Encoding
encodeVersion :: Version -> Encoding
encodeVersion = Word64 -> Encoding
encodeWord64 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> Word64
getVersion64

encodeRatioNoTag :: (t -> Encoding) -> Ratio t -> Encoding
encodeRatioNoTag :: forall t. (t -> Encoding) -> Ratio t -> Encoding
encodeRatioNoTag t -> Encoding
encodeNumeric Ratio t
r =
  Word -> Encoding
encodeListLen Word
2
    forall a. Semigroup a => a -> a -> a
<> t -> Encoding
encodeNumeric (forall a. Ratio a -> a
numerator Ratio t
r)
    forall a. Semigroup a => a -> a -> a
<> t -> Encoding
encodeNumeric (forall a. Ratio a -> a
denominator Ratio t
r)

-- | Encode a rational number with tag 30, as per tag assignment:
-- <https://www.iana.org/assignments/cbor-tags/cbor-tags.xhtml>
--
-- <https://peteroupc.github.io/CBOR/rational.html>
encodeRatioWithTag :: (t -> Encoding) -> Ratio t -> Encoding
encodeRatioWithTag :: forall t. (t -> Encoding) -> Ratio t -> Encoding
encodeRatioWithTag t -> Encoding
encodeNumeric Ratio t
r =
  Word -> Encoding
encodeTag Word
30 forall a. Semigroup a => a -> a -> a
<> forall t. (t -> Encoding) -> Ratio t -> Encoding
encodeRatioNoTag t -> Encoding
encodeNumeric Ratio t
r

encodeRatio :: (t -> Encoding) -> Ratio t -> Encoding
encodeRatio :: forall t. (t -> Encoding) -> Ratio t -> Encoding
encodeRatio t -> Encoding
encodeNumeric Ratio t
r =
  Version -> Encoding -> Encoding -> Encoding
ifEncodingVersionAtLeast
    (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9)
    (forall t. (t -> Encoding) -> Ratio t -> Encoding
encodeRatioWithTag t -> Encoding
encodeNumeric Ratio t
r)
    (forall t. (t -> Encoding) -> Ratio t -> Encoding
encodeRatioNoTag t -> Encoding
encodeNumeric Ratio t
r)

encodeEnum :: Enum a => a -> Encoding
encodeEnum :: forall a. Enum a => a -> Encoding
encodeEnum = Int -> Encoding
encodeInt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum

encodeWithOrigin :: (a -> Encoding) -> WithOrigin a -> Encoding
encodeWithOrigin :: forall a. (a -> Encoding) -> WithOrigin a -> Encoding
encodeWithOrigin a -> Encoding
f = forall a. (a -> Encoding) -> Maybe a -> Encoding
encodeMaybe a -> Encoding
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. WithOrigin t -> Maybe t
withOriginToMaybe

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

encodeMaybe :: (a -> Encoding) -> Maybe a -> Encoding
encodeMaybe :: forall a. (a -> Encoding) -> Maybe a -> Encoding
encodeMaybe a -> Encoding
encodeValue = \case
  Maybe a
Nothing -> Word -> Encoding
encodeListLen Word
0
  Just a
x -> Word -> Encoding
encodeListLen Word
1 forall a. Semigroup a => a -> a -> a
<> a -> Encoding
encodeValue a
x

-- | Alternative way to encode a Maybe type.
--
-- /Note/ - this is not the default method for encoding `Maybe`, use `encodeMaybe` instead
encodeNullMaybe :: (a -> Encoding) -> Maybe a -> Encoding
encodeNullMaybe :: forall a. (a -> Encoding) -> Maybe a -> Encoding
encodeNullMaybe a -> Encoding
encodeValue = \case
  Maybe a
Nothing -> Encoding
encodeNull
  Just a
x -> a -> Encoding
encodeValue a
x

encodeStrictMaybe :: (a -> Encoding) -> StrictMaybe a -> Encoding
encodeStrictMaybe :: forall a. (a -> Encoding) -> StrictMaybe a -> Encoding
encodeStrictMaybe a -> Encoding
encodeValue = \case
  StrictMaybe a
SNothing -> Word -> Encoding
encodeListLen Word
0
  SJust a
x -> Word -> Encoding
encodeListLen Word
1 forall a. Semigroup a => a -> a -> a
<> a -> Encoding
encodeValue a
x

-- | Alternative way to encode a Maybe type.
--
-- /Note/ - this is not the default method for encoding `StrictMaybe`, use
-- `encodeStrictMaybe` instead
encodeNullStrictMaybe :: (a -> Encoding) -> StrictMaybe a -> Encoding
encodeNullStrictMaybe :: forall a. (a -> Encoding) -> StrictMaybe a -> Encoding
encodeNullStrictMaybe a -> Encoding
encodeValue = \case
  StrictMaybe a
SNothing -> Encoding
encodeNull
  SJust a
x -> a -> Encoding
encodeValue a
x

encodeTuple :: (a -> Encoding) -> (b -> Encoding) -> (a, b) -> Encoding
encodeTuple :: forall a b.
(a -> Encoding) -> (b -> Encoding) -> (a, b) -> Encoding
encodeTuple a -> Encoding
encodeFirst b -> Encoding
encodeSecond (a
x, b
y) =
  Word -> Encoding
encodeListLen Word
2
    forall a. Semigroup a => a -> a -> a
<> a -> Encoding
encodeFirst a
x
    forall a. Semigroup a => a -> a -> a
<> b -> Encoding
encodeSecond b
y

-- | Encode any Foldable with indefinite list length encoding
encodeFoldableAsIndefLenList :: Foldable f => (a -> Encoding) -> f a -> Encoding
encodeFoldableAsIndefLenList :: forall (f :: * -> *) a.
Foldable f =>
(a -> Encoding) -> f a -> Encoding
encodeFoldableAsIndefLenList a -> Encoding
encodeValue f a
xs =
  Encoding
encodeListLenIndef forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
x Encoding
r -> a -> Encoding
encodeValue a
x forall a. Semigroup a => a -> a -> a
<> Encoding
r) Encoding
encodeBreak f a
xs

encodeFoldableAsDefLenList :: Foldable f => (a -> Encoding) -> f a -> Encoding
encodeFoldableAsDefLenList :: forall (f :: * -> *) a.
Foldable f =>
(a -> Encoding) -> f a -> Encoding
encodeFoldableAsDefLenList a -> Encoding
encodeValue f a
xs =
  case forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' (\a
v -> (Sum Word
1, a -> Encoding
encodeValue a
v)) f a
xs of
    (Sum Word
len, Encoding
exactLenEncList) -> Word -> Encoding
encodeListLen Word
len forall a. Semigroup a => a -> a -> a
<> Encoding
exactLenEncList

-- | Encode any Foldable with the variable list length encoding, which will use indefinite
-- encoding over 23 elements and definite otherwise.
encodeFoldableEncoder :: Foldable f => (a -> Encoding) -> f a -> Encoding
encodeFoldableEncoder :: forall (f :: * -> *) a.
Foldable f =>
(a -> Encoding) -> f a -> Encoding
encodeFoldableEncoder a -> Encoding
encoder f a
xs = Int -> Encoding -> Encoding
variableListLenEncoding Int
len Encoding
contents
  where
    (Int
len, Encoding
contents) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a}. Num a => (a, Encoding) -> a -> (a, Encoding)
go (Int
0, forall a. Monoid a => a
mempty) f a
xs
    go :: (a, Encoding) -> a -> (a, Encoding)
go (!a
l, !Encoding
enc) a
next = (a
l forall a. Num a => a -> a -> a
+ a
1, Encoding
enc forall a. Semigroup a => a -> a -> a
<> a -> Encoding
encoder a
next)

-- | Encode a data structure as a Map with the 0-based index for a Key to a value. Uses
-- variable map length encoding, which means an indefinite encoding for maps with over 23
-- elements and definite otherwise.
encodeFoldableMapEncoder ::
  Foldable f =>
  -- | A function that accepts an index of the value in the foldable data strucure, the
  -- actual value and optionally produces the encoding of the value and an index if that
  -- value should be encoded.
  (Word -> a -> Maybe Encoding) ->
  f a ->
  Encoding
encodeFoldableMapEncoder :: forall (f :: * -> *) a.
Foldable f =>
(Word -> a -> Maybe Encoding) -> f a -> Encoding
encodeFoldableMapEncoder Word -> a -> Maybe Encoding
encode f a
xs = Int -> Encoding -> Encoding
variableMapLenEncoding Int
len Encoding
contents
  where
    (Int
len, Word
_, Encoding
contents) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' forall {a}.
Num a =>
(a, Word, Encoding) -> a -> (a, Word, Encoding)
go (Int
0, Word
0, 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 forall a. Num a => a -> a -> a
+ Word
1, Encoding
enc)
      Just Encoding
e -> (a
l forall a. Num a => a -> a -> a
+ a
1, Word
i forall a. Num a => a -> a -> a
+ Word
1, Encoding
enc forall a. Semigroup a => a -> a -> a
<> Encoding
e)

--------------------------------------------------------------------------------
-- Map
--------------------------------------------------------------------------------

-- | Encode a Map. Versions variance:
--
-- * [>= 2] - Variable length encoding for Maps larger than 23 key value pairs, otherwise exact
--   length encoding
--
-- * [< 2] - Variable length encoding.
encodeMap ::
  (k -> Encoding) ->
  (v -> Encoding) ->
  Map.Map k v ->
  Encoding
encodeMap :: forall k v.
(k -> Encoding) -> (v -> Encoding) -> Map k v -> Encoding
encodeMap k -> Encoding
encodeKey v -> Encoding
encodeValue Map k v
m =
  let mapEncoding :: Encoding
mapEncoding = forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey (\k
k v
v -> k -> Encoding
encodeKey k
k forall a. Semigroup a => a -> a -> a
<> v -> Encoding
encodeValue v
v) Map k v
m
   in Version -> Encoding -> Encoding -> Encoding
ifEncodingVersionAtLeast
        (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @2)
        (Int -> Encoding -> Encoding
variableMapLenEncoding (forall k a. Map k a -> Int
Map.size Map k v
m) Encoding
mapEncoding)
        (Int -> Encoding -> Encoding
exactMapLenEncoding (forall k a. Map k a -> Int
Map.size Map k v
m) Encoding
mapEncoding)
{-# INLINE encodeMap #-}

-- | Mimics `Map` encoder `encodeMap` identically.
encodeVMap ::
  (VMap.Vector kv k, VMap.Vector vv v) =>
  (k -> Encoding) ->
  (v -> Encoding) ->
  VMap.VMap kv vv k v ->
  Encoding
encodeVMap :: forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
(k -> Encoding) -> (v -> Encoding) -> VMap kv vv k v -> Encoding
encodeVMap k -> Encoding
encodeKey v -> Encoding
encodeValue VMap kv vv k v
m =
  let mapEncoding :: Encoding
mapEncoding = forall (kv :: * -> *) k (vv :: * -> *) v m.
(Vector kv k, Vector vv v, Monoid m) =>
(k -> v -> m) -> VMap kv vv k v -> m
VMap.foldMapWithKey (\k
k v
v -> k -> Encoding
encodeKey k
k forall a. Semigroup a => a -> a -> a
<> v -> Encoding
encodeValue v
v) VMap kv vv k v
m
   in Version -> Encoding -> Encoding -> Encoding
ifEncodingVersionAtLeast
        (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @2)
        (Int -> Encoding -> Encoding
variableMapLenEncoding (forall (kv :: * -> *) k (vv :: * -> *) v.
Vector kv k =>
VMap kv vv k v -> Int
VMap.size VMap kv vv k v
m) Encoding
mapEncoding)
        (Int -> Encoding -> Encoding
exactMapLenEncoding (forall (kv :: * -> *) k (vv :: * -> *) v.
Vector kv k =>
VMap kv vv k v -> Int
VMap.size VMap kv vv k v
m) Encoding
mapEncoding)
{-# INLINE encodeVMap #-}

-- Usage of fromIntegral in `exactMapLenEncoding` is safe, since it is an internal function
-- and is applied to Map's size.
exactMapLenEncoding :: Int -> Encoding -> Encoding
exactMapLenEncoding :: Int -> Encoding -> Encoding
exactMapLenEncoding Int
len Encoding
contents =
  Word -> Encoding
encodeMapLen (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len :: Word) forall a. Semigroup a => a -> a -> a
<> Encoding
contents
{-# INLINE exactMapLenEncoding #-}

-- | Conditionally use variable length encoding, but only for Maps larger than 23
variableMapLenEncoding :: Int -> Encoding -> Encoding
variableMapLenEncoding :: Int -> Encoding -> Encoding
variableMapLenEncoding Int
len Encoding
contents =
  if Int
len forall a. Ord a => a -> a -> Bool
<= Int
lengthThreshold
    then Int -> Encoding -> Encoding
exactMapLenEncoding Int
len Encoding
contents
    else Encoding
encodeMapLenIndef forall a. Semigroup a => a -> a -> a
<> Encoding
contents forall a. Semigroup a => a -> a -> a
<> Encoding
encodeBreak
{-# INLINE variableMapLenEncoding #-}

-- | This is the optimal maximum number for encoding exact length. Above that threashold
-- using variable length encoding will result in less bytes on the wire.
lengthThreshold :: Int
lengthThreshold :: Int
lengthThreshold = Int
23

--------------------------------------------------------------------------------
-- Set
--------------------------------------------------------------------------------

-- | Usage of fromIntegral in `exactListLenEncoding` is safe, since it is an internal function
-- and is applied to List's size.
exactListLenEncoding :: Int -> Encoding -> Encoding
exactListLenEncoding :: Int -> Encoding -> Encoding
exactListLenEncoding Int
len Encoding
contents =
  Word -> Encoding
encodeListLen (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len :: Word) forall a. Semigroup a => a -> a -> a
<> Encoding
contents
{-# INLINE exactListLenEncoding #-}

-- | Conditionally use variable length encoding for list like structures with length
-- larger than 23, otherwise use exact list length encoding.
variableListLenEncoding ::
  -- | Number of elements in the encoded data structure.
  Int ->
  -- | Encoding for the actual data structure
  Encoding ->
  Encoding
variableListLenEncoding :: Int -> Encoding -> Encoding
variableListLenEncoding Int
len Encoding
contents =
  if Int
len forall a. Ord a => a -> a -> Bool
<= Int
lengthThreshold
    then Int -> Encoding -> Encoding
exactListLenEncoding Int
len Encoding
contents
    else Encoding
encodeListLenIndef forall a. Semigroup a => a -> a -> a
<> Encoding
contents forall a. Semigroup a => a -> a -> a
<> Encoding
encodeBreak
{-# INLINE variableListLenEncoding #-}

-- | Encode a Set. Versions variance:
--
-- * [>= 9] - Variable length encoding for Sets larger than 23 elements, otherwise exact
--   length encoding. Prefixes with a special 258 `setTag`.
--
-- * [>= 2] - Variable length encoding for Sets larger than 23 elements, otherwise exact
--   length encoding
--
-- * [< 2] - Variable length encoding. Prefixes with a special 258 `setTag`.
encodeSet :: (a -> Encoding) -> Set.Set a -> Encoding
encodeSet :: forall a. (a -> Encoding) -> Set a -> Encoding
encodeSet a -> Encoding
encodeValue Set a
f =
  let foldableEncoding :: Encoding
foldableEncoding = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' a -> Encoding
encodeValue Set a
f
      varLenSetEncoding :: Encoding
varLenSetEncoding = Int -> Encoding -> Encoding
variableListLenEncoding (forall a. Set a -> Int
Set.size Set a
f) Encoding
foldableEncoding
   in Version -> Encoding -> Encoding -> Encoding
ifEncodingVersionAtLeast
        (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @2)
        ( Version -> Encoding -> Encoding -> Encoding
ifEncodingVersionAtLeast
            (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9)
            (Word -> Encoding
encodeTag Word
setTag forall a. Semigroup a => a -> a -> a
<> Encoding
varLenSetEncoding)
            Encoding
varLenSetEncoding
        )
        (Word -> Encoding
encodeTag Word
setTag forall a. Semigroup a => a -> a -> a
<> Int -> Encoding -> Encoding
exactListLenEncoding (forall a. Set a -> Int
Set.size Set a
f) Encoding
foldableEncoding)
{-# INLINE encodeSet #-}

-- | Encode a list. Versions variance:
--
-- * [>= 2] - Variable length encoding for lists longer than 23 elements, otherwise exact
--   length encoding
--
-- * [< 2] - Variable length encoding
encodeList :: (a -> Encoding) -> [a] -> Encoding
encodeList :: forall a. (a -> Encoding) -> [a] -> Encoding
encodeList a -> Encoding
encodeValue [a]
xs =
  let varLenEncList :: Encoding
varLenEncList = forall (f :: * -> *) a.
Foldable f =>
(a -> Encoding) -> f a -> Encoding
encodeFoldableAsIndefLenList a -> Encoding
encodeValue [a]
xs
      -- we don't want to compute the length of the list, unless it is smaller than the
      -- threshold
      encListVer2 :: Encoding
encListVer2 =
        case forall a. Int -> [a] -> [a]
drop Int
lengthThreshold [a]
xs of
          [] -> forall (f :: * -> *) a.
Foldable f =>
(a -> Encoding) -> f a -> Encoding
encodeFoldableAsDefLenList a -> Encoding
encodeValue [a]
xs
          [a]
_ -> Encoding
varLenEncList
   in Version -> Encoding -> Encoding -> Encoding
ifEncodingVersionAtLeast (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @2) Encoding
encListVer2 Encoding
varLenEncList

-- | Encode a Seq. Variable length encoding for Sequences larger than 23 elements,
--   otherwise exact length encoding
encodeSeq :: (a -> Encoding) -> Seq.Seq a -> Encoding
encodeSeq :: forall a. (a -> Encoding) -> Seq a -> Encoding
encodeSeq a -> Encoding
encodeValue Seq a
f = Int -> Encoding -> Encoding
variableListLenEncoding (forall a. Seq a -> Int
Seq.length Seq a
f) (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' a -> Encoding
encodeValue Seq a
f)
{-# INLINE encodeSeq #-}

encodeStrictSeq :: (a -> Encoding) -> SSeq.StrictSeq a -> Encoding
encodeStrictSeq :: forall a. (a -> Encoding) -> StrictSeq a -> Encoding
encodeStrictSeq a -> Encoding
encodeValue = forall a. (a -> Encoding) -> Seq a -> Encoding
encodeSeq a -> Encoding
encodeValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. StrictSeq a -> Seq a
SSeq.fromStrict
{-# INLINE encodeStrictSeq #-}

--------------------------------------------------------------------------------
-- Vector
--------------------------------------------------------------------------------
encodeContainerSkel ::
  (Word -> Encoding) ->
  (container -> Int) ->
  (accumFunc -> Encoding -> container -> Encoding) ->
  accumFunc ->
  container ->
  Encoding
encodeContainerSkel :: forall container accumFunc.
(Word -> Encoding)
-> (container -> Int)
-> (accumFunc -> Encoding -> container -> Encoding)
-> accumFunc
-> container
-> Encoding
encodeContainerSkel Word -> Encoding
encodeLen container -> Int
size accumFunc -> Encoding -> container -> Encoding
foldFunction accumFunc
f container
c =
  Word -> Encoding
encodeLen (forall a b. (Integral a, Num b) => a -> b
fromIntegral (container -> Int
size container
c)) forall a. Semigroup a => a -> a -> a
<> accumFunc -> Encoding -> container -> Encoding
foldFunction accumFunc
f forall a. Monoid a => a
mempty container
c
{-# INLINE encodeContainerSkel #-}

-- | Generic encoder for vectors. Its intended use is to allow easy
-- definition of 'EncCBOR' instances for custom vector
encodeVector :: VG.Vector v a => (a -> Encoding) -> v a -> Encoding
encodeVector :: forall (v :: * -> *) a.
Vector v a =>
(a -> Encoding) -> v a -> Encoding
encodeVector a -> Encoding
encodeValue =
  forall container accumFunc.
(Word -> Encoding)
-> (container -> Int)
-> (accumFunc -> Encoding -> container -> Encoding)
-> accumFunc
-> container
-> Encoding
encodeContainerSkel
    Word -> Encoding
encodeListLen
    forall (v :: * -> *) a. Vector v a => v a -> Int
VG.length
    forall (v :: * -> *) a b.
Vector v a =>
(a -> b -> b) -> b -> v a -> b
VG.foldr
    (\a
a Encoding
b -> a -> Encoding
encodeValue a
a forall a. Semigroup a => a -> a -> a
<> Encoding
b)
{-# INLINE encodeVector #-}

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

encodeUTCTime :: UTCTime -> Encoding
encodeUTCTime :: UTCTime -> Encoding
encodeUTCTime (UTCTime Day
day DiffTime
timeOfDay) =
  Word -> Encoding
encodeListLen Word
3
    forall a. Semigroup a => a -> a -> a
<> Integer -> Encoding
encodeInteger Integer
year
    forall a. Semigroup a => a -> a -> a
<> Int -> Encoding
encodeInt Int
dayOfYear
    forall a. Semigroup a => a -> a -> a
<> Integer -> Encoding
encodeInteger Integer
timeOfDayPico
  where
    (Integer
year, Int
dayOfYear) = Day -> (Integer, Int)
toOrdinalDate Day
day
    timeOfDayPico :: Integer
timeOfDayPico = DiffTime -> Integer
diffTimeToPicoseconds DiffTime
timeOfDay

--------------------------------------------------------------------------------
-- Network
--------------------------------------------------------------------------------

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

encodeIPv4 :: IPv4 -> Encoding
encodeIPv4 :: IPv4 -> Encoding
encodeIPv4 = ByteString -> Encoding
encodeBytes forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPv4 -> ByteString
ipv4ToBytes

ipv6ToBytes :: IPv6 -> BS.ByteString
ipv6ToBytes :: IPv6 -> ByteString
ipv6ToBytes IPv6
ipv6 = ByteString -> ByteString
BSL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPut 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

encodeIPv6 :: IPv6 -> Encoding
encodeIPv6 :: IPv6 -> Encoding
encodeIPv6 = ByteString -> Encoding
encodeBytes forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPv6 -> ByteString
ipv6ToBytes