{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}

-- | Injecting a transaction from one block type to another
module Ouroboros.Consensus.HardFork.Combinator.InjectTxs
  ( TxsToApply (..)
  , rematchValidatedTxs
  , matchTx
  ) where

import Cardano.Binary (fromCBOR, toCBOR)
import Codec.CBOR.Read
import Codec.CBOR.Write
import Data.Bifunctor (second)
import Data.ByteString.Lazy as BS
import Data.Functor.Product
import qualified Data.List as L
import qualified Data.SOP as LazySOP
import Data.SOP.BasicFunctors
import Data.SOP.Constraint
import qualified Data.SOP.Dict as Dict
import qualified Data.SOP.Match as Match
import Data.SOP.Strict
import qualified Data.SOP.Telescope as Tele
import Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock
import Ouroboros.Consensus.HardFork.Combinator.AcrossEras
import Ouroboros.Consensus.HardFork.Combinator.Basics
import Ouroboros.Consensus.HardFork.Combinator.Info
import qualified Ouroboros.Consensus.HardFork.Combinator.State as State
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.SupportsMempool
import Ouroboros.Consensus.TypeFamilyWrappers

-- | How the re-matched transactions must be applied at the ledger tip era.
--
-- Either we translate all and need to use 'ApplyTxs' or we don't translate and
-- we can use 'ReapplyTxs'.
data TxsToApply a b blk
  = -- | The transaction is already in the tip era; its validation evidence
    -- still holds, so it can be reapplied cheaply.
    ReapplyTxs [(WrapValidatedGenTx blk, a, b)]
  | -- | The transaction was upgraded from an earlier era (serialised there and
    -- decoded here as a plain 'GenTx'), losing its validation evidence, so it
    -- must be fully applied again.
    ApplyTxs [(GenTx blk, a, b)]

-- | Re-match a batch of already-validated transactions against a
-- 'State.HardForkState' whose era might have changed, /without/ translating the
-- transactions across eras.
--
-- The ledger state lives in a single era: the tip of the telescope. Walking the
-- telescope era by era, each transaction that belongs to an era we pass (a @Z@
-- at that point) is serialised to CBOR with that era's 'toCBOR' (after forgetting
-- its validation evidence — we can only encode a 'GenTx'). Once we reach the tip,
-- those bytes are decoded with the tip era's 'fromCBOR', as a 'GenTx':
--
--   * a transaction already in the tip era is kept as-is ('ReapplyTxs');
--
--   * a past-era transaction whose bytes decode in the tip era is upgraded
--     ('ApplyTxs'); it must be fully applied since it lost its evidence;
--
--   * a past-era transaction whose bytes do /not/ decode is untranslatable and
--     is reported back as a 'MismatchEraInfo';
--
--   * a transaction from a /later/ era than the tip (the ledger tip retracted)
--     is downgraded to the era of the tip.
--
-- Reports are built with 'Match.matchNS' from the transaction's original era and
-- the ledger tip era, which is why each transaction carries its original era
-- ('NS' 'SingleEraInfo') alongside its serialised bytes.
rematchValidatedTxs ::
  forall xs a b f.
  All SingleEraBlock xs =>
  -- | How to project a validated transaction
  (forall xs0. Validated (GenTx (HardForkBlock xs0)) -> OneEraValidatedGenTx xs0) ->
  -- | HardForkState
  State.HardForkState f xs ->
  -- | List of transactions to re-match
  [(Validated (GenTx (HardForkBlock xs)), a, b)] ->
  ( [(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
  , State.HardForkState (Product f (TxsToApply a b)) xs
  )
rematchValidatedTxs :: forall (xs :: [*]) a b (f :: * -> *).
All SingleEraBlock xs =>
(forall (xs0 :: [*]).
 Validated (GenTx (HardForkBlock xs0)) -> OneEraValidatedGenTx xs0)
-> HardForkState f xs
-> [(Validated (GenTx (HardForkBlock xs)), a, b)]
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    HardForkState (Product f (TxsToApply a b)) xs)
rematchValidatedTxs forall (xs0 :: [*]).
Validated (GenTx (HardForkBlock xs0)) -> OneEraValidatedGenTx xs0
_ HardForkState f xs
hfs [] =
  ([], (forall a. f a -> Product f (TxsToApply a b) a)
-> HardForkState f xs
-> HardForkState (Product f (TxsToApply a b)) xs
forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hmap (\f a
x -> f a -> TxsToApply a b a -> Product f (TxsToApply a b) a
forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair f a
x ([(WrapValidatedGenTx a, a, b)] -> TxsToApply a b a
forall a b blk.
[(WrapValidatedGenTx blk, a, b)] -> TxsToApply a b blk
ReapplyTxs [])) HardForkState f xs
hfs)
rematchValidatedTxs forall (xs0 :: [*]).
Validated (GenTx (HardForkBlock xs0)) -> OneEraValidatedGenTx xs0
projectValidatedTx (State.HardForkState Telescope (K Past) (Current f) xs
tele) [(Validated (GenTx (HardForkBlock xs)), a, b)]
vtxs =
  (Telescope (K Past) (Current (Product f (TxsToApply a b))) xs
 -> HardForkState (Product f (TxsToApply a b)) xs)
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    Telescope (K Past) (Current (Product f (TxsToApply a b))) xs)
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    HardForkState (Product f (TxsToApply a b)) xs)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Telescope (K Past) (Current (Product f (TxsToApply a b))) xs
-> HardForkState (Product f (TxsToApply a b)) xs
forall (f :: * -> *) (xs :: [*]).
Telescope (K Past) (Current f) xs -> HardForkState f xs
State.HardForkState (([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
  Telescope (K Past) (Current (Product f (TxsToApply a b))) xs)
 -> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
     HardForkState (Product f (TxsToApply a b)) xs))
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    Telescope (K Past) (Current (Product f (TxsToApply a b))) xs)
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    HardForkState (Product f (TxsToApply a b)) xs)
forall a b. (a -> b) -> a -> b
$ NP (Dict SingleEraBlock) xs
-> Telescope (K Past) (Current f) xs
-> [ATx xs a b xs]
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    Telescope (K Past) (Current (Product f (TxsToApply a b))) xs)
forall (f1 :: * -> *) (xs' :: [*]).
NP (Dict SingleEraBlock) xs'
-> Telescope f1 (Current f) xs'
-> [ATx xs a b xs']
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    Telescope f1 (Current (Product f (TxsToApply a b))) xs')
go NP (Dict SingleEraBlock) xs
forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l).
(AllN h c xs, HPure h) =>
h (Dict c) xs
Dict.hdicts Telescope (K Past) (Current f) xs
tele [ATx xs a b xs]
vtxs'
 where
  vtxs' :: [ATx xs a b xs]
vtxs' =
    [ (NS WrapValidatedGenTx xs
-> Either ByteString (NS WrapValidatedGenTx xs)
forall a b. b -> Either a b
Right NS WrapValidatedGenTx xs
ns, Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    WrapValidatedGenTx a -> SingleEraInfo a)
-> NS WrapValidatedGenTx xs
-> NS SingleEraInfo xs
forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcmap Proxy SingleEraBlock
proxySingle WrapValidatedGenTx a -> SingleEraInfo a
forall a.
SingleEraBlock a =>
WrapValidatedGenTx a -> SingleEraInfo a
forall blk (proxy :: * -> *).
SingleEraBlock blk =>
proxy blk -> SingleEraInfo blk
forall (proxy :: * -> *). proxy a -> SingleEraInfo a
singleEraInfo NS WrapValidatedGenTx xs
ns, Validated (GenTx (HardForkBlock xs))
tx, a
a, b
b)
    | (Validated (GenTx (HardForkBlock xs))
tx, a
a, b
b) <- [(Validated (GenTx (HardForkBlock xs)), a, b)]
vtxs
    , let ns :: NS WrapValidatedGenTx xs
ns = OneEraValidatedGenTx xs -> NS WrapValidatedGenTx xs
forall (xs :: [*]).
OneEraValidatedGenTx xs -> NS WrapValidatedGenTx xs
getOneEraValidatedGenTx (OneEraValidatedGenTx xs -> NS WrapValidatedGenTx xs)
-> OneEraValidatedGenTx xs -> NS WrapValidatedGenTx xs
forall a b. (a -> b) -> a -> b
$ Validated (GenTx (HardForkBlock xs)) -> OneEraValidatedGenTx xs
forall (xs0 :: [*]).
Validated (GenTx (HardForkBlock xs0)) -> OneEraValidatedGenTx xs0
projectValidatedTx Validated (GenTx (HardForkBlock xs))
tx
    ]

  -- The ledger era (the tip of the telescope) as an 'NS' inhabited exactly at
  -- the ledger's position.
  ledgerEraNS :: NS LedgerEraInfo xs
  ledgerEraNS :: NS LedgerEraInfo xs
ledgerEraNS = Proxy SingleEraBlock
-> (forall a. SingleEraBlock a => Current f a -> LedgerEraInfo a)
-> NS (Current f) xs
-> NS LedgerEraInfo xs
forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcmap Proxy SingleEraBlock
proxySingle (SingleEraInfo a -> LedgerEraInfo a
forall blk. SingleEraInfo blk -> LedgerEraInfo blk
LedgerEraInfo (SingleEraInfo a -> LedgerEraInfo a)
-> (Current f a -> SingleEraInfo a)
-> Current f a
-> LedgerEraInfo a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Current f a -> SingleEraInfo a
forall blk (proxy :: * -> *).
SingleEraBlock blk =>
proxy blk -> SingleEraInfo blk
forall (proxy :: * -> *). proxy a -> SingleEraInfo a
singleEraInfo) (Telescope (K Past) (Current f) xs -> NS (Current f) xs
forall {k} (g :: k -> *) (f :: k -> *) (xs :: [k]).
Telescope g f xs -> NS f xs
Tele.tip Telescope (K Past) (Current f) xs
tele)

  -- Build the mismatch for a transaction whose era differs from the ledger era.
  -- 'Match.matchNS' positions it correctly (earlier or later than the ledger).
  reject :: NS SingleEraInfo xs -> MismatchEraInfo xs
  reject :: NS SingleEraInfo xs -> MismatchEraInfo xs
reject NS SingleEraInfo xs
txEraNS = Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs
forall (xs :: [*]).
Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs
MismatchEraInfo (Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs)
-> Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs
forall a b. (a -> b) -> a -> b
$ case NS SingleEraInfo xs
-> NS LedgerEraInfo xs
-> Either
     (Mismatch SingleEraInfo LedgerEraInfo xs)
     (NS (Product SingleEraInfo LedgerEraInfo) xs)
forall {k} (f :: k -> *) (xs :: [k]) (g :: k -> *).
NS f xs
-> NS g xs -> Either (Mismatch f g xs) (NS (Product f g) xs)
Match.matchNS NS SingleEraInfo xs
txEraNS NS LedgerEraInfo xs
ledgerEraNS of
    Left Mismatch SingleEraInfo LedgerEraInfo xs
mismatch -> Mismatch SingleEraInfo LedgerEraInfo xs
mismatch
    Right NS (Product SingleEraInfo LedgerEraInfo) xs
_ ->
      [Char] -> Mismatch SingleEraInfo LedgerEraInfo xs
forall a. HasCallStack => [Char] -> a
error
        [Char]
"rematchValidatedTxs: expected an era mismatch, but the transaction and \
        \ledger eras agreed; this is a bug"

  go ::
    forall f1 xs'.
    LazySOP.NP (Dict.Dict SingleEraBlock) xs' ->
    Tele.Telescope f1 (State.Current f) xs' ->
    [ATx xs a b xs'] ->
    ( [(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
    , Tele.Telescope f1 (State.Current (Product f (TxsToApply a b))) xs'
    )
  go :: forall (f1 :: * -> *) (xs' :: [*]).
NP (Dict SingleEraBlock) xs'
-> Telescope f1 (Current f) xs'
-> [ATx xs a b xs']
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    Telescope f1 (Current (Product f (TxsToApply a b))) xs')
go NP (Dict SingleEraBlock) xs'
LazySOP.Nil Telescope f1 (Current f) xs'
t [ATx xs a b xs']
_ = case Telescope f1 (Current f) xs'
t of {}
  -- We are passing a past era: serialise the transactions that belong to it
  -- (forgetting their evidence) and forward everything to the next era. The
  -- transform is inlined (rather than a @where@ helper) so that the @Z@ match
  -- stays coupled to the head era brought in scope by the 'Dict' match.
  go (Dict SingleEraBlock x
Dict.Dict LazySOP.:* NP (Dict SingleEraBlock) xs
nextDicts) (Tele.TS f1 x
i Telescope f1 (Current f) xs1
st) [ATx xs a b xs']
txs =
    (Telescope f1 (Current (Product f (TxsToApply a b))) xs
 -> Telescope f1 (Current (Product f (TxsToApply a b))) xs')
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    Telescope f1 (Current (Product f (TxsToApply a b))) xs)
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    Telescope f1 (Current (Product f (TxsToApply a b))) xs')
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (f1 x
-> Telescope f1 (Current (Product f (TxsToApply a b))) xs
-> Telescope f1 (Current (Product f (TxsToApply a b))) (x : xs)
forall {k} (g :: k -> *) (x :: k) (f :: k -> *) (xs1 :: [k]).
g x -> Telescope g f xs1 -> Telescope g f (x : xs1)
Tele.TS f1 x
i) (([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
  Telescope f1 (Current (Product f (TxsToApply a b))) xs)
 -> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
     Telescope f1 (Current (Product f (TxsToApply a b))) xs'))
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    Telescope f1 (Current (Product f (TxsToApply a b))) xs)
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    Telescope f1 (Current (Product f (TxsToApply a b))) xs')
forall a b. (a -> b) -> a -> b
$
      NP (Dict SingleEraBlock) xs
-> Telescope f1 (Current f) xs
-> [ATx xs a b xs]
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    Telescope f1 (Current (Product f (TxsToApply a b))) xs)
forall (f1 :: * -> *) (xs' :: [*]).
NP (Dict SingleEraBlock) xs'
-> Telescope f1 (Current f) xs'
-> [ATx xs a b xs']
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    Telescope f1 (Current (Product f (TxsToApply a b))) xs')
go
        NP (Dict SingleEraBlock) xs
nextDicts
        Telescope f1 (Current f) xs
Telescope f1 (Current f) xs1
st
        [ ( case Either ByteString (NS WrapValidatedGenTx xs')
tx of
              Left ByteString
bs -> ByteString -> Either ByteString (NS WrapValidatedGenTx xs)
forall a b. a -> Either a b
Left ByteString
bs
              Right (Z WrapValidatedGenTx x
t) ->
                ByteString -> Either ByteString (NS WrapValidatedGenTx xs)
forall a b. a -> Either a b
Left (ByteString -> Either ByteString (NS WrapValidatedGenTx xs))
-> (WrapValidatedGenTx x -> ByteString)
-> WrapValidatedGenTx x
-> Either ByteString (NS WrapValidatedGenTx xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoding -> ByteString
toLazyByteString (Encoding -> ByteString)
-> (WrapValidatedGenTx x -> Encoding)
-> WrapValidatedGenTx x
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenTx x -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (GenTx x -> Encoding)
-> (WrapValidatedGenTx x -> GenTx x)
-> WrapValidatedGenTx x
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validated (GenTx x) -> GenTx x
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated (Validated (GenTx x) -> GenTx x)
-> (WrapValidatedGenTx x -> Validated (GenTx x))
-> WrapValidatedGenTx x
-> GenTx x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapValidatedGenTx x -> Validated (GenTx x)
forall blk. WrapValidatedGenTx blk -> Validated (GenTx blk)
unwrapValidatedGenTx (WrapValidatedGenTx x
 -> Either ByteString (NS WrapValidatedGenTx xs))
-> WrapValidatedGenTx x
-> Either ByteString (NS WrapValidatedGenTx xs)
forall a b. (a -> b) -> a -> b
$ WrapValidatedGenTx x
t
              Right (S NS WrapValidatedGenTx xs1
t) -> NS WrapValidatedGenTx xs
-> Either ByteString (NS WrapValidatedGenTx xs)
forall a b. b -> Either a b
Right NS WrapValidatedGenTx xs
NS WrapValidatedGenTx xs1
t
          , NS SingleEraInfo xs
txEraNS
          , Validated (GenTx (HardForkBlock xs))
orig
          , a
a
          , b
b
          )
        | (Either ByteString (NS WrapValidatedGenTx xs')
tx, NS SingleEraInfo xs
txEraNS, Validated (GenTx (HardForkBlock xs))
orig, a
a, b
b) <- [ATx xs a b xs']
txs
        ]
  go (Dict SingleEraBlock x
Dict.Dict LazySOP.:* NP (Dict SingleEraBlock) xs
d) (Tele.TZ (State.Current Bound
start (f x
st :: f blk))) [ATx xs a b xs']
txs0 =
    (TxsToApply a b x
 -> Telescope f1 (Current (Product f (TxsToApply a b))) xs')
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    TxsToApply a b x)
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    Telescope f1 (Current (Product f (TxsToApply a b))) xs')
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Current (Product f (TxsToApply a b)) x
-> Telescope f1 (Current (Product f (TxsToApply a b))) xs'
Current (Product f (TxsToApply a b)) x
-> Telescope f1 (Current (Product f (TxsToApply a b))) (x : xs)
forall {k} (f :: k -> *) (x :: k) (g :: k -> *) (xs1 :: [k]).
f x -> Telescope g f (x : xs1)
Tele.TZ (Current (Product f (TxsToApply a b)) x
 -> Telescope f1 (Current (Product f (TxsToApply a b))) xs')
-> (TxsToApply a b x -> Current (Product f (TxsToApply a b)) x)
-> TxsToApply a b x
-> Telescope f1 (Current (Product f (TxsToApply a b))) xs'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bound
-> Product f (TxsToApply a b) x
-> Current (Product f (TxsToApply a b)) x
forall (f :: * -> *) blk. Bound -> f blk -> Current f blk
State.Current Bound
start (Product f (TxsToApply a b) x
 -> Current (Product f (TxsToApply a b)) x)
-> (TxsToApply a b x -> Product f (TxsToApply a b) x)
-> TxsToApply a b x
-> Current (Product f (TxsToApply a b)) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> TxsToApply a b x -> Product f (TxsToApply a b) x
forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair f x
st) (([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
  TxsToApply a b x)
 -> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
     Telescope f1 (Current (Product f (TxsToApply a b))) xs'))
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    TxsToApply a b x)
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    Telescope f1 (Current (Product f (TxsToApply a b))) xs')
forall a b. (a -> b) -> a -> b
$
      Dict (All SingleEraBlock) xs
-> (All SingleEraBlock xs =>
    ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
     TxsToApply a b x))
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    TxsToApply a b x)
forall {k} (c :: k -> Constraint) (a :: k) r.
Dict c a -> (c a => r) -> r
Dict.withDict (NP (Dict SingleEraBlock) xs -> Dict (All SingleEraBlock) xs
forall {k} (c :: k -> Constraint) (xs :: [k]).
NP (Dict c) xs -> Dict (All c) xs
Dict.all_NP NP (Dict SingleEraBlock) xs
d) ((All SingleEraBlock xs =>
  ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
   TxsToApply a b x))
 -> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
     TxsToApply a b x))
-> (All SingleEraBlock xs =>
    ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
     TxsToApply a b x))
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    TxsToApply a b x)
forall a b. (a -> b) -> a -> b
$
        Acc xs a b x
-> [ATx xs a b xs']
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    TxsToApply a b x)
All SingleEraBlock xs' =>
Acc xs a b x
-> [ATx xs a b xs']
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    TxsToApply a b x)
go' ([], []) [ATx xs a b xs']
txs0
   where
    -- Survivors are accumulated in a single list, preserving the original order
    -- of the transactions, tagged with how each must be applied: 'Left' = kept
    -- validated (reapply), 'Right' = upgraded (fully apply). By the single-era
    -- invariant the tags are uniform, and 'toTxsToApply' turns them into the
    -- matching 'TxsToApply' constructor.
    go' ::
      All SingleEraBlock xs' =>
      Acc xs a b blk ->
      [ATx xs a b xs'] ->
      ( [(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
      , TxsToApply a b blk
      )
    go' :: All SingleEraBlock xs' =>
Acc xs a b x
-> [ATx xs a b xs']
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    TxsToApply a b x)
go' ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
rej, [(Either (WrapValidatedGenTx x) (GenTx x), a, b)]
surv) [] = ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
-> [(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
forall a. [a] -> [a]
L.reverse [(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
rej, [(Either (WrapValidatedGenTx x) (GenTx x), a, b)]
-> TxsToApply a b x
toTxsToApply ([(Either (WrapValidatedGenTx x) (GenTx x), a, b)]
-> [(Either (WrapValidatedGenTx x) (GenTx x), a, b)]
forall a. [a] -> [a]
L.reverse [(Either (WrapValidatedGenTx x) (GenTx x), a, b)]
surv))
    -- A serialised past-era transaction: upgrade it if it decodes in the tip
    -- era, report it as untranslatable otherwise.
    go' ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
rej, [(Either (WrapValidatedGenTx x) (GenTx x), a, b)]
surv) ((Left ByteString
bs, NS SingleEraInfo xs
txEraNS, Validated (GenTx (HardForkBlock xs))
orig, a
a, b
b) : [ATx xs a b xs']
txs) =
      case (forall s. Decoder s (GenTx x))
-> ByteString -> Either DeserialiseFailure (ByteString, GenTx x)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
deserialiseFromBytes Decoder s (GenTx x)
forall s. Decoder s (GenTx x)
forall a s. FromCBOR a => Decoder s a
fromCBOR ByteString
bs of
        Left DeserialiseFailure
_ -> Acc xs a b x
-> [ATx xs a b xs']
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    TxsToApply a b x)
All SingleEraBlock xs' =>
Acc xs a b x
-> [ATx xs a b xs']
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    TxsToApply a b x)
go' ((Validated (GenTx (HardForkBlock xs))
orig, NS SingleEraInfo xs -> MismatchEraInfo xs
reject NS SingleEraInfo xs
txEraNS) (Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)
-> [(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
-> [(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
forall a. a -> [a] -> [a]
: [(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
rej, [(Either (WrapValidatedGenTx x) (GenTx x), a, b)]
surv) [ATx xs a b xs']
txs
        Right (ByteString
rest, GenTx x
t)
          | ByteString -> Bool
BS.null ByteString
rest -> Acc xs a b x
-> [ATx xs a b xs']
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    TxsToApply a b x)
All SingleEraBlock xs' =>
Acc xs a b x
-> [ATx xs a b xs']
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    TxsToApply a b x)
go' ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
rej, (GenTx x -> Either (WrapValidatedGenTx x) (GenTx x)
forall a b. b -> Either a b
Right GenTx x
t, a
a, b
b) (Either (WrapValidatedGenTx x) (GenTx x), a, b)
-> [(Either (WrapValidatedGenTx x) (GenTx x), a, b)]
-> [(Either (WrapValidatedGenTx x) (GenTx x), a, b)]
forall a. a -> [a] -> [a]
: [(Either (WrapValidatedGenTx x) (GenTx x), a, b)]
surv) [ATx xs a b xs']
txs
          | Bool
otherwise -> Acc xs a b x
-> [ATx xs a b xs']
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    TxsToApply a b x)
All SingleEraBlock xs' =>
Acc xs a b x
-> [ATx xs a b xs']
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    TxsToApply a b x)
go' ((Validated (GenTx (HardForkBlock xs))
orig, NS SingleEraInfo xs -> MismatchEraInfo xs
reject NS SingleEraInfo xs
txEraNS) (Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)
-> [(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
-> [(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
forall a. a -> [a] -> [a]
: [(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
rej, [(Either (WrapValidatedGenTx x) (GenTx x), a, b)]
surv) [ATx xs a b xs']
txs
    -- A transaction already in the tip era: kept as-is.
    go' ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
rej, [(Either (WrapValidatedGenTx x) (GenTx x), a, b)]
surv) ((Right (Z WrapValidatedGenTx x
v), NS SingleEraInfo xs
_, Validated (GenTx (HardForkBlock xs))
_, a
a, b
b) : [ATx xs a b xs']
txs) =
      Acc xs a b x
-> [ATx xs a b xs']
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    TxsToApply a b x)
All SingleEraBlock xs' =>
Acc xs a b x
-> [ATx xs a b xs']
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    TxsToApply a b x)
go' ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
rej, (WrapValidatedGenTx x -> Either (WrapValidatedGenTx x) (GenTx x)
forall a b. a -> Either a b
Left WrapValidatedGenTx x
WrapValidatedGenTx x
v, a
a, b
b) (Either (WrapValidatedGenTx x) (GenTx x), a, b)
-> [(Either (WrapValidatedGenTx x) (GenTx x), a, b)]
-> [(Either (WrapValidatedGenTx x) (GenTx x), a, b)]
forall a. a -> [a] -> [a]
: [(Either (WrapValidatedGenTx x) (GenTx x), a, b)]
surv) [ATx xs a b xs']
txs
    -- A transaction from a later era: we try to downgrade it.
    go' ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
rej, [(Either (WrapValidatedGenTx x) (GenTx x), a, b)]
surv) ((Right (S NS WrapValidatedGenTx xs1
tx), NS SingleEraInfo xs
txEraNS, Validated (GenTx (HardForkBlock xs))
orig, a
a, b
b) : [ATx xs a b xs']
txs) =
      let bs :: CollapseTo NS ByteString
bs =
            NS (K ByteString) xs1 -> CollapseTo NS ByteString
forall (xs :: [*]) a.
SListIN NS xs =>
NS (K a) xs -> CollapseTo NS a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NS (K ByteString) xs1 -> CollapseTo NS ByteString)
-> NS (K ByteString) xs1 -> CollapseTo NS ByteString
forall a b. (a -> b) -> a -> b
$
              Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    WrapValidatedGenTx a -> K ByteString a)
-> NS WrapValidatedGenTx xs1
-> NS (K ByteString) xs1
forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcmap Proxy SingleEraBlock
proxySingle (ByteString -> K ByteString a
forall k a (b :: k). a -> K a b
K (ByteString -> K ByteString a)
-> (WrapValidatedGenTx a -> ByteString)
-> WrapValidatedGenTx a
-> K ByteString a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoding -> ByteString
toLazyByteString (Encoding -> ByteString)
-> (WrapValidatedGenTx a -> Encoding)
-> WrapValidatedGenTx a
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenTx a -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (GenTx a -> Encoding)
-> (WrapValidatedGenTx a -> GenTx a)
-> WrapValidatedGenTx a
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validated (GenTx a) -> GenTx a
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated (Validated (GenTx a) -> GenTx a)
-> (WrapValidatedGenTx a -> Validated (GenTx a))
-> WrapValidatedGenTx a
-> GenTx a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapValidatedGenTx a -> Validated (GenTx a)
forall blk. WrapValidatedGenTx blk -> Validated (GenTx blk)
unwrapValidatedGenTx) NS WrapValidatedGenTx xs1
tx
       in case (forall s. Decoder s (GenTx x))
-> ByteString -> Either DeserialiseFailure (ByteString, GenTx x)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
deserialiseFromBytes Decoder s (GenTx x)
forall s. Decoder s (GenTx x)
forall a s. FromCBOR a => Decoder s a
fromCBOR ByteString
CollapseTo NS ByteString
bs of
            Left DeserialiseFailure
_ -> Acc xs a b x
-> [ATx xs a b xs']
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    TxsToApply a b x)
All SingleEraBlock xs' =>
Acc xs a b x
-> [ATx xs a b xs']
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    TxsToApply a b x)
go' ((Validated (GenTx (HardForkBlock xs))
orig, NS SingleEraInfo xs -> MismatchEraInfo xs
reject NS SingleEraInfo xs
txEraNS) (Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)
-> [(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
-> [(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
forall a. a -> [a] -> [a]
: [(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
rej, [(Either (WrapValidatedGenTx x) (GenTx x), a, b)]
surv) [ATx xs a b xs']
txs
            Right (ByteString
rest, GenTx x
t)
              | ByteString -> Bool
BS.null ByteString
rest -> Acc xs a b x
-> [ATx xs a b xs']
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    TxsToApply a b x)
All SingleEraBlock xs' =>
Acc xs a b x
-> [ATx xs a b xs']
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    TxsToApply a b x)
go' ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
rej, (GenTx x -> Either (WrapValidatedGenTx x) (GenTx x)
forall a b. b -> Either a b
Right GenTx x
t, a
a, b
b) (Either (WrapValidatedGenTx x) (GenTx x), a, b)
-> [(Either (WrapValidatedGenTx x) (GenTx x), a, b)]
-> [(Either (WrapValidatedGenTx x) (GenTx x), a, b)]
forall a. a -> [a] -> [a]
: [(Either (WrapValidatedGenTx x) (GenTx x), a, b)]
surv) [ATx xs a b xs']
txs
              | Bool
otherwise -> Acc xs a b x
-> [ATx xs a b xs']
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    TxsToApply a b x)
All SingleEraBlock xs' =>
Acc xs a b x
-> [ATx xs a b xs']
-> ([(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)],
    TxsToApply a b x)
go' ((Validated (GenTx (HardForkBlock xs))
orig, NS SingleEraInfo xs -> MismatchEraInfo xs
reject NS SingleEraInfo xs
txEraNS) (Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)
-> [(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
-> [(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
forall a. a -> [a] -> [a]
: [(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
rej, [(Either (WrapValidatedGenTx x) (GenTx x), a, b)]
surv) [ATx xs a b xs']
txs

    -- Collapse the ordered, tagged survivors into a single 'TxsToApply'. The
    -- fold preserves order; a mix of tags would violate the single-era invariant.
    toTxsToApply ::
      [(Either (WrapValidatedGenTx blk) (GenTx blk), a, b)] -> TxsToApply a b blk
    toTxsToApply :: [(Either (WrapValidatedGenTx x) (GenTx x), a, b)]
-> TxsToApply a b x
toTxsToApply = ((Either (WrapValidatedGenTx x) (GenTx x), a, b)
 -> TxsToApply a b x -> TxsToApply a b x)
-> TxsToApply a b x
-> [(Either (WrapValidatedGenTx x) (GenTx x), a, b)]
-> TxsToApply a b x
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
L.foldr (Either (WrapValidatedGenTx x) (GenTx x), a, b)
-> TxsToApply a b x -> TxsToApply a b x
forall {blk} {a} {b}.
(Either (WrapValidatedGenTx blk) (GenTx blk), a, b)
-> TxsToApply a b blk -> TxsToApply a b blk
step ([(WrapValidatedGenTx x, a, b)] -> TxsToApply a b x
forall a b blk.
[(WrapValidatedGenTx blk, a, b)] -> TxsToApply a b blk
ReapplyTxs [])
     where
      step :: (Either (WrapValidatedGenTx blk) (GenTx blk), a, b)
-> TxsToApply a b blk -> TxsToApply a b blk
step (Left WrapValidatedGenTx blk
v, a
a, b
b) (ReapplyTxs [(WrapValidatedGenTx blk, a, b)]
vs) = [(WrapValidatedGenTx blk, a, b)] -> TxsToApply a b blk
forall a b blk.
[(WrapValidatedGenTx blk, a, b)] -> TxsToApply a b blk
ReapplyTxs ((WrapValidatedGenTx blk
v, a
a, b
b) (WrapValidatedGenTx blk, a, b)
-> [(WrapValidatedGenTx blk, a, b)]
-> [(WrapValidatedGenTx blk, a, b)]
forall a. a -> [a] -> [a]
: [(WrapValidatedGenTx blk, a, b)]
vs)
      step (Right GenTx blk
t, a
a, b
b) (ReapplyTxs []) = [(GenTx blk, a, b)] -> TxsToApply a b blk
forall a b blk. [(GenTx blk, a, b)] -> TxsToApply a b blk
ApplyTxs [(GenTx blk
t, a
a, b
b)]
      step (Right GenTx blk
t, a
a, b
b) (ApplyTxs [(GenTx blk, a, b)]
ts) = [(GenTx blk, a, b)] -> TxsToApply a b blk
forall a b blk. [(GenTx blk, a, b)] -> TxsToApply a b blk
ApplyTxs ((GenTx blk
t, a
a, b
b) (GenTx blk, a, b) -> [(GenTx blk, a, b)] -> [(GenTx blk, a, b)]
forall a. a -> [a] -> [a]
: [(GenTx blk, a, b)]
ts)
      step (Either (WrapValidatedGenTx blk) (GenTx blk), a, b)
_ TxsToApply a b blk
_ =
        [Char] -> TxsToApply a b blk
forall a. HasCallStack => [Char] -> a
error [Char]
"rematchValidatedTxs: the batch spans more than one era; this is a bug"

type Acc xs a b blk =
  ( [(Validated (GenTx (HardForkBlock xs)), MismatchEraInfo xs)]
  , [(Either (WrapValidatedGenTx blk) (GenTx blk), a, b)]
  )

-- | A transaction being re-matched, as it travels down the telescope.
--
-- The first component is either the CBOR bytes of a transaction from an era we
-- have already passed, or the (era-tagged) validated transaction for the eras we
-- have not reached yet. The second component records the transaction's original
-- era over the whole @xs@, used to report a 'MismatchEraInfo' if untranslatable
-- or from a later era.
type ATx xs a b xs' =
  ( Either ByteString (NS WrapValidatedGenTx xs')
  , NS SingleEraInfo xs
  , Validated (GenTx (HardForkBlock xs))
  , a
  , b
  )

matchTx ::
  All SingleEraBlock xs =>
  NS GenTx xs ->
  State.HardForkState f xs ->
  Either (MismatchEraInfo xs) (State.HardForkState (Product f GenTx) xs)
matchTx :: forall (xs :: [*]) (f :: * -> *).
All SingleEraBlock xs =>
NS GenTx xs
-> HardForkState f xs
-> Either (MismatchEraInfo xs) (HardForkState (Product f GenTx) xs)
matchTx NS GenTx xs
tx (State.HardForkState Telescope (K Past) (Current f) xs
tele) =
  case NS GenTx xs
-> Telescope (K Past) (Current f) xs
-> Either
     (Mismatch GenTx (Current f) xs)
     (Telescope (K Past) (Product GenTx (Current f)) xs)
forall {k} (h :: k -> *) (xs :: [k]) (g :: k -> *) (f :: k -> *).
NS h xs
-> Telescope g f xs
-> Either (Mismatch h f xs) (Telescope g (Product h f) xs)
Match.matchTelescope NS GenTx xs
tx Telescope (K Past) (Current f) xs
tele of
    -- Transaction and state are in the same era
    Right Telescope (K Past) (Product GenTx (Current f)) xs
m -> HardForkState (Product f GenTx) xs
-> Either (MismatchEraInfo xs) (HardForkState (Product f GenTx) xs)
forall a b. b -> Either a b
Right (HardForkState (Product f GenTx) xs
 -> Either
      (MismatchEraInfo xs) (HardForkState (Product f GenTx) xs))
-> (Telescope (K Past) (Product GenTx (Current f)) xs
    -> HardForkState (Product f GenTx) xs)
-> Telescope (K Past) (Product GenTx (Current f)) xs
-> Either (MismatchEraInfo xs) (HardForkState (Product f GenTx) xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Telescope (K Past) (Current (Product f GenTx)) xs
-> HardForkState (Product f GenTx) xs
forall (f :: * -> *) (xs :: [*]).
Telescope (K Past) (Current f) xs -> HardForkState f xs
State.HardForkState (Telescope (K Past) (Current (Product f GenTx)) xs
 -> HardForkState (Product f GenTx) xs)
-> (Telescope (K Past) (Product GenTx (Current f)) xs
    -> Telescope (K Past) (Current (Product f GenTx)) xs)
-> Telescope (K Past) (Product GenTx (Current f)) xs
-> HardForkState (Product f GenTx) xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a.
 Product GenTx (Current f) a -> Current (Product f GenTx) a)
-> Telescope (K Past) (Product GenTx (Current f)) xs
-> Telescope (K Past) (Current (Product f GenTx)) xs
forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hmap Product GenTx (Current f) a -> Current (Product f GenTx) a
forall a.
Product GenTx (Current f) a -> Current (Product f GenTx) a
forall (f :: * -> *) a.
Product GenTx (Current f) a -> Current (Product f GenTx) a
flipCurrAndProd (Telescope (K Past) (Product GenTx (Current f)) xs
 -> Either
      (MismatchEraInfo xs) (HardForkState (Product f GenTx) xs))
-> Telescope (K Past) (Product GenTx (Current f)) xs
-> Either (MismatchEraInfo xs) (HardForkState (Product f GenTx) xs)
forall a b. (a -> b) -> a -> b
$ Telescope (K Past) (Product GenTx (Current f)) xs
m
    -- Transaction and state are in different eras
    Left Mismatch GenTx (Current f) xs
mm ->
      case HardForkState (Maybe :.: Product f GenTx) xs
-> Maybe (HardForkState (Product f GenTx) xs)
forall (m :: * -> *) (f :: * -> *) (xs :: [*]).
(All Top xs, Functor m) =>
HardForkState (m :.: f) xs -> m (HardForkState f xs)
State.sequenceHardForkState (HardForkState (Maybe :.: Product f GenTx) xs
 -> Maybe (HardForkState (Product f GenTx) xs))
-> HardForkState (Maybe :.: Product f GenTx) xs
-> Maybe (HardForkState (Product f GenTx) xs)
forall a b. (a -> b) -> a -> b
$ Telescope (K Past) (Current (Maybe :.: Product f GenTx)) xs
-> HardForkState (Maybe :.: Product f GenTx) xs
forall (f :: * -> *) (xs :: [*]).
Telescope (K Past) (Current f) xs -> HardForkState f xs
State.HardForkState (Telescope (K Past) (Current (Maybe :.: Product f GenTx)) xs
 -> HardForkState (Maybe :.: Product f GenTx) xs)
-> Telescope (K Past) (Current (Maybe :.: Product f GenTx)) xs
-> HardForkState (Maybe :.: Product f GenTx) xs
forall a b. (a -> b) -> a -> b
$ Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    Current f a -> Current (Maybe :.: Product f GenTx) a)
-> Telescope (K Past) (Current f) xs
-> Telescope (K Past) (Current (Maybe :.: Product f GenTx)) xs
forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcmap Proxy SingleEraBlock
proxySingle Current f a -> Current (Maybe :.: Product f GenTx) a
forall a.
SingleEraBlock a =>
Current f a -> Current (Maybe :.: Product f GenTx) a
forall blk (f :: * -> *).
SingleEraBlock blk =>
Current f blk -> Current (Maybe :.: Product f GenTx) blk
de Telescope (K Past) (Current f) xs
tele of
        -- Tx failed to deserialise in the target era
        Maybe (HardForkState (Product f GenTx) xs)
Nothing ->
          MismatchEraInfo xs
-> Either (MismatchEraInfo xs) (HardForkState (Product f GenTx) xs)
forall a b. a -> Either a b
Left
            (MismatchEraInfo xs
 -> Either
      (MismatchEraInfo xs) (HardForkState (Product f GenTx) xs))
-> (Mismatch GenTx (Current f) xs -> MismatchEraInfo xs)
-> Mismatch GenTx (Current f) xs
-> Either (MismatchEraInfo xs) (HardForkState (Product f GenTx) xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs
forall (xs :: [*]).
Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs
MismatchEraInfo
            (Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs)
-> (Mismatch GenTx (Current f) xs
    -> Mismatch SingleEraInfo LedgerEraInfo xs)
-> Mismatch GenTx (Current f) xs
-> MismatchEraInfo xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy SingleEraBlock
-> (forall x. SingleEraBlock x => GenTx x -> SingleEraInfo x)
-> (forall x. SingleEraBlock x => Current f x -> LedgerEraInfo x)
-> Mismatch GenTx (Current f) xs
-> Mismatch SingleEraInfo LedgerEraInfo xs
forall {k} (c :: k -> Constraint) (xs :: [k])
       (proxy :: (k -> Constraint) -> *) (f :: k -> *) (f' :: k -> *)
       (g :: k -> *) (g' :: k -> *).
All c xs =>
proxy c
-> (forall (x :: k). c x => f x -> f' x)
-> (forall (x :: k). c x => g x -> g' x)
-> Mismatch f g xs
-> Mismatch f' g' xs
Match.bihcmap Proxy SingleEraBlock
proxySingle GenTx x -> SingleEraInfo x
forall x. SingleEraBlock x => GenTx x -> SingleEraInfo x
forall blk (proxy :: * -> *).
SingleEraBlock blk =>
proxy blk -> SingleEraInfo blk
forall (proxy :: * -> *). proxy x -> SingleEraInfo x
singleEraInfo (SingleEraInfo x -> LedgerEraInfo x
forall blk. SingleEraInfo blk -> LedgerEraInfo blk
LedgerEraInfo (SingleEraInfo x -> LedgerEraInfo x)
-> (Current f x -> SingleEraInfo x)
-> Current f x
-> LedgerEraInfo x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Current f x -> SingleEraInfo x
forall blk (proxy :: * -> *).
SingleEraBlock blk =>
proxy blk -> SingleEraInfo blk
forall (proxy :: * -> *). proxy x -> SingleEraInfo x
singleEraInfo)
            (Mismatch GenTx (Current f) xs
 -> Either
      (MismatchEraInfo xs) (HardForkState (Product f GenTx) xs))
-> Mismatch GenTx (Current f) xs
-> Either (MismatchEraInfo xs) (HardForkState (Product f GenTx) xs)
forall a b. (a -> b) -> a -> b
$ Mismatch GenTx (Current f) xs
mm
        -- Tx deserialised in the target era
        Just HardForkState (Product f GenTx) xs
n -> HardForkState (Product f GenTx) xs
-> Either (MismatchEraInfo xs) (HardForkState (Product f GenTx) xs)
forall a b. b -> Either a b
Right HardForkState (Product f GenTx) xs
n
 where
  flipCurrAndProd :: Product GenTx (State.Current f) a -> State.Current (Product f GenTx) a
  flipCurrAndProd :: forall (f :: * -> *) a.
Product GenTx (Current f) a -> Current (Product f GenTx) a
flipCurrAndProd (Pair GenTx a
a (State.Current Bound
b f a
c)) = Bound -> Product f GenTx a -> Current (Product f GenTx) a
forall (f :: * -> *) blk. Bound -> f blk -> Current f blk
State.Current Bound
b (f a -> GenTx a -> Product f GenTx a
forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair f a
c GenTx a
a)

  ser :: CollapseTo NS ByteString
ser = NS (K ByteString) xs -> CollapseTo NS ByteString
forall (xs :: [*]) a.
SListIN NS xs =>
NS (K a) xs -> CollapseTo NS a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NS (K ByteString) xs -> CollapseTo NS ByteString)
-> NS (K ByteString) xs -> CollapseTo NS ByteString
forall a b. (a -> b) -> a -> b
$ Proxy SingleEraBlock
-> (forall a. SingleEraBlock a => GenTx a -> K ByteString a)
-> NS GenTx xs
-> NS (K ByteString) xs
forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcmap Proxy SingleEraBlock
proxySingle (ByteString -> K ByteString a
forall k a (b :: k). a -> K a b
K (ByteString -> K ByteString a)
-> (GenTx a -> ByteString) -> GenTx a -> K ByteString a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoding -> ByteString
toLazyByteString (Encoding -> ByteString)
-> (GenTx a -> Encoding) -> GenTx a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenTx a -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR) NS GenTx xs
tx
  de ::
    SingleEraBlock blk =>
    State.Current f blk -> State.Current (Maybe :.: Product f GenTx) blk
  de :: forall blk (f :: * -> *).
SingleEraBlock blk =>
Current f blk -> Current (Maybe :.: Product f GenTx) blk
de (State.Current Bound
s f blk
st) = case (forall s. Decoder s (GenTx blk))
-> ByteString -> Either DeserialiseFailure (ByteString, GenTx blk)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
deserialiseFromBytes Decoder s (GenTx blk)
forall s. Decoder s (GenTx blk)
forall a s. FromCBOR a => Decoder s a
fromCBOR ByteString
CollapseTo NS ByteString
ser of
    Left DeserialiseFailure
_ -> Bound
-> (:.:) Maybe (Product f GenTx) blk
-> Current (Maybe :.: Product f GenTx) blk
forall (f :: * -> *) blk. Bound -> f blk -> Current f blk
State.Current Bound
s (Maybe (Product f GenTx blk) -> (:.:) Maybe (Product f GenTx) blk
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp Maybe (Product f GenTx blk)
forall a. Maybe a
Nothing)
    Right (ByteString
rest, GenTx blk
v)
      | ByteString -> Bool
BS.null ByteString
rest -> Bound
-> (:.:) Maybe (Product f GenTx) blk
-> Current (Maybe :.: Product f GenTx) blk
forall (f :: * -> *) blk. Bound -> f blk -> Current f blk
State.Current Bound
s (Maybe (Product f GenTx blk) -> (:.:) Maybe (Product f GenTx) blk
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp (Maybe (Product f GenTx blk) -> (:.:) Maybe (Product f GenTx) blk)
-> (GenTx blk -> Maybe (Product f GenTx blk))
-> GenTx blk
-> (:.:) Maybe (Product f GenTx) blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Product f GenTx blk -> Maybe (Product f GenTx blk)
forall a. a -> Maybe a
Just (Product f GenTx blk -> Maybe (Product f GenTx blk))
-> (GenTx blk -> Product f GenTx blk)
-> GenTx blk
-> Maybe (Product f GenTx blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f blk -> GenTx blk -> Product f GenTx blk
forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair f blk
st (GenTx blk -> (:.:) Maybe (Product f GenTx) blk)
-> GenTx blk -> (:.:) Maybe (Product f GenTx) blk
forall a b. (a -> b) -> a -> b
$ GenTx blk
v)
      | Bool
otherwise -> Bound
-> (:.:) Maybe (Product f GenTx) blk
-> Current (Maybe :.: Product f GenTx) blk
forall (f :: * -> *) blk. Bound -> f blk -> Current f blk
State.Current Bound
s (Maybe (Product f GenTx blk) -> (:.:) Maybe (Product f GenTx) blk
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp Maybe (Product f GenTx blk)
forall a. Maybe a
Nothing)