{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeFamilies #-}

-- | The LeiosFetch mini-protocol's types and codec.
module Ouroboros.Consensus.MiniProtocol.LeiosFetch.Type
  ( LeiosFetch (..)
  , LeiosFetchBusy (..)
  , Message (..)
  , SingLeiosFetch (..)
  , TxBitmaps
  , bitmapOffsets
  , byteLimitsLeiosFetch
  , codecLeiosFetch
  , codecLeiosFetchId
  , maxLeiosTxsRequestBytesSize
  , timeLimitsLeiosFetch
  ) where

import Cardano.Ledger.Binary.Plain (decodeRecordSum)
import qualified Codec.CBOR.Decoding as CBOR
import qualified Codec.CBOR.Encoding as CBOR
import qualified Codec.CBOR.Read as CBOR
import Control.DeepSeq (NFData (..))
import Control.Monad (when)
import Control.Monad.Class.MonadST (MonadST)
import qualified Data.Bits as Bits
import Data.ByteString.Lazy (ByteString)
import Data.Kind (Type)
import Data.List (unfoldr)
import Data.Proxy (Proxy (..))
import qualified Data.Text as T
import qualified Data.Vector.Strict as V
import Data.Word (Word16, Word32, Word64)
import Network.TypedProtocol.Codec.CBOR
  ( ActiveState
  , AnnotatedCodec
  , Annotator (..)
  , AnyMessage (..)
  , Codec
  , CodecF (..)
  , CodecFailure (..)
  , DecodeStep (..)
  , SomeMessage (..)
  , StateTokenI (..)
  , mkCodecCborLazyBS
  , notActiveState
  )
import Network.TypedProtocol.Core
  ( Agency (..)
  , Protocol (..)
  , StateAgency
  )
import Ouroboros.Consensus.Leios.Types (maxEndorserBlockBytesSize)
import Ouroboros.Consensus.Util.CBOR (decodeListUpTo)
import Ouroboros.Network.Protocol.Limits
  ( ProtocolSizeLimits (..)
  , ProtocolTimeLimits (..)
  , longWait
  , smallByteLimit
  , waitForever
  )
import Ouroboros.Network.Util.ShowProxy (ShowProxy (..))

-----

-- | The LeiosFetch mini-protocol's states, as the cardano-blueprint specifies
-- them:
-- <https://cardano-scaling.github.io/cardano-blueprint/network/node-to-node/leios-fetch/index.html?leios=on>.
-- CIP-0164 specifies the Leios mini-protocols,
-- <https://cips.cardano.org/cip/CIP-0164>.
type LeiosFetch :: Type -> Type -> Type -> Type
data LeiosFetch point eb tx = StIdle | StBusy (LeiosFetchBusy point eb tx) | StDone

type LeiosFetchBusy :: Type -> Type -> Type -> Type
data LeiosFetchBusy point eb tx = StBlock | StBlockTxs

instance
  ( ShowProxy point
  , ShowProxy eb
  , ShowProxy tx
  ) =>
  ShowProxy (LeiosFetch point eb tx)
  where
  showProxy :: Proxy (LeiosFetch point eb tx) -> String
showProxy Proxy (LeiosFetch point eb tx)
_ =
    [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ String
"LeiosFetch "
      , Proxy point -> String
forall {k} (p :: k). ShowProxy p => Proxy p -> String
showProxy (Proxy point
forall {k} (t :: k). Proxy t
Proxy :: Proxy point)
      , String
" "
      , Proxy eb -> String
forall {k} (p :: k). ShowProxy p => Proxy p -> String
showProxy (Proxy eb
forall {k} (t :: k). Proxy t
Proxy :: Proxy eb)
      , String
" "
      , Proxy tx -> String
forall {k} (p :: k). ShowProxy p => Proxy p -> String
showProxy (Proxy tx
forall {k} (t :: k). Proxy t
Proxy :: Proxy tx)
      ]

instance ShowProxy (StIdle :: LeiosFetch point eb tx) where
  showProxy :: Proxy 'StIdle -> String
showProxy Proxy 'StIdle
_ = String
"StIdle"
instance ShowProxy (StBusy StBlock :: LeiosFetch point eb tx) where
  showProxy :: Proxy ('StBusy 'StBlock) -> String
showProxy Proxy ('StBusy 'StBlock)
_ = String
"(StBusy StBlock)"
instance ShowProxy (StBusy StBlockTxs :: LeiosFetch point eb tx) where
  showProxy :: Proxy ('StBusy 'StBlockTxs) -> String
showProxy Proxy ('StBusy 'StBlockTxs)
_ = String
"(StBusy StBlockTxs)"
instance ShowProxy (StDone :: LeiosFetch point eb tx) where
  showProxy :: Proxy 'StDone -> String
showProxy Proxy 'StDone
_ = String
"StDone"

type SingLeiosFetch ::
  LeiosFetch point eb tx ->
  Type
data SingLeiosFetch st where
  SingIdle :: SingLeiosFetch StIdle
  SingBlock :: SingLeiosFetch (StBusy StBlock)
  SingBlockTxs :: SingLeiosFetch (StBusy StBlockTxs)
  SingDone :: SingLeiosFetch StDone

deriving instance Show (SingLeiosFetch st)

instance StateTokenI StIdle where stateToken :: StateToken 'StIdle
stateToken = StateToken 'StIdle
SingLeiosFetch 'StIdle
forall {point} {eb} {tx}. SingLeiosFetch 'StIdle
SingIdle
instance StateTokenI (StBusy StBlock) where stateToken :: StateToken ('StBusy 'StBlock)
stateToken = StateToken ('StBusy 'StBlock)
SingLeiosFetch ('StBusy 'StBlock)
forall {point} {eb} {tx}. SingLeiosFetch ('StBusy 'StBlock)
SingBlock
instance StateTokenI (StBusy StBlockTxs) where stateToken :: StateToken ('StBusy 'StBlockTxs)
stateToken = StateToken ('StBusy 'StBlockTxs)
SingLeiosFetch ('StBusy 'StBlockTxs)
forall {point} {eb} {tx}. SingLeiosFetch ('StBusy 'StBlockTxs)
SingBlockTxs
instance StateTokenI StDone where stateToken :: StateToken 'StDone
stateToken = StateToken 'StDone
SingLeiosFetch 'StDone
forall {point} {eb} {tx}. SingLeiosFetch 'StDone
SingDone

-----

-- | Which of an endorser block's transactions a request names: each entry is
-- the index of a run of 64 transactions and a bitmap of those 64, the most
-- significant bit naming the first of them.
type TxBitmaps = [(Word16, Word64)]

-- | The offsets of the transactions the bitmaps name, in the bitmaps' order.
bitmapOffsets :: TxBitmaps -> [Int]
bitmapOffsets :: [(Word16, Word64)] -> [Int]
bitmapOffsets = ([(Word16, Word64)] -> Maybe (Int, [(Word16, Word64)]))
-> [(Word16, Word64)] -> [Int]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr [(Word16, Word64)] -> Maybe (Int, [(Word16, Word64)])
next
 where
  next :: [(Word16, Word64)] -> Maybe (Int, [(Word16, Word64)])
next = \case
    [] -> Maybe (Int, [(Word16, Word64)])
forall a. Maybe a
Nothing
    (Word16
index, Word64
bitmap) : [(Word16, Word64)]
rest
      | Word64
bitmap Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 -> [(Word16, Word64)] -> Maybe (Int, [(Word16, Word64)])
next [(Word16, Word64)]
rest
      | Bool
otherwise ->
          let i :: Int
i = Word64 -> Int
forall b. FiniteBits b => b -> Int
Bits.countLeadingZeros Word64
bitmap
           in (Int, [(Word16, Word64)]) -> Maybe (Int, [(Word16, Word64)])
forall a. a -> Maybe a
Just (Int
64 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
index Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i, (Word16
index, Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
Bits.clearBit Word64
bitmap (Int
63 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)) (Word16, Word64) -> [(Word16, Word64)] -> [(Word16, Word64)]
forall a. a -> [a] -> [a]
: [(Word16, Word64)]
rest)

instance Protocol (LeiosFetch point eb tx) where
  data Message (LeiosFetch point eb tx) from to where
    MsgDone ::
      Message (LeiosFetch point eb tx) StIdle StDone
    MsgLeiosBlockRequest ::
      !point ->
      Message (LeiosFetch point eb tx) StIdle (StBusy StBlock)
    MsgLeiosBlock ::
      !eb ->
      Message (LeiosFetch point eb tx) (StBusy StBlock) StIdle
    MsgLeiosBlockTxsRequest ::
      !point ->
      TxBitmaps ->
      Message (LeiosFetch point eb tx) StIdle (StBusy StBlockTxs)
    MsgLeiosBlockTxs ::
      !(V.Vector tx) ->
      Message (LeiosFetch point eb tx) (StBusy StBlockTxs) StIdle

  type StateAgency StIdle = ClientAgency
  type StateAgency (StBusy st) = ServerAgency
  type StateAgency StDone = NobodyAgency

  type StateToken = SingLeiosFetch

instance NFData (Message (LeiosFetch point eb tx) from to) where
  rnf :: Message (LeiosFetch point eb tx) from to -> ()
rnf = \case
    Message (LeiosFetch point eb tx) from to
R:MessageLeiosFetchfromto point eb tx from to
MsgDone -> ()
    MsgLeiosBlockRequest{} -> ()
    MsgLeiosBlock{} -> ()
    MsgLeiosBlockTxsRequest point
_p [(Word16, Word64)]
bitmaps -> [(Word16, Word64)] -> ()
forall a. NFData a => a -> ()
rnf [(Word16, Word64)]
bitmaps
    MsgLeiosBlockTxs{} -> ()

deriving instance
  (Eq point, Eq eb, Eq tx) =>
  Eq (Message (LeiosFetch point eb tx) from to)

deriving instance
  (Show point, Show eb, Show tx) =>
  Show (Message (LeiosFetch point eb tx) from to)

-----

-- | The most transaction bytes an honest client asks for in one
-- 'MsgLeiosBlockTxsRequest', so that it fetches an endorser block's closure as
-- several smaller requests, smoothing out its load on the peer. The server need
-- not enforce it. The client bounds the size of a 'MsgLeiosBlockTxs' by it.
--
-- Its value is a design choice; no protocol parameter bounds it.
maxLeiosTxsRequestBytesSize :: Word32
maxLeiosTxsRequestBytesSize :: Word32
maxLeiosTxsRequestBytesSize = Word32
500 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
1000

-- | The limits assume that peers write the parts of a message that are not
-- hashed, such as the framing around its payloads, in tight CBOR: each
-- integer and length in its fewest bytes. The decoders accept wider ones too,
-- but the limits do not make room for them.
byteLimitsLeiosFetch ::
  (bytes -> Word) ->
  ProtocolSizeLimits (LeiosFetch point eb tx) bytes
byteLimitsLeiosFetch :: forall bytes point eb tx.
(bytes -> Word)
-> ProtocolSizeLimits (LeiosFetch point eb tx) bytes
byteLimitsLeiosFetch = (forall (st :: LeiosFetch point eb tx).
 ActiveState st =>
 StateToken st -> Word)
-> (bytes -> Word)
-> ProtocolSizeLimits (LeiosFetch point eb tx) bytes
forall ps bytes.
(forall (st :: ps). ActiveState st => StateToken st -> Word)
-> (bytes -> Word) -> ProtocolSizeLimits ps bytes
ProtocolSizeLimits ((forall (st :: LeiosFetch point eb tx).
  ActiveState st =>
  StateToken st -> Word)
 -> (bytes -> Word)
 -> ProtocolSizeLimits (LeiosFetch point eb tx) bytes)
-> (forall (st :: LeiosFetch point eb tx).
    ActiveState st =>
    StateToken st -> Word)
-> (bytes -> Word)
-> ProtocolSizeLimits (LeiosFetch point eb tx) bytes
forall a b. (a -> b) -> a -> b
$ \case
  StateToken st
SingLeiosFetch st
SingIdle -> Word
smallByteLimit
  -- A 'MsgLeiosBlock' adds at most three bytes to an endorser block: the
  -- header of a list of two items, the tag 2, and the closing marker if the
  -- list is indefinite-length. 'decodeEndorserBlock' rejects an endorser block
  -- larger than 'maxEndorserBlockBytesSize' only after decoding it, and this
  -- limit keeps that work close to what the largest acceptable one costs.
  StateToken st
SingLeiosFetch st
SingBlock -> Word32 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word) -> Word32 -> Word
forall a b. (a -> b) -> a -> b
$ Word32
maxEndorserBlockBytesSize Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
3
  StateToken st
SingLeiosFetch st
SingBlockTxs -> Word32 -> Word
withMargin Word32
maxLeiosTxsRequestBytesSize
  st :: StateToken st
st@StateToken st
SingLeiosFetch st
SingDone -> StateToken 'StDone -> forall a. a
forall ps (st :: ps).
(StateAgency st ~ 'NobodyAgency, ActiveState st) =>
StateToken st -> forall a. a
notActiveState StateToken st
StateToken 'StDone
st
 where
  -- The margin covers what a 'MsgLeiosBlockTxs' writes around its payload: at
  -- most seven bytes, plus a CBOR-in-CBOR tag and byte-string header per
  -- transaction: four bytes while the transaction is under 256 bytes, five under
  -- 64 KiB, seven beyond. A valid transaction spends at least one input, so it
  -- takes at least 47 bytes, and the headers add under 9% of
  -- 'maxLeiosTxsRequestBytesSize'.
  withMargin :: Word32 -> Word
  withMargin :: Word32 -> Word
withMargin Word32
x = Word32 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word) -> Word32 -> Word
forall a b. (a -> b) -> a -> b
$ Word32
x Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
x Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`div` Word32
10

timeLimitsLeiosFetch ::
  ProtocolTimeLimits (LeiosFetch point eb tx)
timeLimitsLeiosFetch :: forall point eb tx. ProtocolTimeLimits (LeiosFetch point eb tx)
timeLimitsLeiosFetch = (forall (st :: LeiosFetch point eb tx).
 ActiveState st =>
 StateToken st -> Maybe DiffTime)
-> ProtocolTimeLimits (LeiosFetch point eb tx)
forall ps.
(forall (st :: ps).
 ActiveState st =>
 StateToken st -> Maybe DiffTime)
-> ProtocolTimeLimits ps
ProtocolTimeLimits ((forall (st :: LeiosFetch point eb tx).
  ActiveState st =>
  StateToken st -> Maybe DiffTime)
 -> ProtocolTimeLimits (LeiosFetch point eb tx))
-> (forall (st :: LeiosFetch point eb tx).
    ActiveState st =>
    StateToken st -> Maybe DiffTime)
-> ProtocolTimeLimits (LeiosFetch point eb tx)
forall a b. (a -> b) -> a -> b
$ \case
  StateToken st
SingLeiosFetch st
SingIdle -> Maybe DiffTime
waitForever
  StateToken st
SingLeiosFetch st
SingBlock -> Maybe DiffTime
longWait
  StateToken st
SingLeiosFetch st
SingBlockTxs -> Maybe DiffTime
longWait
  st :: StateToken st
st@StateToken st
SingLeiosFetch st
SingDone -> StateToken 'StDone -> forall a. a
forall ps (st :: ps).
(StateAgency st ~ 'NobodyAgency, ActiveState st) =>
StateToken st -> forall a. a
notActiveState StateToken st
StateToken 'StDone
st

-----

codecLeiosFetch ::
  forall (point :: Type) (eb :: Type) (tx :: Type) m.
  MonadST m =>
  -- | The most txs an EB can hold. The decoder rejects a larger count before
  -- it allocates.
  Int ->
  (point -> CBOR.Encoding) ->
  (forall s. CBOR.Decoder s point) ->
  (eb -> CBOR.Encoding) ->
  -- | Decode an endorser block, given the bytes of the whole message. Its byte
  -- offsets count from the start of the message, as the ledger's annotators
  -- expect, so it slices its own bytes out of them.
  (forall s. CBOR.Decoder s (ByteString -> eb)) ->
  (tx -> CBOR.Encoding) ->
  (forall s. CBOR.Decoder s tx) ->
  AnnotatedCodec (LeiosFetch point eb tx) CBOR.DeserialiseFailure m ByteString
codecLeiosFetch :: forall point eb tx (m :: * -> *).
MonadST m =>
Int
-> (point -> Encoding)
-> (forall s. Decoder s point)
-> (eb -> Encoding)
-> (forall s. Decoder s (ByteString -> eb))
-> (tx -> Encoding)
-> (forall s. Decoder s tx)
-> AnnotatedCodec
     (LeiosFetch point eb tx) DeserialiseFailure m ByteString
codecLeiosFetch Int
maxTxs point -> Encoding
encodeP forall s. Decoder s point
decodeP eb -> Encoding
encodeEb forall s. Decoder s (ByteString -> eb)
decodeEb tx -> Encoding
encodeTx forall s. Decoder s tx
decodeTx =
  (forall (st :: LeiosFetch point eb tx)
        (st' :: LeiosFetch point eb tx).
 (StateTokenI st, ActiveState st) =>
 Message (LeiosFetch point eb tx) st st' -> Encoding)
-> (forall (st :: LeiosFetch point eb tx) s.
    ActiveState st =>
    StateToken st -> Decoder s (Annotator ByteString st))
-> CodecF
     (LeiosFetch point eb tx)
     DeserialiseFailure
     m
     (Annotator ByteString)
     ByteString
forall ps (m :: * -> *) (f :: ps -> *).
MonadST m =>
(forall (st :: ps) (st' :: ps).
 (StateTokenI st, ActiveState st) =>
 Message ps st st' -> Encoding)
-> (forall (st :: ps) s.
    ActiveState st =>
    StateToken st -> Decoder s (f st))
-> CodecF ps DeserialiseFailure m f ByteString
mkCodecCborLazyBS
    ((point -> Encoding)
-> (eb -> Encoding)
-> (tx -> Encoding)
-> Message (LeiosFetch point eb tx) st st'
-> Encoding
forall point eb tx (st :: LeiosFetch point eb tx)
       (st' :: LeiosFetch point eb tx).
(point -> Encoding)
-> (eb -> Encoding)
-> (tx -> Encoding)
-> Message (LeiosFetch point eb tx) st st'
-> Encoding
encodeLeiosFetch point -> Encoding
encodeP eb -> Encoding
encodeEb tx -> Encoding
encodeTx)
    StateToken st -> Decoder s (Annotator ByteString st)
StateToken st -> forall s. Decoder s (Annotator ByteString st)
forall (st :: LeiosFetch point eb tx).
ActiveState st =>
StateToken st -> forall s. Decoder s (Annotator ByteString st)
forall (st :: LeiosFetch point eb tx) s.
ActiveState st =>
StateToken st -> Decoder s (Annotator ByteString st)
decode
 where
  decode ::
    forall (st :: LeiosFetch point eb tx).
    ActiveState st =>
    StateToken st ->
    forall s.
    CBOR.Decoder s (Annotator ByteString st)
  decode :: forall (st :: LeiosFetch point eb tx).
ActiveState st =>
StateToken st -> forall s. Decoder s (Annotator ByteString st)
decode StateToken st
stok =
    Text
-> (Word -> Decoder s (Int, Annotator ByteString st))
-> Decoder s (Annotator ByteString st)
forall s a. Text -> (Word -> Decoder s (Int, a)) -> Decoder s a
decodeRecordSum
      (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"LeiosFetch (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SingLeiosFetch st -> String
forall a. Show a => a -> String
show StateToken st
SingLeiosFetch st
stok String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")")
      (Int
-> (forall s. Decoder s point)
-> (forall s. Decoder s (ByteString -> eb))
-> (forall s. Decoder s tx)
-> StateToken st
-> Word
-> Decoder s (Int, Annotator ByteString st)
forall point eb tx (st :: LeiosFetch point eb tx) s.
ActiveState st =>
Int
-> (forall s'. Decoder s' point)
-> (forall s'. Decoder s' (ByteString -> eb))
-> (forall s'. Decoder s' tx)
-> StateToken st
-> Word
-> Decoder s (Int, Annotator ByteString st)
decodeLeiosFetch Int
maxTxs Decoder s' point
forall s. Decoder s point
decodeP Decoder s' (ByteString -> eb)
forall s. Decoder s (ByteString -> eb)
decodeEb Decoder s' tx
forall s. Decoder s tx
decodeTx StateToken st
stok)

encodeLeiosFetch ::
  forall
    (point :: Type)
    (eb :: Type)
    (tx :: Type)
    (st :: LeiosFetch point eb tx)
    (st' :: LeiosFetch point eb tx).
  (point -> CBOR.Encoding) ->
  (eb -> CBOR.Encoding) ->
  (tx -> CBOR.Encoding) ->
  Message (LeiosFetch point eb tx) st st' ->
  CBOR.Encoding
encodeLeiosFetch :: forall point eb tx (st :: LeiosFetch point eb tx)
       (st' :: LeiosFetch point eb tx).
(point -> Encoding)
-> (eb -> Encoding)
-> (tx -> Encoding)
-> Message (LeiosFetch point eb tx) st st'
-> Encoding
encodeLeiosFetch point -> Encoding
encodeP eb -> Encoding
encodeEb tx -> Encoding
encodeTx = \case
  Message (LeiosFetch point eb tx) st st'
R:MessageLeiosFetchfromto point eb tx st st'
MsgDone ->
    Word -> Encoding
CBOR.encodeListLen Word
1
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
0
  MsgLeiosBlockRequest point
p ->
    Word -> Encoding
CBOR.encodeListLen Word
2
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
1
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> point -> Encoding
encodeP point
p
  MsgLeiosBlock eb
x ->
    Word -> Encoding
CBOR.encodeListLen Word
2
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
2
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> eb -> Encoding
encodeEb eb
x
  MsgLeiosBlockTxsRequest point
p [(Word16, Word64)]
bitmaps ->
    Word -> Encoding
CBOR.encodeListLen Word
3
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
3
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> point -> Encoding
encodeP point
p
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [(Word16, Word64)] -> Encoding
encodeBitmaps [(Word16, Word64)]
bitmaps
  MsgLeiosBlockTxs Vector tx
txs ->
    Word -> Encoding
CBOR.encodeListLen Word
2
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
4
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeListLen (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ Vector tx -> Int
forall a. Vector a -> Int
V.length Vector tx
txs)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> (tx -> Encoding) -> Vector tx -> Encoding
forall m a. Monoid m => (a -> m) -> Vector a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap tx -> Encoding
encodeTx Vector tx
txs

decodeLeiosFetch ::
  forall
    (point :: Type)
    (eb :: Type)
    (tx :: Type)
    (st :: LeiosFetch point eb tx)
    s.
  ActiveState st =>
  Int ->
  (forall s'. CBOR.Decoder s' point) ->
  (forall s'. CBOR.Decoder s' (ByteString -> eb)) ->
  (forall s'. CBOR.Decoder s' tx) ->
  StateToken st ->
  Word ->
  CBOR.Decoder s (Int, Annotator ByteString st)
decodeLeiosFetch :: forall point eb tx (st :: LeiosFetch point eb tx) s.
ActiveState st =>
Int
-> (forall s'. Decoder s' point)
-> (forall s'. Decoder s' (ByteString -> eb))
-> (forall s'. Decoder s' tx)
-> StateToken st
-> Word
-> Decoder s (Int, Annotator ByteString st)
decodeLeiosFetch Int
maxTxs forall s'. Decoder s' point
decodeP forall s'. Decoder s' (ByteString -> eb)
decodeEb forall s'. Decoder s' tx
decodeTx StateToken st
stok Word
key =
  case (StateToken st
SingLeiosFetch st
stok, Word
key) of
    (SingLeiosFetch st
SingIdle, Word
0) -> Int
-> Decoder s (Annotator ByteString st)
-> Decoder s (Int, Annotator ByteString st)
fields Int
1 (Decoder s (Annotator ByteString st)
 -> Decoder s (Int, Annotator ByteString st))
-> Decoder s (Annotator ByteString st)
-> Decoder s (Int, Annotator ByteString st)
forall a b. (a -> b) -> a -> b
$ Annotator ByteString st -> Decoder s (Annotator ByteString st)
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message (LeiosFetch point eb tx) st 'StDone
-> Annotator ByteString st
forall (st' :: LeiosFetch point eb tx).
(StateTokenI st, StateTokenI st') =>
Message (LeiosFetch point eb tx) st st' -> Annotator ByteString st
dontNeedAnnotatorBytes Message (LeiosFetch point eb tx) st 'StDone
Message (LeiosFetch point eb tx) 'StIdle 'StDone
forall point eb tx.
Message (LeiosFetch point eb tx) 'StIdle 'StDone
MsgDone)
    (SingLeiosFetch st
SingIdle, Word
1) -> Int
-> Decoder s (Annotator ByteString st)
-> Decoder s (Int, Annotator ByteString st)
fields Int
2 (Decoder s (Annotator ByteString st)
 -> Decoder s (Int, Annotator ByteString st))
-> Decoder s (Annotator ByteString st)
-> Decoder s (Int, Annotator ByteString st)
forall a b. (a -> b) -> a -> b
$ do
      p <- Decoder s point
forall s'. Decoder s' point
decodeP
      return $ dontNeedAnnotatorBytes $ MsgLeiosBlockRequest p
    (SingLeiosFetch st
SingBlock, Word
2) -> Int
-> Decoder s (Annotator ByteString st)
-> Decoder s (Int, Annotator ByteString st)
fields Int
2 (Decoder s (Annotator ByteString st)
 -> Decoder s (Int, Annotator ByteString st))
-> Decoder s (Annotator ByteString st)
-> Decoder s (Int, Annotator ByteString st)
forall a b. (a -> b) -> a -> b
$ do
      x <- Decoder s (ByteString -> eb)
forall s'. Decoder s' (ByteString -> eb)
decodeEb
      return $ Annotator $ SomeMessage . MsgLeiosBlock . x
    (SingLeiosFetch st
SingIdle, Word
3) -> Int
-> Decoder s (Annotator ByteString st)
-> Decoder s (Int, Annotator ByteString st)
fields Int
3 (Decoder s (Annotator ByteString st)
 -> Decoder s (Int, Annotator ByteString st))
-> Decoder s (Annotator ByteString st)
-> Decoder s (Int, Annotator ByteString st)
forall a b. (a -> b) -> a -> b
$ do
      p <- Decoder s point
forall s'. Decoder s' point
decodeP
      bitmaps <- decodeBitmaps maxTxs
      return $ dontNeedAnnotatorBytes $ MsgLeiosBlockTxsRequest p bitmaps
    (SingLeiosFetch st
SingBlockTxs, Word
4) -> Int
-> Decoder s (Annotator ByteString st)
-> Decoder s (Int, Annotator ByteString st)
fields Int
2 (Decoder s (Annotator ByteString st)
 -> Decoder s (Int, Annotator ByteString st))
-> Decoder s (Annotator ByteString st)
-> Decoder s (Int, Annotator ByteString st)
forall a b. (a -> b) -> a -> b
$ do
      txs <- String -> Int -> Decoder s tx -> Decoder s [tx]
forall s a. String -> Int -> Decoder s a -> Decoder s [a]
decodeListUpTo String
"MsgLeiosBlockTxs" Int
maxTxs Decoder s tx
forall s'. Decoder s' tx
decodeTx
      return $ dontNeedAnnotatorBytes $ MsgLeiosBlockTxs $ V.fromList txs
    (SingLeiosFetch st
SingDone, Word
_) -> StateToken 'StDone -> forall a. a
forall ps (st :: ps).
(StateAgency st ~ 'NobodyAgency, ActiveState st) =>
StateToken st -> forall a. a
notActiveState StateToken st
StateToken 'StDone
stok
    -- failures per protocol state
    (SingLeiosFetch st
SingIdle, Word
_) -> Decoder s (Int, Annotator ByteString st)
forall a. Decoder s a
unexpected
    (SingLeiosFetch st
SingBlock, Word
_) -> Decoder s (Int, Annotator ByteString st)
forall a. Decoder s a
unexpected
    (SingLeiosFetch st
SingBlockTxs, Word
_) -> Decoder s (Int, Annotator ByteString st)
forall a. Decoder s a
unexpected
 where
  fields ::
    Int -> CBOR.Decoder s (Annotator ByteString st) -> CBOR.Decoder s (Int, Annotator ByteString st)
  fields :: Int
-> Decoder s (Annotator ByteString st)
-> Decoder s (Int, Annotator ByteString st)
fields Int
n = (Annotator ByteString st -> (Int, Annotator ByteString st))
-> Decoder s (Annotator ByteString st)
-> Decoder s (Int, Annotator ByteString st)
forall a b. (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) Int
n)

  dontNeedAnnotatorBytes ::
    forall st'.
    (StateTokenI st, StateTokenI st') =>
    Message (LeiosFetch point eb tx) st st' -> Annotator ByteString st
  dontNeedAnnotatorBytes :: forall (st' :: LeiosFetch point eb tx).
(StateTokenI st, StateTokenI st') =>
Message (LeiosFetch point eb tx) st st' -> Annotator ByteString st
dontNeedAnnotatorBytes = (ByteString -> SomeMessage st) -> Annotator ByteString st
forall {ps} bytes (st :: ps).
(bytes -> SomeMessage st) -> Annotator bytes st
Annotator ((ByteString -> SomeMessage st) -> Annotator ByteString st)
-> (Message (LeiosFetch point eb tx) st st'
    -> ByteString -> SomeMessage st)
-> Message (LeiosFetch point eb tx) st st'
-> Annotator ByteString st
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeMessage st -> ByteString -> SomeMessage st
forall a b. a -> b -> a
const (SomeMessage st -> ByteString -> SomeMessage st)
-> (Message (LeiosFetch point eb tx) st st' -> SomeMessage st)
-> Message (LeiosFetch point eb tx) st st'
-> ByteString
-> SomeMessage st
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message (LeiosFetch point eb tx) st st' -> SomeMessage st
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
Message ps st st' -> SomeMessage st
SomeMessage

  unexpected :: forall a. CBOR.Decoder s a
  unexpected :: forall a. Decoder s a
unexpected =
    String -> Decoder s a
forall a. HasCallStack => String -> Decoder s a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail (String -> Decoder s a) -> String -> Decoder s a
forall a b. (a -> b) -> a -> b
$ String
"codecLeiosFetch (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SingLeiosFetch st -> String
forall a. Show a => a -> String
show StateToken st
SingLeiosFetch st
stok String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
") unexpected key " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word -> String
forall a. Show a => a -> String
show Word
key

codecLeiosFetchId ::
  forall (point :: Type) (eb :: Type) (tx :: Type) m.
  Monad m =>
  Codec
    (LeiosFetch point eb tx)
    CodecFailure
    m
    (AnyMessage (LeiosFetch point eb tx))
codecLeiosFetchId :: forall point eb tx (m :: * -> *).
Monad m =>
Codec
  (LeiosFetch point eb tx)
  CodecFailure
  m
  (AnyMessage (LeiosFetch point eb tx))
codecLeiosFetchId = Codec{Message (LeiosFetch point eb tx) st st'
-> AnyMessage (LeiosFetch point eb tx)
forall (st :: LeiosFetch point eb tx)
       (st' :: LeiosFetch point eb tx).
(ActiveState st, StateTokenI st) =>
Message (LeiosFetch point eb tx) st st'
-> AnyMessage (LeiosFetch point eb tx)
forall (st :: LeiosFetch point eb tx)
       (st' :: LeiosFetch point eb tx).
(StateTokenI st, ActiveState st) =>
Message (LeiosFetch point eb tx) st st'
-> AnyMessage (LeiosFetch point eb tx)
encode :: forall (st :: LeiosFetch point eb tx)
       (st' :: LeiosFetch point eb tx).
(ActiveState st, StateTokenI st) =>
Message (LeiosFetch point eb tx) st st'
-> AnyMessage (LeiosFetch point eb tx)
encode :: forall (st :: LeiosFetch point eb tx)
       (st' :: LeiosFetch point eb tx).
(StateTokenI st, ActiveState st) =>
Message (LeiosFetch point eb tx) st st'
-> AnyMessage (LeiosFetch point eb tx)
encode, StateToken st
-> m (DecodeStep
        (AnyMessage (LeiosFetch point eb tx))
        CodecFailure
        m
        (SomeMessage st))
forall (st :: LeiosFetch point eb tx).
ActiveState st =>
StateToken st
-> m (DecodeStep
        (AnyMessage (LeiosFetch point eb tx))
        CodecFailure
        m
        (SomeMessage st))
decode :: forall (st :: LeiosFetch point eb tx).
ActiveState st =>
StateToken st
-> m (DecodeStep
        (AnyMessage (LeiosFetch point eb tx))
        CodecFailure
        m
        (SomeMessage st))
decode :: forall (st :: LeiosFetch point eb tx).
ActiveState st =>
StateToken st
-> m (DecodeStep
        (AnyMessage (LeiosFetch point eb tx))
        CodecFailure
        m
        (SomeMessage st))
decode}
 where
  encode ::
    forall st st'.
    ( ActiveState st
    , StateTokenI st
    ) =>
    Message (LeiosFetch point eb tx) st st' ->
    AnyMessage (LeiosFetch point eb tx)
  encode :: forall (st :: LeiosFetch point eb tx)
       (st' :: LeiosFetch point eb tx).
(ActiveState st, StateTokenI st) =>
Message (LeiosFetch point eb tx) st st'
-> AnyMessage (LeiosFetch point eb tx)
encode = Message (LeiosFetch point eb tx) st st'
-> AnyMessage (LeiosFetch point eb tx)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage

  decode ::
    forall (st :: LeiosFetch point eb tx).
    ActiveState st =>
    StateToken st ->
    m
      ( DecodeStep
          (AnyMessage (LeiosFetch point eb tx))
          CodecFailure
          m
          (SomeMessage st)
      )
  decode :: forall (st :: LeiosFetch point eb tx).
ActiveState st =>
StateToken st
-> m (DecodeStep
        (AnyMessage (LeiosFetch point eb tx))
        CodecFailure
        m
        (SomeMessage st))
decode StateToken st
stok = DecodeStep
  (AnyMessage (LeiosFetch point eb tx))
  CodecFailure
  m
  (SomeMessage st)
-> m (DecodeStep
        (AnyMessage (LeiosFetch point eb tx))
        CodecFailure
        m
        (SomeMessage st))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DecodeStep
   (AnyMessage (LeiosFetch point eb tx))
   CodecFailure
   m
   (SomeMessage st)
 -> m (DecodeStep
         (AnyMessage (LeiosFetch point eb tx))
         CodecFailure
         m
         (SomeMessage st)))
-> DecodeStep
     (AnyMessage (LeiosFetch point eb tx))
     CodecFailure
     m
     (SomeMessage st)
-> m (DecodeStep
        (AnyMessage (LeiosFetch point eb tx))
        CodecFailure
        m
        (SomeMessage st))
forall a b. (a -> b) -> a -> b
$ (Maybe (AnyMessage (LeiosFetch point eb tx))
 -> m (DecodeStep
         (AnyMessage (LeiosFetch point eb tx))
         CodecFailure
         m
         (SomeMessage st)))
-> DecodeStep
     (AnyMessage (LeiosFetch point eb tx))
     CodecFailure
     m
     (SomeMessage st)
forall bytes failure (m :: * -> *) a.
(Maybe bytes -> m (DecodeStep bytes failure m a))
-> DecodeStep bytes failure m a
DecodePartial ((Maybe (AnyMessage (LeiosFetch point eb tx))
  -> m (DecodeStep
          (AnyMessage (LeiosFetch point eb tx))
          CodecFailure
          m
          (SomeMessage st)))
 -> DecodeStep
      (AnyMessage (LeiosFetch point eb tx))
      CodecFailure
      m
      (SomeMessage st))
-> (Maybe (AnyMessage (LeiosFetch point eb tx))
    -> m (DecodeStep
            (AnyMessage (LeiosFetch point eb tx))
            CodecFailure
            m
            (SomeMessage st)))
-> DecodeStep
     (AnyMessage (LeiosFetch point eb tx))
     CodecFailure
     m
     (SomeMessage st)
forall a b. (a -> b) -> a -> b
$ \Maybe (AnyMessage (LeiosFetch point eb tx))
bytes ->
    DecodeStep
  (AnyMessage (LeiosFetch point eb tx))
  CodecFailure
  m
  (SomeMessage st)
-> m (DecodeStep
        (AnyMessage (LeiosFetch point eb tx))
        CodecFailure
        m
        (SomeMessage st))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DecodeStep
   (AnyMessage (LeiosFetch point eb tx))
   CodecFailure
   m
   (SomeMessage st)
 -> m (DecodeStep
         (AnyMessage (LeiosFetch point eb tx))
         CodecFailure
         m
         (SomeMessage st)))
-> DecodeStep
     (AnyMessage (LeiosFetch point eb tx))
     CodecFailure
     m
     (SomeMessage st)
-> m (DecodeStep
        (AnyMessage (LeiosFetch point eb tx))
        CodecFailure
        m
        (SomeMessage st))
forall a b. (a -> b) -> a -> b
$ case (StateToken st
SingLeiosFetch st
stok, Maybe (AnyMessage (LeiosFetch point eb tx))
bytes) of
      (SingLeiosFetch st
SingIdle, Just (AnyMessage msg :: Message (LeiosFetch point eb tx) st st'
msg@MsgDone{})) ->
        SomeMessage st
-> Maybe (AnyMessage (LeiosFetch point eb tx))
-> DecodeStep
     (AnyMessage (LeiosFetch point eb tx))
     CodecFailure
     m
     (SomeMessage st)
forall bytes failure (m :: * -> *) a.
a -> Maybe bytes -> DecodeStep bytes failure m a
DecodeDone (Message (LeiosFetch point eb tx) st st' -> SomeMessage st
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
Message ps st st' -> SomeMessage st
SomeMessage Message (LeiosFetch point eb tx) st st'
Message (LeiosFetch point eb tx) st st'
msg) Maybe (AnyMessage (LeiosFetch point eb tx))
forall a. Maybe a
Nothing
      (SingLeiosFetch st
SingIdle, Just (AnyMessage msg :: Message (LeiosFetch point eb tx) st st'
msg@MsgLeiosBlockRequest{})) ->
        SomeMessage st
-> Maybe (AnyMessage (LeiosFetch point eb tx))
-> DecodeStep
     (AnyMessage (LeiosFetch point eb tx))
     CodecFailure
     m
     (SomeMessage st)
forall bytes failure (m :: * -> *) a.
a -> Maybe bytes -> DecodeStep bytes failure m a
DecodeDone (Message (LeiosFetch point eb tx) st st' -> SomeMessage st
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
Message ps st st' -> SomeMessage st
SomeMessage Message (LeiosFetch point eb tx) st st'
Message (LeiosFetch point eb tx) st st'
msg) Maybe (AnyMessage (LeiosFetch point eb tx))
forall a. Maybe a
Nothing
      (SingLeiosFetch st
SingBlock, Just (AnyMessage msg :: Message (LeiosFetch point eb tx) st st'
msg@MsgLeiosBlock{})) ->
        SomeMessage st
-> Maybe (AnyMessage (LeiosFetch point eb tx))
-> DecodeStep
     (AnyMessage (LeiosFetch point eb tx))
     CodecFailure
     m
     (SomeMessage st)
forall bytes failure (m :: * -> *) a.
a -> Maybe bytes -> DecodeStep bytes failure m a
DecodeDone (Message (LeiosFetch point eb tx) st st' -> SomeMessage st
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
Message ps st st' -> SomeMessage st
SomeMessage Message (LeiosFetch point eb tx) st st'
Message (LeiosFetch point eb tx) st st'
msg) Maybe (AnyMessage (LeiosFetch point eb tx))
forall a. Maybe a
Nothing
      (SingLeiosFetch st
SingIdle, Just (AnyMessage msg :: Message (LeiosFetch point eb tx) st st'
msg@MsgLeiosBlockTxsRequest{})) ->
        SomeMessage st
-> Maybe (AnyMessage (LeiosFetch point eb tx))
-> DecodeStep
     (AnyMessage (LeiosFetch point eb tx))
     CodecFailure
     m
     (SomeMessage st)
forall bytes failure (m :: * -> *) a.
a -> Maybe bytes -> DecodeStep bytes failure m a
DecodeDone (Message (LeiosFetch point eb tx) st st' -> SomeMessage st
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
Message ps st st' -> SomeMessage st
SomeMessage Message (LeiosFetch point eb tx) st st'
Message (LeiosFetch point eb tx) st st'
msg) Maybe (AnyMessage (LeiosFetch point eb tx))
forall a. Maybe a
Nothing
      (SingLeiosFetch st
SingBlockTxs, Just (AnyMessage msg :: Message (LeiosFetch point eb tx) st st'
msg@MsgLeiosBlockTxs{})) ->
        SomeMessage st
-> Maybe (AnyMessage (LeiosFetch point eb tx))
-> DecodeStep
     (AnyMessage (LeiosFetch point eb tx))
     CodecFailure
     m
     (SomeMessage st)
forall bytes failure (m :: * -> *) a.
a -> Maybe bytes -> DecodeStep bytes failure m a
DecodeDone (Message (LeiosFetch point eb tx) st st' -> SomeMessage st
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
Message ps st st' -> SomeMessage st
SomeMessage Message (LeiosFetch point eb tx) st st'
Message (LeiosFetch point eb tx) st st'
msg) Maybe (AnyMessage (LeiosFetch point eb tx))
forall a. Maybe a
Nothing
      (SingLeiosFetch st
SingDone, Maybe (AnyMessage (LeiosFetch point eb tx))
_) ->
        StateToken 'StDone -> forall a. a
forall ps (st :: ps).
(StateAgency st ~ 'NobodyAgency, ActiveState st) =>
StateToken st -> forall a. a
notActiveState StateToken st
StateToken 'StDone
stok
      (SingLeiosFetch st
_, Maybe (AnyMessage (LeiosFetch point eb tx))
_) ->
        CodecFailure
-> DecodeStep
     (AnyMessage (LeiosFetch point eb tx))
     CodecFailure
     m
     (SomeMessage st)
forall bytes failure (m :: * -> *) a.
failure -> DecodeStep bytes failure m a
DecodeFail (CodecFailure
 -> DecodeStep
      (AnyMessage (LeiosFetch point eb tx))
      CodecFailure
      m
      (SomeMessage st))
-> CodecFailure
-> DecodeStep
     (AnyMessage (LeiosFetch point eb tx))
     CodecFailure
     m
     (SomeMessage st)
forall a b. (a -> b) -> a -> b
$ String -> CodecFailure
CodecFailure String
"codecLeiosFetchId: no matching message"

-----

-- | Always the indefinite-length map, as the cardano-blueprint writes it. Using
-- the definite-length encoding for small maps, as the ledger does, could only
-- ever save one byte.
encodeBitmaps :: TxBitmaps -> CBOR.Encoding
encodeBitmaps :: [(Word16, Word64)] -> Encoding
encodeBitmaps [(Word16, Word64)]
bitmaps =
  Encoding
CBOR.encodeMapLenIndef
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ((Word16, Word64) -> Encoding -> Encoding)
-> Encoding -> [(Word16, Word64)] -> Encoding
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
      (\(Word16
index, Word64
bitmap) Encoding
r -> Word16 -> Encoding
CBOR.encodeWord16 Word16
index Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word64 -> Encoding
CBOR.encodeWord64 Word64
bitmap Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
r)
      Encoding
CBOR.encodeBreak
      [(Word16, Word64)]
bitmaps

-- | The most bitmap entries it takes to cover @maxTxs@ txs, 64 txs to an entry.
maxBitmapEntries :: Int -> Int
maxBitmapEntries :: Int -> Int
maxBitmapEntries Int
maxTxs = (Int
maxTxs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
63) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
64

-- | Decode at most enough bitmaps to cover @maxTxs@ txs. Each bitmap must be
-- non-zero. The indices must be strictly ascending, and each must be below
-- 'maxBitmapEntries'.
--
-- Accepts either CBOR map encoding. We encode the indefinite one, but a decoder
-- that rejects the definite one would reject a peer that is within spec. A
-- declared length is checked before the loop, so neither form reads more
-- entries than the cap.
decodeBitmaps :: Int -> CBOR.Decoder s TxBitmaps
decodeBitmaps :: forall s. Int -> Decoder s [(Word16, Word64)]
decodeBitmaps Int
maxTxs =
  Decoder s (Maybe Int)
forall s. Decoder s (Maybe Int)
CBOR.decodeMapLenOrIndef Decoder s (Maybe Int)
-> (Maybe Int -> Decoder s [(Word16, Word64)])
-> Decoder s [(Word16, Word64)]
forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Int
Nothing -> (Int -> Decoder s Bool)
-> Int
-> Maybe Word16
-> [(Word16, Word64)]
-> Decoder s [(Word16, Word64)]
go (Decoder s Bool -> Int -> Decoder s Bool
forall a b. a -> b -> a
const Decoder s Bool
forall s. Decoder s Bool
CBOR.decodeBreakOr) Int
0 Maybe Word16
forall a. Maybe a
Nothing []
    Just Int
n
      | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxEntries -> String -> Decoder s [(Word16, Word64)]
forall a. HasCallStack => String -> Decoder s a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail String
tooManyEntries
      | Bool
otherwise -> (Int -> Decoder s Bool)
-> Int
-> Maybe Word16
-> [(Word16, Word64)]
-> Decoder s [(Word16, Word64)]
go (\Int
k -> Bool -> Decoder s Bool
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n)) Int
0 Maybe Word16
forall a. Maybe a
Nothing []
 where
  maxEntries :: Int
maxEntries = Int -> Int
maxBitmapEntries Int
maxTxs
  tooManyEntries :: String
tooManyEntries = String
"TxBitmaps: more than " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
maxEntries String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" entries"
  -- 'done' is how the two encodings differ: a break byte, or the declared count.
  go :: (Int -> Decoder s Bool)
-> Int
-> Maybe Word16
-> [(Word16, Word64)]
-> Decoder s [(Word16, Word64)]
go Int -> Decoder s Bool
done !Int
k Maybe Word16
mbPrevIndex [(Word16, Word64)]
acc =
    Int -> Decoder s Bool
done Int
k Decoder s Bool
-> (Bool -> Decoder s [(Word16, Word64)])
-> Decoder s [(Word16, Word64)]
forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
True -> [(Word16, Word64)] -> Decoder s [(Word16, Word64)]
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Word16, Word64)] -> [(Word16, Word64)]
forall a. [a] -> [a]
reverse [(Word16, Word64)]
acc)
      Bool
False
        | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxEntries -> String -> Decoder s [(Word16, Word64)]
forall a. HasCallStack => String -> Decoder s a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail String
tooManyEntries
        | Bool
otherwise -> do
            index <- Decoder s Word16
forall s. Decoder s Word16
CBOR.decodeWord16
            bitmap <- CBOR.decodeWord64
            when (bitmap == 0) $
              fail $
                "TxBitmaps: bitmap at index " <> show index <> " is zero"
            when (fromIntegral index >= maxEntries) $
              fail $
                "TxBitmaps: index " <> show index <> " is not below " <> show maxEntries
            when (maybe False (index <=) mbPrevIndex) $
              fail $
                "TxBitmaps: index " <> show index <> " is not strictly ascending"
            go done (k + 1 :: Int) (Just index) ((index, bitmap) : acc)