{-# LANGUAGE DuplicateRecordFields #-}
{-# OPTIONS_GHC -Wno-ambiguous-fields #-}

module Hydra.Model.MockChain where

import Hydra.Cardano.Api hiding (CardanoSigningKey (..), Network, getVerificationKey)
import Hydra.Prelude hiding (Any, label)
import Test.Hydra.Prelude

import Cardano.Api.UTxO qualified as UTxO
import Control.Concurrent.Class.MonadSTM (
  MonadSTM (writeTVar),
  modifyTVar,
  readTQueue,
  readTVarIO,
  throwSTM,
  tryReadTQueue,
  writeTQueue,
  writeTVar,
 )
import Control.Monad.Class.MonadAsync (link)
import Control.Tracer.JSON (Tracer, traceWith)
import Data.Map.Strict qualified as Map
import Data.Secret (Secret)
import Data.Sequence (Seq (Empty, (:|>)))
import Data.Sequence qualified as Seq
import Data.Time (secondsToNominalDiffTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Hydra.API.ServerOutput (getConfirmedSnapshot)
import Hydra.BehaviorSpec (RequeueMode (..), SimulatedChainNetwork (..))
import Hydra.Cardano.Api.Gen (genTxIn)
import Hydra.Cardano.Api.Pretty (renderTxWithUTxO)
import Hydra.Chain (
  Chain (..),
  PostChainTx (
    CloseTx,
    closingSnapshot,
    headId,
    headParameters,
    openVersion
  ),
  PostTxError (FailedToPostTx, failingTx, failureReason),
  initHistory,
 )
import Hydra.Chain.ChainState (ChainSlot (..))
import Hydra.Chain.Direct.Handlers (
  CardanoChainLog (..),
  ChainSyncHandler (..),
  LocalChainState (..),
  SubmitTx,
  chainSyncHandler,
  mkChain,
  newLocalChainState,
  onRollBackward,
  onRollForward,
 )
import Hydra.Chain.Direct.State (ChainContext (..), ChainStateAt (..), initialChainState)
import Hydra.Chain.Direct.TimeHandle (TimeHandle, mkTimeHandle)
import Hydra.Chain.Direct.Wallet (TinyWallet (..))
import Hydra.HeadLogic (
  ClosedState (..),
  HeadState (..),
  IdleState (..),
  Input (..),
  OpenState (..),
 )
import Hydra.Ledger (Ledger (..), ValidationError (..))
import Hydra.Ledger.Cardano (adjustUTxO, fromChainSlot)
import Hydra.Ledger.Cardano.Evaluate (renderEvaluationReport)
import Hydra.Model.Payment (CardanoSigningKey (..))
import Hydra.Network (Network (..))
import Hydra.Network.Message (Message (..))
import Hydra.Node (DraftHydraNode (..), HydraNode (..), NodeStateHandler (..), connect, mkNetworkInput)
import Hydra.Node.Environment (Environment (Environment, depositPeriod, participants, party))
import Hydra.Node.InputQueue (InputQueue (..))
import Hydra.Node.State (ChainPointTime (..), NodeState (..))
import Hydra.NodeSpec (mockServer)
import Hydra.Tx (txId)
import Hydra.Tx.BlueprintTx (mkSimpleBlueprintTx)
import Hydra.Tx.Crypto (HydraKey, getVerificationKey)
import Hydra.Tx.Deposit (observeDepositTx)
import Hydra.Tx.DepositPeriod (DepositPeriod)
import Hydra.Tx.HeadId (HeadId)
import Hydra.Tx.Party (Party (..), deriveParty)
import Hydra.Tx.ScriptRegistry (registryUTxO)
import Hydra.Tx.Snapshot (ConfirmedSnapshot (..))
import Hydra.Tx.Utils (verificationKeyToOnChainId)
import Test.Gen.Cardano.Api.Typed (genBlockHeaderAt)
import Test.Hydra.Ledger (collectTransactions)
import Test.Hydra.Ledger.Cardano.Fixtures (eraHistoryWithoutHorizon, evaluateTx)
import Test.Hydra.Tx.Fixture (defaultPParams, testNetworkId)
import Test.Hydra.Tx.Gen (genScriptRegistry, genTxOutAdaOnly)
import Test.QuickCheck.Hedgehog (hedgehog)

-- | Create a mocked chain which connects nodes through 'ChainSyncHandler' and
-- 'Chain' interfaces. It calls connected chain sync handlers 'onRollForward' on
-- every 'blockTime' and performs 'rollbackAndForward' every couple blocks.
mockChainAndNetwork ::
  forall m.
  ( MonadTimer m
  , MonadAsync m
  , MonadMask m
  , MonadThrow (STM m)
  , MonadLabelledSTM m
  , MonadFork m
  , MonadDelay m
  , MonadTime m
  ) =>
  Tracer m CardanoChainLog ->
  [(Secret (SigningKey HydraKey), CardanoSigningKey)] ->
  m (SimulatedChainNetwork Tx m)
mockChainAndNetwork :: forall (m :: * -> *).
(MonadTimer m, MonadAsync m, MonadMask m, MonadThrow (STM m),
 MonadLabelledSTM m, MonadFork m, MonadDelay m, MonadTime m) =>
Tracer m CardanoChainLog
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> m (SimulatedChainNetwork Tx m)
mockChainAndNetwork Tracer m CardanoChainLog
tr [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys = do
  TVar m [MockHydraNode m]
nodes <- String -> [MockHydraNode m] -> m (TVar m [MockHydraNode m])
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> a -> m (TVar m a)
newLabelledTVarIO String
"mock-chain-nodes" []
  TQueue m Tx
queue <- String -> m (TQueue m Tx)
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> m (TQueue m a)
newLabelledTQueueIO String
"mock-chain-chain-queue"
  TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain <- String
-> (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> m (TVar
        m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO))
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> a -> m (TVar m a)
newLabelledTVarIO String
"mock-chain-state" (ChainSlot
0 :: ChainSlot, Natural
0 :: Natural, Seq (BlockHeader, [Tx], UTxO)
forall a. Seq a
Empty, UTxO
initialUTxO)
  TVar m Word64
latencySeed <- String -> Word64 -> m (TVar m Word64)
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> a -> m (TVar m a)
newLabelledTVarIO String
"mock-network-latency-seed" (Word64
42 :: Word64)
  -- Persisted, totally-ordered network log plus a per-party consumer offset,
  -- mirroring the production etcd network: a node reconnecting after a restart
  -- resumes from its last consumed offset (messages sent while down, or
  -- in-flight at crash time, are re-delivered; already-consumed ones are not
  -- re-processed). See 'connectNode' and 'createMockNetwork'.
  TVar m [(Party, Message Tx)]
networkHistory <- String -> [(Party, Message Tx)] -> m (TVar m [(Party, Message Tx)])
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> a -> m (TVar m a)
newLabelledTVarIO String
"mock-network-history" ([] :: [(Party, Message Tx)])
  TVar m (Map Party Int)
consumerOffsets <- String -> Map Party Int -> m (TVar m (Map Party Int))
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> a -> m (TVar m a)
newLabelledTVarIO String
"mock-network-offsets" (Map Party Int
forall a. Monoid a => a
mempty :: Map Party Int)
  Async m ()
tickThread <- String -> m () -> m (Async m ())
forall (m :: * -> *) a.
MonadAsync m =>
String -> m a -> m (Async m a)
asyncLabelled String
"mock-chain-tick" (TVar m [MockHydraNode m]
-> TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> TQueue m Tx
-> m ()
simulateChain TVar m [MockHydraNode m]
nodes TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain TQueue m Tx
queue)
  Async m () -> m ()
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m) =>
Async m a -> m ()
link Async m ()
tickThread
  SimulatedChainNetwork Tx m -> m (SimulatedChainNetwork Tx m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    SimulatedChainNetwork
      { $sel:connectNode:SimulatedChainNetwork :: DraftHydraNode Tx m -> m (HydraNode Tx m)
connectNode = TVar m Word64
-> TVar m [(Party, Message Tx)]
-> TVar m (Map Party Int)
-> TVar m [MockHydraNode m]
-> TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> TQueue m Tx
-> DraftHydraNode Tx m
-> m (HydraNode Tx m)
connectNode TVar m Word64
latencySeed TVar m [(Party, Message Tx)]
networkHistory TVar m (Map Party Int)
consumerOffsets TVar m [MockHydraNode m]
nodes TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain TQueue m Tx
queue
      , Async m ()
tickThread :: Async m ()
$sel:tickThread:SimulatedChainNetwork :: Async m ()
tickThread
      , rollbackAndForward :: Natural -> m ()
rollbackAndForward = TVar m [MockHydraNode m]
-> TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> Natural
-> m ()
rollbackAndForward TVar m [MockHydraNode m]
nodes TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain
      , $sel:rollbackAndFork:SimulatedChainNetwork :: Natural -> RequeueMode -> m ()
rollbackAndFork = TVar m [MockHydraNode m]
-> TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> TQueue m Tx
-> Natural
-> RequeueMode
-> m ()
rollbackAndFork TVar m [MockHydraNode m]
nodes TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain TQueue m Tx
queue
      , $sel:simulateDeposit:SimulatedChainNetwork :: HeadId -> UTxOType Tx -> UTCTime -> m (TxIdType Tx)
simulateDeposit = TVar m [MockHydraNode m] -> HeadId -> UTxO -> UTCTime -> m TxId
simulateDeposit TVar m [MockHydraNode m]
nodes
      , $sel:closeWithInitialSnapshot:SimulatedChainNetwork :: Party -> m ()
closeWithInitialSnapshot = TVar m [MockHydraNode m] -> Party -> m ()
closeWithInitialSnapshot TVar m [MockHydraNode m]
nodes
      , $sel:getChainHistory:SimulatedChainNetwork :: m [ChainEvent Tx]
getChainHistory = [ChainEvent Tx] -> m [ChainEvent Tx]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      }
 where
  initialUTxO :: UTxO
initialUTxO = UTxO
seedUTxO UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> ScriptRegistry -> UTxO
registryUTxO ScriptRegistry
scriptRegistry

  seedUTxO :: UTxO
  seedUTxO :: UTxO
seedUTxO = [(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
UTxO.fromList [(TxIn
seedInput, (Gen (VerificationKey PaymentKey)
forall a. Arbitrary a => Gen a
arbitrary Gen (VerificationKey PaymentKey)
-> (VerificationKey PaymentKey -> Gen (TxOut CtxUTxO Era))
-> Gen (TxOut CtxUTxO Era)
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= VerificationKey PaymentKey -> Gen (TxOut CtxUTxO Era)
forall ctx. VerificationKey PaymentKey -> Gen (TxOut ctx)
genTxOutAdaOnly) Gen (TxOut CtxUTxO Era) -> Int -> TxOut CtxUTxO Era
forall a. Gen a -> Int -> a
`generateWith` Int
42)]

  seedInput :: TxIn
seedInput = Gen TxIn
genTxIn Gen TxIn -> Int -> TxIn
forall a. Gen a -> Int -> a
`generateWith` Int
42

  ledger :: Ledger Tx
ledger = Ledger Tx
scriptLedger

  Ledger{ChainSlot
-> UTxOType Tx
-> [Tx]
-> Either (Tx, ValidationError) (UTxOType Tx)
applyTransactions :: ChainSlot
-> UTxOType Tx
-> [Tx]
-> Either (Tx, ValidationError) (UTxOType Tx)
$sel:applyTransactions:Ledger :: forall tx.
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions} = Ledger Tx
ledger

  scriptRegistry :: ScriptRegistry
scriptRegistry = Gen ScriptRegistry
genScriptRegistry Gen ScriptRegistry -> Int -> ScriptRegistry
forall a. Gen a -> Int -> a
`generateWith` Int
42

  -- NOTE: We need to modify the environment as 'createHydraNode' was
  -- creating OnChainIds based on hydra keys. Here, however we will be
  -- validating transactions and need to be signing with proper keys.
  -- Consequently the identifiers of participants need to be derived from
  -- the real keys.
  updateEnvironment :: Environment -> Environment
updateEnvironment Environment
env = do
    let vks :: [VerificationKey PaymentKey]
vks = (\(Secret (SigningKey HydraKey)
_, CardanoSigningKey Secret (SigningKey PaymentKey)
sk) -> Secret (SigningKey PaymentKey) -> VerificationKey PaymentKey
forall s k. HasVerificationKey s k => s -> VerificationKey k
getVerificationKey Secret (SigningKey PaymentKey)
sk) ((Secret (SigningKey HydraKey), CardanoSigningKey)
 -> VerificationKey PaymentKey)
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> [VerificationKey PaymentKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys
    Environment
env{participants = verificationKeyToOnChainId <$> vks}

  connectNode :: TVar m Word64
-> TVar m [(Party, Message Tx)]
-> TVar m (Map Party Int)
-> TVar m [MockHydraNode m]
-> TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> TQueue m Tx
-> DraftHydraNode Tx m
-> m (HydraNode Tx m)
connectNode TVar m Word64
latencySeed TVar m [(Party, Message Tx)]
networkHistory TVar m (Map Party Int)
consumerOffsets TVar m [MockHydraNode m]
nodes TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain TQueue m Tx
queue DraftHydraNode Tx m
draftNode = do
    LocalChainState m Tx
localChainState <- ChainStateHistory Tx -> m (LocalChainState m Tx)
forall (m :: * -> *) tx.
(IsChainState tx, MonadLabelledSTM m) =>
ChainStateHistory tx -> m (LocalChainState m tx)
newLocalChainState (ChainStateType Tx -> ChainStateHistory Tx
forall tx.
IsChainState tx =>
ChainStateType tx -> ChainStateHistory tx
initHistory ChainStateType Tx
initialChainState)
    let DraftHydraNode{Environment
env :: Environment
$sel:env:DraftHydraNode :: forall tx (m :: * -> *). DraftHydraNode tx m -> Environment
env} = DraftHydraNode Tx m
draftNode
        Environment{$sel:party:Environment :: Environment -> Party
party = Party
ownParty, DepositPeriod
$sel:depositPeriod:Environment :: Environment -> DepositPeriod
depositPeriod :: DepositPeriod
depositPeriod} = Environment
env
    let vkey :: VerificationKey PaymentKey
vkey = (VerificationKey PaymentKey, [VerificationKey PaymentKey])
-> VerificationKey PaymentKey
forall a b. (a, b) -> a
fst ((VerificationKey PaymentKey, [VerificationKey PaymentKey])
 -> VerificationKey PaymentKey)
-> (VerificationKey PaymentKey, [VerificationKey PaymentKey])
-> VerificationKey PaymentKey
forall a b. (a -> b) -> a -> b
$ Party
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> (VerificationKey PaymentKey, [VerificationKey PaymentKey])
findOwnCardanoKey Party
ownParty [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys
    let ctx :: ChainContext
ctx =
          ChainContext
            { $sel:networkId:ChainContext :: NetworkId
networkId = NetworkId
testNetworkId
            , $sel:ownVerificationKey:ChainContext :: VerificationKey PaymentKey
ownVerificationKey = VerificationKey PaymentKey
vkey
            , Party
ownParty :: Party
$sel:ownParty:ChainContext :: Party
ownParty
            , ScriptRegistry
scriptRegistry :: ScriptRegistry
$sel:scriptRegistry:ChainContext :: ScriptRegistry
scriptRegistry
            }
    -- The time handle follows the mock chain's tip, as a real node's would.
    -- Deposits are drafted at the current slot and so only activate after
    -- 'depositActivation' (5 blocks) — well after their deposit transaction
    -- landed, like in production. With a fixed slot every deposit looked old
    -- enough to activate on the next tick, so deposit and increment landed in
    -- adjacent blocks and no fork could erase one without the other.
    let getTimeHandle :: m TimeHandle
getTimeHandle = do
          (ChainSlot Natural
slotNum, Natural
_, Seq (BlockHeader, [Tx], UTxO)
_, UTxO
_) <- TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
forall a. TVar m a -> m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain
          TimeHandle -> m TimeHandle
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TimeHandle -> m TimeHandle) -> TimeHandle -> m TimeHandle
forall a b. (a -> b) -> a -> b
$ SlotNo -> TimeHandle
timeHandleAt (Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ Natural -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
slotNum)
    let DraftHydraNode{$sel:inputQueue:DraftHydraNode :: forall tx (m :: * -> *).
DraftHydraNode tx m -> InputQueue m (Input tx)
inputQueue = InputQueue{Input Tx -> m ()
enqueue :: Input Tx -> m ()
$sel:enqueue:InputQueue :: forall (m :: * -> *) e. InputQueue m e -> e -> m ()
enqueue}} = DraftHydraNode Tx m
draftNode
    -- Validate transactions on submission and queue them for inclusion if valid.
    let submitTx :: Tx -> m ()
submitTx Tx
tx =
          STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            -- NOTE: Determine the current "view" on the chain (important while
            -- rolled back, before new roll forwards were issued)
            (ChainSlot
slot, Natural
position, Seq (BlockHeader, [Tx], UTxO)
blocks, UTxO
globalUTxO) <- TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> STM m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain
            let utxo :: UTxO
utxo = case Int
-> Seq (BlockHeader, [Tx], UTxO) -> Maybe (BlockHeader, [Tx], UTxO)
forall a. Int -> Seq a -> Maybe a
Seq.lookup (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
position) Seq (BlockHeader, [Tx], UTxO)
blocks of
                  Maybe (BlockHeader, [Tx], UTxO)
Nothing -> UTxO
globalUTxO
                  Just (BlockHeader
_, [Tx]
_, UTxO
blockUTxO) -> UTxO
blockUTxO
            case ChainSlot -> UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
applyTransactions ChainSlot
slot UTxO
utxo [Tx
tx] of
              Left (Tx
_tx, ValidationError{Text
reason :: Text
$sel:reason:ValidationError :: ValidationError -> Text
reason}) ->
                -- A transaction that does not apply is rejected at submission,
                -- as a real cardano-node would: the posting node observes a
                -- 'PostTxError' (see 'processEffect') and the head continues.
                -- This is a legitimate situation e.g. for a settlement
                -- re-posted after a rollback racing its re-landed original.
                PostTxError Tx -> STM m ()
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM
                  FailedToPostTx
                    { $sel:failureReason:NoSeedInput :: Text
failureReason =
                        Text -> Text
forall a. ToText a => a -> Text
toText (Text -> Text) -> ([Text] -> Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
                          [ Text
"MockChain: Invalid tx submitted"
                          , Text
"Slot: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ChainSlot -> Text
forall b a. (Show a, IsString b) => a -> b
show ChainSlot
slot
                          , Text
"Tx: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. ToText a => a -> Text
toText (UTxO -> Tx -> String
renderTxWithUTxO UTxO
utxo Tx
tx)
                          , Text
"Error: \n\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reason
                          ]
                    , $sel:failingTx:NoSeedInput :: Tx
failingTx = Tx
tx
                    }
              Right UTxO
_utxo' ->
                TQueue m Tx -> Tx -> STM m ()
forall a. TQueue m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> a -> STM m ()
writeTQueue TQueue m Tx
queue Tx
tx
    let mockChain :: Chain Tx m
mockChain =
          Tracer m CardanoChainLog
-> ChainContext
-> DepositPeriod
-> (Tx -> m ())
-> m TimeHandle
-> TxIn
-> LocalChainState m Tx
-> Chain Tx m
forall (m :: * -> *).
(MonadTimer m, MonadThrow (STM m)) =>
Tracer m CardanoChainLog
-> ChainContext
-> DepositPeriod
-> SubmitTx m
-> m TimeHandle
-> TxIn
-> LocalChainState m Tx
-> Chain Tx m
createMockChain
            Tracer m CardanoChainLog
tr
            ChainContext
ctx
            DepositPeriod
depositPeriod
            Tx -> m ()
submitTx
            m TimeHandle
getTimeHandle
            TxIn
seedInput
            LocalChainState m Tx
localChainState
    HydraNode Tx m
node <- Chain Tx m
-> Network m (Message Tx)
-> Server Tx m
-> DraftHydraNode Tx m
-> m (HydraNode Tx m)
forall (m :: * -> *) tx.
Monad m =>
Chain tx m
-> Network m (Message tx)
-> Server tx m
-> DraftHydraNode tx m
-> m (HydraNode tx m)
connect Chain Tx m
mockChain (DraftHydraNode Tx m
-> TVar m [(Party, Message Tx)]
-> TVar m [MockHydraNode m]
-> Network m (Message Tx)
forall (m :: * -> *).
(MonadSTM m, MonadTime m) =>
DraftHydraNode Tx m
-> TVar m [(Party, Message Tx)]
-> TVar m [MockHydraNode m]
-> Network m (Message Tx)
createMockNetwork DraftHydraNode Tx m
draftNode TVar m [(Party, Message Tx)]
networkHistory TVar m [MockHydraNode m]
nodes) Server Tx m
forall (m :: * -> *) tx. Monad m => Server tx m
mockServer DraftHydraNode Tx m
draftNode
    let node' :: HydraNode Tx m
node' = (HydraNode Tx m
node :: HydraNode Tx m){env = updateEnvironment env}
    -- Advance this party's consumer offset as a message reaches the node, so a
    -- later reconnect resumes from exactly here (see the network-log replay).
    let bumpOffset :: STM m ()
        bumpOffset :: STM m ()
bumpOffset = TVar m (Map Party Int)
-> (Map Party Int -> Map Party Int) -> STM m ()
forall a. TVar m a -> (a -> a) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
TVar m a -> (a -> a) -> STM m ()
modifyTVar TVar m (Map Party Int)
consumerOffsets ((Int -> Int -> Int)
-> Party -> Int -> Map Party Int -> Map Party Int
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Party
ownParty Int
1)
        -- A fresh random delay in [0, maxNetworkLatency), via Knuth's MMIX LCG
        -- (deterministic, dependency-free).
        nextLatency :: STM m DiffTime
        nextLatency :: STM m DiffTime
nextLatency = do
          Word64
seed <- TVar m Word64 -> STM m Word64
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m Word64
latencySeed
          let seed' :: Word64
seed' = Word64
seed Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
6364136223846793005 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1442695040888963407
          TVar m Word64 -> Word64 -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m Word64
latencySeed Word64
seed'
          DiffTime -> STM m DiffTime
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiffTime -> STM m DiffTime) -> DiffTime -> STM m DiffTime
forall a b. (a -> b) -> a -> b
$ Word64 -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
seed' Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` DiffTime -> Word64
forall b. Integral b => DiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (DiffTime
maxNetworkLatency DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
1_000_000)) DiffTime -> DiffTime -> DiffTime
forall a. Fractional a => a -> a -> a
/ DiffTime
1_000_000
    -- Deliver network messages from this node's mailbox with a random
    -- per-message latency, preserving per-node order; see 'createMockNetwork'.
    -- Latencies overlap (each message is due at its own arrival + latency, and
    -- the single delivery thread only sleeps up to the due time), so a burst
    -- of n messages arrives within 'maxNetworkLatency' — not n times it.
    TQueue m (UTCTime, Party, Message Tx)
mailbox <- String -> m (TQueue m (UTCTime, Party, Message Tx))
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> m (TQueue m a)
newLabelledTQueueIO String
"mock-network-mailbox"
    Async m Any
deliveryThread <- String -> m Any -> m (Async m Any)
forall (m :: * -> *) a.
MonadAsync m =>
String -> m a -> m (Async m a)
asyncLabelled String
"mock-network-delivery" (m Any -> m (Async m Any)) -> m Any -> m (Async m Any)
forall a b. (a -> b) -> a -> b
$
      m () -> m Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m Any) -> m () -> m Any
forall a b. (a -> b) -> a -> b
$ do
        (UTCTime
arrival, Party
sender, Message Tx
msg) <- STM m (UTCTime, Party, Message Tx)
-> m (UTCTime, Party, Message Tx)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (UTCTime, Party, Message Tx)
 -> m (UTCTime, Party, Message Tx))
-> STM m (UTCTime, Party, Message Tx)
-> m (UTCTime, Party, Message Tx)
forall a b. (a -> b) -> a -> b
$ TQueue m (UTCTime, Party, Message Tx)
-> STM m (UTCTime, Party, Message Tx)
forall a. TQueue m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m a
readTQueue TQueue m (UTCTime, Party, Message Tx)
mailbox
        DiffTime
latency <- STM m DiffTime -> m DiffTime
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m DiffTime
nextLatency
        UTCTime
now <- m UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
        let remaining :: DiffTime
remaining = NominalDiffTime -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (NominalDiffTime -> DiffTime) -> NominalDiffTime -> DiffTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (DiffTime -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac DiffTime
latency) UTCTime
arrival UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
now
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DiffTime
remaining DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> DiffTime
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
remaining
        STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m ()
bumpOffset
        Input Tx -> m ()
enqueue (Party -> Message Tx -> Input Tx
forall tx. Party -> Message tx -> Input tx
mkNetworkInput Party
sender Message Tx
msg)
    Async m Any -> m ()
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m) =>
Async m a -> m ()
link Async m Any
deliveryThread
    let mockNode :: MockHydraNode m
mockNode =
          MockHydraNode
            { $sel:node:MockHydraNode :: HydraNode Tx m
node = HydraNode Tx m
node'
            , $sel:chainHandler:MockHydraNode :: ChainSyncHandler m
chainHandler =
                Tracer m CardanoChainLog
-> ChainCallback Tx m
-> (SlotNo -> m TimeHandle)
-> ChainContext
-> LocalChainState m Tx
-> ChainSyncHandler m
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Tracer m CardanoChainLog
-> ChainCallback Tx m
-> (SlotNo -> GetTimeHandle m)
-> ChainContext
-> LocalChainState m Tx
-> ChainSyncHandler m
chainSyncHandler
                  Tracer m CardanoChainLog
tr
                  (Input Tx -> m ()
enqueue (Input Tx -> m ())
-> (ChainEvent Tx -> Input Tx) -> ChainCallback Tx m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainEvent Tx -> Input Tx
forall tx. ChainEvent tx -> Input tx
ChainInput)
                  (m TimeHandle -> SlotNo -> m TimeHandle
forall a b. a -> b -> a
const m TimeHandle
getTimeHandle)
                  ChainContext
ctx
                  LocalChainState m Tx
localChainState
            , TQueue m (UTCTime, Party, Message Tx)
mailbox :: TQueue m (UTCTime, Party, Message Tx)
$sel:mailbox:MockHydraNode :: TQueue m (UTCTime, Party, Message Tx)
mailbox
            }
    -- Resume chain sync from the node's recovered chain point, like a real
    -- node re-syncing after a restart. Its head state comes from the event
    -- store, so for each already-served block we either:
    --   * slot <= recovered: rebuild the chain-sync 'localChainState' history
    --     only (the block's stored UTxO is the spendable L1 UTxO at that
    --     point), so a later rollback can resolve to any past state — seeding
    --     just the tip would leave a gap and desync the handler on the next
    --     rollback. No 'onRollForward', which would re-drive the recovered head
    --     state machine.
    --   * slot > recovered: re-observe it (blocks missed while down), which
    --     drives both head state and 'localChainState' via the handler.
    -- A fresh node recovered nothing (slot 0) with no blocks produced yet, so
    -- this is a no-op.
    let HydraNode{$sel:nodeStateHandler:HydraNode :: forall tx (m :: * -> *). HydraNode tx m -> NodeStateHandler tx m
nodeStateHandler = NodeStateHandler{STM m (NodeState Tx)
queryNodeState :: STM m (NodeState Tx)
$sel:queryNodeState:NodeStateHandler :: forall tx (m :: * -> *).
NodeStateHandler tx m -> STM m (NodeState tx)
queryNodeState}} = HydraNode Tx m
node'
    ChainSlot
recoveredSlot <- ChainPointTime -> ChainSlot
currentSlot (ChainPointTime -> ChainSlot)
-> (NodeState Tx -> ChainPointTime) -> NodeState Tx -> ChainSlot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeState Tx -> ChainPointTime
forall tx. NodeState tx -> ChainPointTime
chainPointTime (NodeState Tx -> ChainSlot) -> m (NodeState Tx) -> m ChainSlot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (NodeState Tx) -> m (NodeState Tx)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (NodeState Tx)
queryNodeState
    -- Blocks at or before the recovered slot only rebuild 'localChainState'
    -- (bookkeeping); later blocks — missed while down — are re-observed, which
    -- drives both head state and 'localChainState' via the handler.
    let replayBlock :: (BlockHeader, [Tx], UTxO) -> m ()
        replayBlock :: (BlockHeader, [Tx], UTxO) -> m ()
replayBlock (header :: BlockHeader
header@(BlockHeader SlotNo
slotNo Hash BlockHeader
_ BlockNo
_), [Tx]
txs, UTxO
blockUTxO)
          | SlotNo
slotNo SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> ChainSlot -> SlotNo
fromChainSlot ChainSlot
recoveredSlot = ChainSyncHandler m -> BlockHeader -> [Tx] -> m ()
forall (m :: * -> *).
ChainSyncHandler m -> BlockHeader -> [Tx] -> m ()
onRollForward (MockHydraNode m -> ChainSyncHandler m
forall (m :: * -> *). MockHydraNode m -> ChainSyncHandler m
chainHandler MockHydraNode m
mockNode) BlockHeader
header [Tx]
txs
          | Bool
otherwise = STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ LocalChainState m Tx -> ChainStateType Tx -> STM m ()
forall (m :: * -> *) tx.
LocalChainState m tx -> ChainStateType tx -> STM m ()
pushNew LocalChainState m Tx
localChainState ChainStateAt{$sel:spendableUTxO:ChainStateAt :: UTxO
spendableUTxO = UTxO
blockUTxO, $sel:recordedAt:ChainStateAt :: Maybe ChainPoint
recordedAt = ChainPoint -> Maybe ChainPoint
forall a. a -> Maybe a
Just (BlockHeader -> ChainPoint
getChainPoint BlockHeader
header)}
    (ChainSlot
_, Natural
replayPosition, Seq (BlockHeader, [Tx], UTxO)
replayBlocks, UTxO
_) <- TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
forall a. TVar m a -> m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain
    Seq (BlockHeader, [Tx], UTxO)
-> ((BlockHeader, [Tx], UTxO) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Int
-> Seq (BlockHeader, [Tx], UTxO) -> Seq (BlockHeader, [Tx], UTxO)
forall a. Int -> Seq a -> Seq a
Seq.take (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
replayPosition) Seq (BlockHeader, [Tx], UTxO)
replayBlocks) (BlockHeader, [Tx], UTxO) -> m ()
replayBlock
    -- Register (replacing a previous incarnation of this party's node) and
    -- snapshot the network log in one atomic step, so the log partitions
    -- cleanly: messages already logged are replayed below, later ones reach
    -- the freshly registered mailbox — no message lost or delivered twice.
    ([(Party, Message Tx)]
pastMessages, Int
ownOffset) <- STM m ([(Party, Message Tx)], Int)
-> m ([(Party, Message Tx)], Int)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m ([(Party, Message Tx)], Int)
 -> m ([(Party, Message Tx)], Int))
-> STM m ([(Party, Message Tx)], Int)
-> m ([(Party, Message Tx)], Int)
forall a b. (a -> b) -> a -> b
$ do
      TVar m [MockHydraNode m]
-> ([MockHydraNode m] -> [MockHydraNode m]) -> STM m ()
forall a. TVar m a -> (a -> a) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
TVar m a -> (a -> a) -> STM m ()
modifyTVar TVar m [MockHydraNode m]
nodes ((MockHydraNode m
mockNode :) ([MockHydraNode m] -> [MockHydraNode m])
-> ([MockHydraNode m] -> [MockHydraNode m])
-> [MockHydraNode m]
-> [MockHydraNode m]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MockHydraNode m -> Bool) -> [MockHydraNode m] -> [MockHydraNode m]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (MockHydraNode m -> Bool) -> MockHydraNode m -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Party -> MockHydraNode m -> Bool
matchingParty Party
ownParty))
      [(Party, Message Tx)]
history <- TVar m [(Party, Message Tx)] -> STM m [(Party, Message Tx)]
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m [(Party, Message Tx)]
networkHistory
      Int
offset <- Int -> Party -> Map Party Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Int
0 Party
ownParty (Map Party Int -> Int) -> STM m (Map Party Int) -> STM m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar m (Map Party Int) -> STM m (Map Party Int)
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (Map Party Int)
consumerOffsets
      ([(Party, Message Tx)], Int) -> STM m ([(Party, Message Tx)], Int)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Party, Message Tx)]
history, Int
offset)
    -- Resume the persisted network log from this party's consumer offset,
    -- mirroring a node re-reading the etcd stream from where it left off after
    -- a restart: messages sent while down, or in-flight (delivered to the
    -- mailbox but not yet consumed) at crash time, are re-delivered; ones it
    -- already consumed are not re-processed (which would diverge its ledger).
    -- A first connection has offset 0 and an empty log, so replays nothing.
    let DraftHydraNode{$sel:inputQueue:DraftHydraNode :: forall tx (m :: * -> *).
DraftHydraNode tx m -> InputQueue m (Input tx)
inputQueue = InputQueue{$sel:enqueue:InputQueue :: forall (m :: * -> *) e. InputQueue m e -> e -> m ()
enqueue = Input Tx -> m ()
enqueueOwn}} = DraftHydraNode Tx m
draftNode
    [(Party, Message Tx)] -> ((Party, Message Tx) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Int -> [(Party, Message Tx)] -> [(Party, Message Tx)]
forall a. Int -> [a] -> [a]
drop Int
ownOffset [(Party, Message Tx)]
pastMessages) (((Party, Message Tx) -> m ()) -> m ())
-> ((Party, Message Tx) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(Party
msgSender, Message Tx
msg) -> do
      STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m ()
bumpOffset
      Input Tx -> m ()
enqueueOwn (Input Tx -> m ()) -> Input Tx -> m ()
forall a b. (a -> b) -> a -> b
$ Party -> Message Tx -> Input Tx
forall tx. Party -> Message tx -> Input tx
mkNetworkInput Party
msgSender Message Tx
msg
    -- Re-observe blocks produced during the reconnect above (all past the
    -- recovered slot, so 'replayBlock' re-observes them).
    (ChainSlot
_, Natural
caughtUpPosition, Seq (BlockHeader, [Tx], UTxO)
caughtUpBlocks, UTxO
_) <- TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
forall a. TVar m a -> m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain
    Seq (BlockHeader, [Tx], UTxO)
-> ((BlockHeader, [Tx], UTxO) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Int
-> Seq (BlockHeader, [Tx], UTxO) -> Seq (BlockHeader, [Tx], UTxO)
forall a. Int -> Seq a -> Seq a
Seq.take (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
caughtUpPosition Int -> Int -> Int
forall a. Num a => a -> a -> a
- Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
replayPosition) (Seq (BlockHeader, [Tx], UTxO) -> Seq (BlockHeader, [Tx], UTxO))
-> Seq (BlockHeader, [Tx], UTxO) -> Seq (BlockHeader, [Tx], UTxO)
forall a b. (a -> b) -> a -> b
$ Int
-> Seq (BlockHeader, [Tx], UTxO) -> Seq (BlockHeader, [Tx], UTxO)
forall a. Int -> Seq a -> Seq a
Seq.drop (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
replayPosition) Seq (BlockHeader, [Tx], UTxO)
caughtUpBlocks) (BlockHeader, [Tx], UTxO) -> m ()
replayBlock
    HydraNode Tx m -> m (HydraNode Tx m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HydraNode Tx m
node'

  simulateDeposit :: TVar m [MockHydraNode m] -> HeadId -> UTxO -> UTCTime -> m TxId
  simulateDeposit :: TVar m [MockHydraNode m] -> HeadId -> UTxO -> UTCTime -> m TxId
simulateDeposit TVar m [MockHydraNode m]
nodes HeadId
headId UTxO
utxoToDeposit UTCTime
deadline = do
    -- XXX: Weird that we need a registered node here and cannot just draft the
    -- deposit tx directly?
    -- Draft against an in-sync open node: a node still catching up after a
    -- restart has a stale chain view, so drafting the deposit against it fails
    -- ('CannotFindHeadOutputInIncrement'). Any synced node works — the deposit
    -- is not party-specific.
    TVar m [MockHydraNode m] -> m (Maybe (MockHydraNode m))
findSyncedOpenNode TVar m [MockHydraNode m]
nodes m (Maybe (MockHydraNode m))
-> (Maybe (MockHydraNode m) -> m TxId) -> m TxId
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (MockHydraNode m)
Nothing -> Text -> m TxId
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"simulateDeposit: no in-sync open MockHydraNode"
      Just MockHydraNode{$sel:node:MockHydraNode :: forall (m :: * -> *). MockHydraNode m -> HydraNode Tx m
node = HydraNode{$sel:oc:HydraNode :: forall tx (m :: * -> *). HydraNode tx m -> Chain tx m
oc = Chain{MonadThrow m => Tx -> m ()
submitTx :: MonadThrow m => Tx -> m ()
$sel:submitTx:Chain :: forall tx (m :: * -> *). Chain tx m -> MonadThrow m => tx -> m ()
submitTx, MonadThrow m =>
HeadId
-> PParams LedgerEra
-> ConfirmedSnapshot Tx
-> CommitBlueprintTx Tx
-> UTCTime
-> Maybe AddressInEra
-> m (Either (PostTxError Tx) Tx)
draftDepositTx :: MonadThrow m =>
HeadId
-> PParams LedgerEra
-> ConfirmedSnapshot Tx
-> CommitBlueprintTx Tx
-> UTCTime
-> Maybe AddressInEra
-> m (Either (PostTxError Tx) Tx)
$sel:draftDepositTx:Chain :: forall tx (m :: * -> *).
Chain tx m
-> MonadThrow m =>
   HeadId
   -> PParams LedgerEra
   -> ConfirmedSnapshot tx
   -> CommitBlueprintTx tx
   -> UTCTime
   -> Maybe AddressInEra
   -> m (Either (PostTxError tx) tx)
draftDepositTx}, $sel:nodeStateHandler:HydraNode :: forall tx (m :: * -> *). HydraNode tx m -> NodeStateHandler tx m
nodeStateHandler = NodeStateHandler{STM m (NodeState Tx)
$sel:queryNodeState:NodeStateHandler :: forall tx (m :: * -> *).
NodeStateHandler tx m -> STM m (NodeState tx)
queryNodeState :: STM m (NodeState Tx)
queryNodeState}}} -> do
        ConfirmedSnapshot Tx
currentSnapshot <-
          ConfirmedSnapshot Tx
-> Maybe (ConfirmedSnapshot Tx) -> ConfirmedSnapshot Tx
forall a. a -> Maybe a -> a
fromMaybe InitialSnapshot{HeadId
headId :: HeadId
$sel:headId:InitialSnapshot :: HeadId
headId} (Maybe (ConfirmedSnapshot Tx) -> ConfirmedSnapshot Tx)
-> (NodeState Tx -> Maybe (ConfirmedSnapshot Tx))
-> NodeState Tx
-> ConfirmedSnapshot Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeadState Tx -> Maybe (ConfirmedSnapshot Tx)
forall tx. HeadState tx -> Maybe (ConfirmedSnapshot tx)
getConfirmedSnapshot (HeadState Tx -> Maybe (ConfirmedSnapshot Tx))
-> (NodeState Tx -> HeadState Tx)
-> NodeState Tx
-> Maybe (ConfirmedSnapshot Tx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeState Tx -> HeadState Tx
forall tx. NodeState tx -> HeadState tx
headState (NodeState Tx -> ConfirmedSnapshot Tx)
-> m (NodeState Tx) -> m (ConfirmedSnapshot Tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (NodeState Tx) -> m (NodeState Tx)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (NodeState Tx)
queryNodeState
        MonadThrow m =>
HeadId
-> PParams LedgerEra
-> ConfirmedSnapshot Tx
-> CommitBlueprintTx Tx
-> UTCTime
-> Maybe AddressInEra
-> m (Either (PostTxError Tx) Tx)
HeadId
-> PParams LedgerEra
-> ConfirmedSnapshot Tx
-> CommitBlueprintTx Tx
-> UTCTime
-> Maybe AddressInEra
-> m (Either (PostTxError Tx) Tx)
draftDepositTx HeadId
headId PParams LedgerEra
defaultPParams ConfirmedSnapshot Tx
currentSnapshot (UTxOType Tx -> CommitBlueprintTx Tx
forall tx. IsTx tx => UTxOType tx -> CommitBlueprintTx tx
mkSimpleBlueprintTx UTxOType Tx
UTxO
utxoToDeposit) UTCTime
deadline Maybe AddressInEra
forall a. Maybe a
Nothing m (Either (PostTxError Tx) Tx)
-> (Either (PostTxError Tx) Tx -> m TxId) -> m TxId
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left PostTxError Tx
e -> PostTxError Tx -> m TxId
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO PostTxError Tx
e
          Right Tx
tx -> MonadThrow m => Tx -> m ()
Tx -> m ()
submitTx Tx
tx m () -> TxId -> m TxId
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
Hydra.Tx.txId Tx
tx

  -- \| Wait for and return a node that is both in sync with the chain and has
  -- an open head, retrying briefly (nodes may be mid-catch-up after a restart).
  findSyncedOpenNode :: TVar m [MockHydraNode m] -> m (Maybe (MockHydraNode m))
  findSyncedOpenNode :: TVar m [MockHydraNode m] -> m (Maybe (MockHydraNode m))
findSyncedOpenNode TVar m [MockHydraNode m]
nodes = Int -> m (Maybe (MockHydraNode m))
go (Int
100 :: Int)
   where
    go :: Int -> m (Maybe (MockHydraNode m))
go Int
0 = Maybe (MockHydraNode m) -> m (Maybe (MockHydraNode m))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (MockHydraNode m)
forall a. Maybe a
Nothing
    go Int
n = do
      [MockHydraNode m]
hydraNodes <- TVar m [MockHydraNode m] -> m [MockHydraNode m]
forall a. TVar m a -> m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar m [MockHydraNode m]
nodes
      [MockHydraNode m]
synced <- (MockHydraNode m -> m Bool)
-> [MockHydraNode m] -> m [MockHydraNode m]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM MockHydraNode m -> m Bool
isSyncedOpen [MockHydraNode m]
hydraNodes
      case [MockHydraNode m]
synced of
        (MockHydraNode m
node : [MockHydraNode m]
_) -> Maybe (MockHydraNode m) -> m (Maybe (MockHydraNode m))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MockHydraNode m -> Maybe (MockHydraNode m)
forall a. a -> Maybe a
Just MockHydraNode m
node)
        [] -> DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.1 m () -> m (Maybe (MockHydraNode m)) -> m (Maybe (MockHydraNode m))
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> m (Maybe (MockHydraNode m))
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    isSyncedOpen :: MockHydraNode m -> m Bool
    isSyncedOpen :: MockHydraNode m -> m Bool
isSyncedOpen MockHydraNode{$sel:node:MockHydraNode :: forall (m :: * -> *). MockHydraNode m -> HydraNode Tx m
node = HydraNode{$sel:nodeStateHandler:HydraNode :: forall tx (m :: * -> *). HydraNode tx m -> NodeStateHandler tx m
nodeStateHandler = NodeStateHandler{STM m (NodeState Tx)
$sel:queryNodeState:NodeStateHandler :: forall tx (m :: * -> *).
NodeStateHandler tx m -> STM m (NodeState tx)
queryNodeState :: STM m (NodeState Tx)
queryNodeState}}} =
      STM m (NodeState Tx) -> m (NodeState Tx)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (NodeState Tx)
queryNodeState m (NodeState Tx) -> (NodeState Tx -> Bool) -> m Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        NodeInSync{$sel:headState:NodeInSync :: forall tx. NodeState tx -> HeadState tx
headState = Open{}} -> Bool
True
        NodeState Tx
_ -> Bool
False

  -- REVIEW: Is this still needed now as we have TxTraceSpec?
  closeWithInitialSnapshot :: TVar m [MockHydraNode m] -> Party -> m ()
  closeWithInitialSnapshot :: TVar m [MockHydraNode m] -> Party -> m ()
closeWithInitialSnapshot TVar m [MockHydraNode m]
nodes Party
party = do
    [MockHydraNode m]
hydraNodes <- TVar m [MockHydraNode m] -> m [MockHydraNode m]
forall a. TVar m a -> m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar m [MockHydraNode m]
nodes
    case (MockHydraNode m -> Bool)
-> [MockHydraNode m] -> Maybe (MockHydraNode m)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Party -> MockHydraNode m -> Bool
matchingParty Party
party) [MockHydraNode m]
hydraNodes of
      Maybe (MockHydraNode m)
Nothing -> Text -> m ()
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"closeWithInitialSnapshot: Could not find matching HydraNode"
      Just
        MockHydraNode
          { $sel:node:MockHydraNode :: forall (m :: * -> *). MockHydraNode m -> HydraNode Tx m
node = HydraNode{$sel:oc:HydraNode :: forall tx (m :: * -> *). HydraNode tx m -> Chain tx m
oc = Chain{MonadThrow m => PostChainTx Tx -> m ()
postTx :: MonadThrow m => PostChainTx Tx -> m ()
$sel:postTx:Chain :: forall tx (m :: * -> *).
Chain tx m -> MonadThrow m => PostChainTx tx -> m ()
postTx}, $sel:nodeStateHandler:HydraNode :: forall tx (m :: * -> *). HydraNode tx m -> NodeStateHandler tx m
nodeStateHandler = NodeStateHandler{STM m (NodeState Tx)
$sel:queryNodeState:NodeStateHandler :: forall tx (m :: * -> *).
NodeStateHandler tx m -> STM m (NodeState tx)
queryNodeState :: STM m (NodeState Tx)
queryNodeState}}
          } -> do
          NodeState Tx
nodeState <- STM m (NodeState Tx) -> m (NodeState Tx)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (NodeState Tx)
queryNodeState
          case NodeState Tx -> HeadState Tx
forall tx. NodeState tx -> HeadState tx
headState NodeState Tx
nodeState of
            Idle IdleState{} -> Text -> m ()
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Cannot post Close tx when in Idle state"
            Open OpenState{$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId = HeadId
openHeadId, $sel:parameters:OpenState :: forall tx. OpenState tx -> HeadParameters
parameters = HeadParameters
headParameters} -> do
              MonadThrow m => PostChainTx Tx -> m ()
PostChainTx Tx -> m ()
postTx
                CloseTx
                  { $sel:headId:InitTx :: HeadId
headId = HeadId
openHeadId
                  , HeadParameters
$sel:headParameters:InitTx :: HeadParameters
headParameters :: HeadParameters
headParameters
                  , $sel:openVersion:InitTx :: SnapshotVersion
openVersion = SnapshotVersion
0
                  , $sel:closingSnapshot:InitTx :: ConfirmedSnapshot Tx
closingSnapshot = InitialSnapshot{$sel:headId:InitialSnapshot :: HeadId
headId = HeadId
openHeadId}
                  }
            Closed ClosedState{} -> Text -> m ()
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Cannot post Close tx when in Closed state"
            FanoutProgress{} -> Text -> m ()
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Cannot post Close tx when in FanoutProgress state"

  matchingParty :: Party -> MockHydraNode m -> Bool
  matchingParty :: Party -> MockHydraNode m -> Bool
matchingParty Party
us MockHydraNode{$sel:node:MockHydraNode :: forall (m :: * -> *). MockHydraNode m -> HydraNode Tx m
node = HydraNode{$sel:env:HydraNode :: forall tx (m :: * -> *). HydraNode tx m -> Environment
env = Environment{Party
$sel:party:Environment :: Environment -> Party
party :: Party
party}}} =
    Party
party Party -> Party -> Bool
forall a. Eq a => a -> a -> Bool
== Party
us

  blockTime :: DiffTime
  blockTime :: DiffTime
blockTime = DiffTime
20

  simulateChain :: TVar m [MockHydraNode m]
-> TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> TQueue m Tx
-> m ()
simulateChain TVar m [MockHydraNode m]
nodes TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain TQueue m Tx
queue =
    m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar m [MockHydraNode m]
-> TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> TQueue m Tx
-> m ()
rollForward TVar m [MockHydraNode m]
nodes TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain TQueue m Tx
queue

  rollForward :: TVar m [MockHydraNode m]
-> TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> TQueue m Tx
-> m ()
rollForward TVar m [MockHydraNode m]
nodes TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain TQueue m Tx
queue = do
    DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
blockTime
    [(Tx, Text)]
dropped <- STM m [(Tx, Text)] -> m [(Tx, Text)]
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m [(Tx, Text)] -> m [(Tx, Text)])
-> STM m [(Tx, Text)] -> m [(Tx, Text)]
forall a b. (a -> b) -> a -> b
$ do
      [Tx]
transactions <- TQueue m Tx -> STM m [Tx]
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m [a]
flushQueue TQueue m Tx
queue
      TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> [Tx] -> STM m [(Tx, Text)]
addNewBlockToChain TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain [Tx]
transactions
    -- A real chain drops invalid transactions silently, but an invisible drop
    -- makes test failures undiagnosable: surface each like a failed posting.
    [(Tx, Text)] -> ((Tx, Text) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Tx, Text)]
dropped (((Tx, Text) -> m ()) -> m ()) -> ((Tx, Text) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(Tx
tx, Text
reason) ->
      Tracer m CardanoChainLog -> CardanoChainLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m CardanoChainLog
tr PostingFailed{Tx
tx :: Tx
$sel:tx:ToPost :: Tx
tx, $sel:postTxError:ToPost :: PostTxError Tx
postTxError = FailedToPostTx{$sel:failureReason:NoSeedInput :: Text
failureReason = Text
"MockChain: dropped at block inclusion: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reason, $sel:failingTx:NoSeedInput :: Tx
failingTx = Tx
tx}}
    TVar m [MockHydraNode m]
-> TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> m ()
doRollForward TVar m [MockHydraNode m]
nodes TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain

  doRollForward :: TVar m [MockHydraNode m] -> TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO) -> m ()
  doRollForward :: TVar m [MockHydraNode m]
-> TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> m ()
doRollForward TVar m [MockHydraNode m]
nodes TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain = do
    -- NOTE: Advance the chain state in a single transaction: a separate
    -- read-then-write races concurrent mutations (block production,
    -- rollbacks, forks) and would clobber them with the stale read. The
    -- ledger must also be reset to this utxo before calling the node handlers
    -- (as they might submit transactions directly).
    Maybe (BlockHeader, [Tx])
mServed <- STM m (Maybe (BlockHeader, [Tx])) -> m (Maybe (BlockHeader, [Tx]))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe (BlockHeader, [Tx]))
 -> m (Maybe (BlockHeader, [Tx])))
-> STM m (Maybe (BlockHeader, [Tx]))
-> m (Maybe (BlockHeader, [Tx]))
forall a b. (a -> b) -> a -> b
$ do
      (ChainSlot
slotNum, Natural
position, Seq (BlockHeader, [Tx], UTxO)
blocks, UTxO
_) <- TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> STM m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain
      case Int
-> Seq (BlockHeader, [Tx], UTxO) -> Maybe (BlockHeader, [Tx], UTxO)
forall a. Int -> Seq a -> Maybe a
Seq.lookup (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
position) Seq (BlockHeader, [Tx], UTxO)
blocks of
        Just (BlockHeader
header, [Tx]
txs, UTxO
utxo) -> do
          TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain (ChainSlot
slotNum, Natural
position Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1, Seq (BlockHeader, [Tx], UTxO)
blocks, UTxO
utxo)
          Maybe (BlockHeader, [Tx]) -> STM m (Maybe (BlockHeader, [Tx]))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (BlockHeader, [Tx]) -> STM m (Maybe (BlockHeader, [Tx])))
-> Maybe (BlockHeader, [Tx]) -> STM m (Maybe (BlockHeader, [Tx]))
forall a b. (a -> b) -> a -> b
$ (BlockHeader, [Tx]) -> Maybe (BlockHeader, [Tx])
forall a. a -> Maybe a
Just (BlockHeader
header, [Tx]
txs)
        Maybe (BlockHeader, [Tx], UTxO)
Nothing ->
          Maybe (BlockHeader, [Tx]) -> STM m (Maybe (BlockHeader, [Tx]))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (BlockHeader, [Tx])
forall a. Maybe a
Nothing
    case Maybe (BlockHeader, [Tx])
mServed of
      Just (BlockHeader
header, [Tx]
txs) -> do
        [ChainSyncHandler m]
allHandlers <- (MockHydraNode m -> ChainSyncHandler m)
-> [MockHydraNode m] -> [ChainSyncHandler m]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MockHydraNode m -> ChainSyncHandler m
forall (m :: * -> *). MockHydraNode m -> ChainSyncHandler m
chainHandler ([MockHydraNode m] -> [ChainSyncHandler m])
-> m [MockHydraNode m] -> m [ChainSyncHandler m]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar m [MockHydraNode m] -> m [MockHydraNode m]
forall a. TVar m a -> m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar m [MockHydraNode m]
nodes
        [ChainSyncHandler m] -> (ChainSyncHandler m -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ChainSyncHandler m]
allHandlers (\ChainSyncHandler m
h -> ChainSyncHandler m -> BlockHeader -> [Tx] -> m ()
forall (m :: * -> *).
ChainSyncHandler m -> BlockHeader -> [Tx] -> m ()
onRollForward ChainSyncHandler m
h BlockHeader
header [Tx]
txs)
      Maybe (BlockHeader, [Tx])
Nothing ->
        () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  -- XXX: This should actually work more like a chain fork / switch to longer
  -- chain. That is, the ledger switches to the longer chain state right away
  -- and we issue rollback and forwards to synchronize clients. However,
  -- submission will already validate against the new ledger state.
  rollbackAndForward ::
    TVar m [MockHydraNode m] ->
    TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO) ->
    Natural ->
    m ()
  rollbackAndForward :: TVar m [MockHydraNode m]
-> TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> Natural
-> m ()
rollbackAndForward TVar m [MockHydraNode m]
nodes TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain Natural
numberOfBlocks = do
    TVar m [MockHydraNode m]
-> TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> Natural
-> m ()
doRollBackward TVar m [MockHydraNode m]
nodes TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain Natural
numberOfBlocks
    Int -> m () -> m ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
numberOfBlocks) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      TVar m [MockHydraNode m]
-> TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> m ()
doRollForward TVar m [MockHydraNode m]
nodes TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain
    -- NOTE: There seems to be a race condition on multiple consecutive
    -- rollbackAndForward calls, which would require some minimal (1ms) delay
    -- here. However, waiting here for one blockTime is not wrong and enforces
    -- rollbacks / chain switches to be not more often than blocks being added.
    DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
blockTime

  doRollBackward ::
    TVar m [MockHydraNode m] ->
    TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO) ->
    Natural ->
    m ()
  doRollBackward :: TVar m [MockHydraNode m]
-> TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> Natural
-> m ()
doRollBackward TVar m [MockHydraNode m]
nodes TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain Natural
nbBlocks = do
    -- NOTE: Single transaction for the same reason as in 'doRollForward'.
    Maybe ChainPoint
mPoint <- STM m (Maybe ChainPoint) -> m (Maybe ChainPoint)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe ChainPoint) -> m (Maybe ChainPoint))
-> STM m (Maybe ChainPoint) -> m (Maybe ChainPoint)
forall a b. (a -> b) -> a -> b
$ do
      (ChainSlot
slotNum, Natural
position, Seq (BlockHeader, [Tx], UTxO)
blocks, UTxO
_) <- TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> STM m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain
      -- Roll back exactly @nbBlocks@ blocks: the block before them becomes
      -- the new tip.
      let tipIndex :: Integer
tipIndex = Natural -> Integer
forall a. Integral a => a -> Integer
toInteger Natural
position Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Natural -> Integer
forall a. Integral a => a -> Integer
toInteger Natural
nbBlocks Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1
      if Integer
tipIndex Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0
        then Maybe ChainPoint -> STM m (Maybe ChainPoint)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ChainPoint
forall a. Maybe a
Nothing
        else case Int
-> Seq (BlockHeader, [Tx], UTxO) -> Maybe (BlockHeader, [Tx], UTxO)
forall a. Int -> Seq a -> Maybe a
Seq.lookup (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
tipIndex) Seq (BlockHeader, [Tx], UTxO)
blocks of
          Just (BlockHeader
header, [Tx]
_, UTxO
utxo) -> do
            TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain (ChainSlot
slotNum, Integer -> Natural
forall a. Num a => Integer -> a
fromInteger Integer
tipIndex Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1, Seq (BlockHeader, [Tx], UTxO)
blocks, UTxO
utxo)
            Maybe ChainPoint -> STM m (Maybe ChainPoint)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ChainPoint -> STM m (Maybe ChainPoint))
-> Maybe ChainPoint -> STM m (Maybe ChainPoint)
forall a b. (a -> b) -> a -> b
$ ChainPoint -> Maybe ChainPoint
forall a. a -> Maybe a
Just (BlockHeader -> ChainPoint
getChainPoint BlockHeader
header)
          Maybe (BlockHeader, [Tx], UTxO)
Nothing ->
            Maybe ChainPoint -> STM m (Maybe ChainPoint)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ChainPoint
forall a. Maybe a
Nothing
    case Maybe ChainPoint
mPoint of
      Just ChainPoint
point -> do
        [ChainSyncHandler m]
allHandlers <- (MockHydraNode m -> ChainSyncHandler m)
-> [MockHydraNode m] -> [ChainSyncHandler m]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MockHydraNode m -> ChainSyncHandler m
forall (m :: * -> *). MockHydraNode m -> ChainSyncHandler m
chainHandler ([MockHydraNode m] -> [ChainSyncHandler m])
-> m [MockHydraNode m] -> m [ChainSyncHandler m]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar m [MockHydraNode m] -> m [MockHydraNode m]
forall a. TVar m a -> m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar m [MockHydraNode m]
nodes
        [ChainSyncHandler m] -> (ChainSyncHandler m -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ChainSyncHandler m]
allHandlers (ChainSyncHandler m -> ChainPoint -> m ()
forall (m :: * -> *). ChainSyncHandler m -> ChainPoint -> m ()
`onRollBackward` ChainPoint
point)
      Maybe ChainPoint
Nothing ->
        () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  -- Rollback the chain and continue on a divergent fork: unlike
  -- 'rollbackAndForward', which re-serves the very same blocks, the rolled
  -- back blocks are dropped. The 'RequeueMode' selects which of their
  -- transactions are re-submitted (a real chain switch re-includes
  -- transactions from the mempool where still valid) and re-land in later
  -- blocks at later slots; the others are gone for good and only
  -- transactions (re-)posted by the nodes reacting to the rollback make it
  -- onto the new chain.
  rollbackAndFork ::
    TVar m [MockHydraNode m] ->
    TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO) ->
    TQueue m Tx ->
    Natural ->
    RequeueMode ->
    m ()
  rollbackAndFork :: TVar m [MockHydraNode m]
-> TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> TQueue m Tx
-> Natural
-> RequeueMode
-> m ()
rollbackAndFork TVar m [MockHydraNode m]
nodes TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain TQueue m Tx
queue Natural
numberOfBlocks RequeueMode
requeueMode = do
    let requeues :: Tx -> Bool
requeues Tx
tx = case RequeueMode
requeueMode of
          RequeueMode
RequeueAll -> Bool
True
          -- A deposit transaction only creates an output at the deposit
          -- script; it does not spend the head output and stays valid.
          RequeueMode
RequeueDeposits -> Maybe DepositObservation -> Bool
forall a. Maybe a -> Bool
isJust (NetworkId -> Tx -> Maybe DepositObservation
observeDepositTx NetworkId
testNetworkId Tx
tx)
          RequeueMode
RequeueNone -> Bool
False
    Maybe ChainPoint
mPoint <- STM m (Maybe ChainPoint) -> m (Maybe ChainPoint)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe ChainPoint) -> m (Maybe ChainPoint))
-> STM m (Maybe ChainPoint) -> m (Maybe ChainPoint)
forall a b. (a -> b) -> a -> b
$ do
      (ChainSlot
slotNum, Natural
position, Seq (BlockHeader, [Tx], UTxO)
blocks, UTxO
_utxo) <- TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> STM m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain
      -- Same rollback point arithmetic as 'doRollBackward': exactly
      -- @numberOfBlocks@ blocks are erased and the one before them becomes
      -- the new tip — but never fork past the block containing the head's
      -- init tx (the one spending 'seedInput'): a permanently erased init
      -- makes the head unrecoverable by design (see the known limitations in
      -- docs/dev/rollbacks) and is not the scenario this simulates.
      let initIndex :: Int
initIndex =
            Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$
              ((BlockHeader, [Tx], UTxO) -> Bool)
-> Seq (BlockHeader, [Tx], UTxO) -> Maybe Int
forall a. (a -> Bool) -> Seq a -> Maybe Int
Seq.findIndexR (\(BlockHeader
_, [Tx]
txs, UTxO
_) -> (Tx -> Bool) -> [Tx] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TxIn -> [TxIn] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
elem TxIn
seedInput ([TxIn] -> Bool) -> (Tx -> [TxIn]) -> Tx -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx -> [TxIn]
forall era. Tx era -> [TxIn]
txIns') [Tx]
txs) Seq (BlockHeader, [Tx], UTxO)
blocks
          tipIndex :: Integer
tipIndex = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
initIndex) (Natural -> Integer
forall a. Integral a => a -> Integer
toInteger Natural
position Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Natural -> Integer
forall a. Integral a => a -> Integer
toInteger Natural
numberOfBlocks Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)
      if Integer
tipIndex Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0
        then Maybe ChainPoint -> STM m (Maybe ChainPoint)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ChainPoint
forall a. Maybe a
Nothing
        else case Int
-> Seq (BlockHeader, [Tx], UTxO) -> Maybe (BlockHeader, [Tx], UTxO)
forall a. Int -> Seq a -> Maybe a
Seq.lookup (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
tipIndex) Seq (BlockHeader, [Tx], UTxO)
blocks of
          Maybe (BlockHeader, [Tx], UTxO)
Nothing -> Maybe ChainPoint -> STM m (Maybe ChainPoint)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ChainPoint
forall a. Maybe a
Nothing
          Just (BlockHeader
header, [Tx]
_, UTxO
blockUTxO) -> do
            let kept :: Seq (BlockHeader, [Tx], UTxO)
kept = Int
-> Seq (BlockHeader, [Tx], UTxO) -> Seq (BlockHeader, [Tx], UTxO)
forall a. Int -> Seq a -> Seq a
Seq.take (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
tipIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Seq (BlockHeader, [Tx], UTxO)
blocks
                erased :: [Tx]
erased = ((BlockHeader, [Tx], UTxO) -> [Tx])
-> [(BlockHeader, [Tx], UTxO)] -> [Tx]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(BlockHeader
_, [Tx]
txs, UTxO
_) -> [Tx]
txs) ([(BlockHeader, [Tx], UTxO)] -> [Tx])
-> [(BlockHeader, [Tx], UTxO)] -> [Tx]
forall a b. (a -> b) -> a -> b
$ Seq (BlockHeader, [Tx], UTxO) -> [(BlockHeader, [Tx], UTxO)]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq (BlockHeader, [Tx], UTxO) -> [(BlockHeader, [Tx], UTxO)])
-> Seq (BlockHeader, [Tx], UTxO) -> [(BlockHeader, [Tx], UTxO)]
forall a b. (a -> b) -> a -> b
$ Int
-> Seq (BlockHeader, [Tx], UTxO) -> Seq (BlockHeader, [Tx], UTxO)
forall a. Int -> Seq a -> Seq a
Seq.drop (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
tipIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Seq (BlockHeader, [Tx], UTxO)
blocks
            TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain (ChainSlot
slotNum, Integer -> Natural
forall a. Num a => Integer -> a
fromInteger Integer
tipIndex Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1, Seq (BlockHeader, [Tx], UTxO)
kept, UTxO
blockUTxO)
            [Tx] -> (Tx -> STM m ()) -> STM m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((Tx -> Bool) -> [Tx] -> [Tx]
forall a. (a -> Bool) -> [a] -> [a]
filter Tx -> Bool
requeues [Tx]
erased) (TQueue m Tx -> Tx -> STM m ()
forall a. TQueue m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> a -> STM m ()
writeTQueue TQueue m Tx
queue)
            Maybe ChainPoint -> STM m (Maybe ChainPoint)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ChainPoint -> STM m (Maybe ChainPoint))
-> Maybe ChainPoint -> STM m (Maybe ChainPoint)
forall a b. (a -> b) -> a -> b
$ ChainPoint -> Maybe ChainPoint
forall a. a -> Maybe a
Just (BlockHeader -> ChainPoint
getChainPoint BlockHeader
header)
    case Maybe ChainPoint
mPoint of
      Maybe ChainPoint
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just ChainPoint
point -> do
        [ChainSyncHandler m]
allHandlers <- (MockHydraNode m -> ChainSyncHandler m)
-> [MockHydraNode m] -> [ChainSyncHandler m]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MockHydraNode m -> ChainSyncHandler m
forall (m :: * -> *). MockHydraNode m -> ChainSyncHandler m
chainHandler ([MockHydraNode m] -> [ChainSyncHandler m])
-> m [MockHydraNode m] -> m [ChainSyncHandler m]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar m [MockHydraNode m] -> m [MockHydraNode m]
forall a. TVar m a -> m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar m [MockHydraNode m]
nodes
        [ChainSyncHandler m] -> (ChainSyncHandler m -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ChainSyncHandler m]
allHandlers (ChainSyncHandler m -> ChainPoint -> m ()
forall (m :: * -> *). ChainSyncHandler m -> ChainPoint -> m ()
`onRollBackward` ChainPoint
point)
    -- Give the nodes and the chain time to converge onto the new fork: nodes
    -- re-post erased settlements upon observing the rollback and requeued
    -- transactions are included in the following blocks.
    DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (DiffTime
3 DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
blockTime)

  -- Returns the transactions that were dropped (with the validation error
  -- against the block-start UTxO), so callers can surface them.
  addNewBlockToChain :: TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO) -> [Tx] -> STM m [(Tx, Text)]
  addNewBlockToChain :: TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> [Tx] -> STM m [(Tx, Text)]
addNewBlockToChain TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain [Tx]
transactions = do
    (ChainSlot
slotNum, Natural
position, Seq (BlockHeader, [Tx], UTxO)
blocks, UTxO
utxo) <- TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> STM m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain
    -- NOTE: Assumes 1 slot = 1 second
    let newSlot :: ChainSlot
newSlot = ChainSlot
slotNum ChainSlot -> ChainSlot -> ChainSlot
forall a. Num a => a -> a -> a
+ Natural -> ChainSlot
ChainSlot (DiffTime -> Natural
forall b. Integral b => DiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate DiffTime
blockTime)
        header :: BlockHeader
header = Gen BlockHeader -> Gen BlockHeader
forall a. Gen a -> Gen a
hedgehog (SlotNo -> Gen BlockHeader
genBlockHeaderAt (ChainSlot -> SlotNo
fromChainSlot ChainSlot
newSlot)) Gen BlockHeader -> Int -> BlockHeader
forall a. Gen a -> Int -> a
`generateWith` Int
42
        -- NOTE: Transactions that do not apply to the current state (eg.
        -- UTxO) are dropped, which emulates the chain behaviour that no
        -- invalid transaction will ever be included in the chain.
        ([Tx]
txs', UTxOType Tx
utxo') = Ledger Tx
-> ChainSlot -> UTxOType Tx -> [Tx] -> ([Tx], UTxOType Tx)
forall tx.
Ledger tx
-> ChainSlot -> UTxOType tx -> [tx] -> ([tx], UTxOType tx)
collectTransactions Ledger Tx
ledger ChainSlot
newSlot UTxOType Tx
UTxO
utxo [Tx]
transactions
        dropped :: [(Tx, Text)]
dropped =
          [ (Tx
tx, Text
reason)
          | Tx
tx <- [Tx]
transactions
          , Tx
tx Tx -> [Tx] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` [Tx]
txs'
          , let reason :: Text
reason = case ChainSlot -> UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
applyTransactions ChainSlot
newSlot UTxO
utxo [Tx
tx] of
                  Left (Tx
_, ValidationError{$sel:reason:ValidationError :: ValidationError -> Text
reason = Text
r}) -> Text -> Text
forall a. ToText a => a -> Text
toText Text
r
                  Right UTxO
_ -> Text
"conflicts with an earlier transaction in the same block"
          ]
    TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain (ChainSlot
newSlot, Natural
position, Seq (BlockHeader, [Tx], UTxO)
blocks Seq (BlockHeader, [Tx], UTxO)
-> (BlockHeader, [Tx], UTxO) -> Seq (BlockHeader, [Tx], UTxO)
forall a. Seq a -> a -> Seq a
:|> (BlockHeader
header, [Tx]
txs', UTxOType Tx
UTxO
utxo'), UTxOType Tx
UTxO
utxo')
    [(Tx, Text)] -> STM m [(Tx, Text)]
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Tx, Text)]
dropped

-- | A 'TimeHandle' at the given slot, for a chain that starts at time 0 and
-- has the era horizon far in the future. This is used in our 'Model' tests and
-- we want to make sure the tests finish before the horizon is reached to
-- prevent the 'PastHorizon' exceptions.
timeHandleAt :: SlotNo -> TimeHandle
timeHandleAt :: SlotNo -> TimeHandle
timeHandleAt SlotNo
currentSlotNo =
  SlotNo -> SystemStart -> EraHistory -> TimeHandle
mkTimeHandle SlotNo
currentSlotNo (UTCTime -> SystemStart
SystemStart UTCTime
startTime) EraHistory
eraHistoryWithoutHorizon
 where
  startTime :: UTCTime
startTime = NominalDiffTime -> UTCTime
posixSecondsToUTCTime (NominalDiffTime -> UTCTime) -> NominalDiffTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ Pico -> NominalDiffTime
secondsToNominalDiffTime Pico
0

-- | A trimmed down ledger whose only purpose is to validate
-- on-chain scripts.
scriptLedger ::
  Ledger Tx
scriptLedger :: Ledger Tx
scriptLedger =
  Ledger{ChainSlot
-> UTxOType Tx
-> [Tx]
-> Either (Tx, ValidationError) (UTxOType Tx)
ChainSlot -> UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
$sel:applyTransactions:Ledger :: ChainSlot
-> UTxOType Tx
-> [Tx]
-> Either (Tx, ValidationError) (UTxOType Tx)
applyTransactions :: ChainSlot -> UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
applyTransactions}
 where
  -- XXX: We could easily add 'slot' validation here and this would already
  -- emulate the dropping of outdated transactions from the cardano-node
  -- mempool.
  applyTransactions :: ChainSlot -> UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
  applyTransactions :: ChainSlot -> UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
applyTransactions ChainSlot
slot UTxO
utxo = \case
    [] -> UTxO -> Either (Tx, ValidationError) UTxO
forall a b. b -> Either a b
Right UTxO
utxo
    (Tx
tx : [Tx]
txs) ->
      case Tx -> UTxO -> Either EvaluationError EvaluationReport
evaluateTx Tx
tx UTxO
utxo of
        Left EvaluationError
err ->
          (Tx, ValidationError) -> Either (Tx, ValidationError) UTxO
forall a b. a -> Either a b
Left (Tx
tx, ValidationError{$sel:reason:ValidationError :: Text
reason = EvaluationError -> Text
forall b a. (Show a, IsString b) => a -> b
show EvaluationError
err})
        Right EvaluationReport
report
          | (Either ScriptExecutionError ExecutionUnits -> Bool)
-> EvaluationReport -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Either ScriptExecutionError ExecutionUnits -> Bool
forall a b. Either a b -> Bool
isLeft EvaluationReport
report ->
              (Tx, ValidationError) -> Either (Tx, ValidationError) UTxO
forall a b. a -> Either a b
Left (Tx
tx, ValidationError{$sel:reason:ValidationError :: Text
reason = EvaluationReport -> Text
renderEvaluationReport EvaluationReport
report})
          | Bool
otherwise ->
              ChainSlot -> UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
applyTransactions ChainSlot
slot (Tx -> UTxO -> UTxO
adjustUTxO Tx
tx UTxO
utxo) [Tx]
txs

-- | Find Cardano vkey corresponding to our Hydra vkey using signing keys lookup.
-- This is a bit cumbersome and a tribute to the fact the `HydraNode` itself has no
-- direct knowledge of the cardano keys which are stored only at the `ChainComponent` level.
findOwnCardanoKey :: Party -> [(Secret (SigningKey HydraKey), CardanoSigningKey)] -> (VerificationKey PaymentKey, [VerificationKey PaymentKey])
findOwnCardanoKey :: Party
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> (VerificationKey PaymentKey, [VerificationKey PaymentKey])
findOwnCardanoKey Party
me [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys = (VerificationKey PaymentKey, [VerificationKey PaymentKey])
-> Maybe (VerificationKey PaymentKey, [VerificationKey PaymentKey])
-> (VerificationKey PaymentKey, [VerificationKey PaymentKey])
forall a. a -> Maybe a -> a
fromMaybe (Text -> (VerificationKey PaymentKey, [VerificationKey PaymentKey])
forall a t. (HasCallStack, IsText t) => t -> a
error (Text
 -> (VerificationKey PaymentKey, [VerificationKey PaymentKey]))
-> Text
-> (VerificationKey PaymentKey, [VerificationKey PaymentKey])
forall a b. (a -> b) -> a -> b
$ Text
"cannot find cardano key for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Party -> Text
forall b a. (Show a, IsString b) => a -> b
show Party
me Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" in seed-keys of size " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show ([(Secret (SigningKey HydraKey), CardanoSigningKey)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys)) (Maybe (VerificationKey PaymentKey, [VerificationKey PaymentKey])
 -> (VerificationKey PaymentKey, [VerificationKey PaymentKey]))
-> Maybe (VerificationKey PaymentKey, [VerificationKey PaymentKey])
-> (VerificationKey PaymentKey, [VerificationKey PaymentKey])
forall a b. (a -> b) -> a -> b
$ do
  VerificationKey PaymentKey
csk <- CardanoSigningKey -> VerificationKey PaymentKey
vkOf (CardanoSigningKey -> VerificationKey PaymentKey)
-> ((Secret (SigningKey HydraKey), CardanoSigningKey)
    -> CardanoSigningKey)
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> VerificationKey PaymentKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Secret (SigningKey HydraKey), CardanoSigningKey)
-> CardanoSigningKey
forall a b. (a, b) -> b
snd ((Secret (SigningKey HydraKey), CardanoSigningKey)
 -> VerificationKey PaymentKey)
-> Maybe (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Maybe (VerificationKey PaymentKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Secret (SigningKey HydraKey), CardanoSigningKey) -> Bool)
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> Maybe (Secret (SigningKey HydraKey), CardanoSigningKey)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Party -> Party -> Bool
forall a. Eq a => a -> a -> Bool
== Party
me) (Party -> Bool)
-> ((Secret (SigningKey HydraKey), CardanoSigningKey) -> Party)
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Secret (SigningKey HydraKey) -> Party
deriveParty (Secret (SigningKey HydraKey) -> Party)
-> ((Secret (SigningKey HydraKey), CardanoSigningKey)
    -> Secret (SigningKey HydraKey))
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Party
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Secret (SigningKey HydraKey), CardanoSigningKey)
-> Secret (SigningKey HydraKey)
forall a b. (a, b) -> a
fst) [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys
  (VerificationKey PaymentKey, [VerificationKey PaymentKey])
-> Maybe (VerificationKey PaymentKey, [VerificationKey PaymentKey])
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VerificationKey PaymentKey
csk, (VerificationKey PaymentKey -> Bool)
-> [VerificationKey PaymentKey] -> [VerificationKey PaymentKey]
forall a. (a -> Bool) -> [a] -> [a]
filter (VerificationKey PaymentKey -> VerificationKey PaymentKey -> Bool
forall a. Eq a => a -> a -> Bool
/= VerificationKey PaymentKey
csk) ([VerificationKey PaymentKey] -> [VerificationKey PaymentKey])
-> [VerificationKey PaymentKey] -> [VerificationKey PaymentKey]
forall a b. (a -> b) -> a -> b
$ ((Secret (SigningKey HydraKey), CardanoSigningKey)
 -> VerificationKey PaymentKey)
-> [(Secret (SigningKey HydraKey), CardanoSigningKey)]
-> [VerificationKey PaymentKey]
forall a b. (a -> b) -> [a] -> [b]
map (CardanoSigningKey -> VerificationKey PaymentKey
vkOf (CardanoSigningKey -> VerificationKey PaymentKey)
-> ((Secret (SigningKey HydraKey), CardanoSigningKey)
    -> CardanoSigningKey)
-> (Secret (SigningKey HydraKey), CardanoSigningKey)
-> VerificationKey PaymentKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Secret (SigningKey HydraKey), CardanoSigningKey)
-> CardanoSigningKey
forall a b. (a, b) -> b
snd) [(Secret (SigningKey HydraKey), CardanoSigningKey)]
seedKeys)
 where
  vkOf :: CardanoSigningKey -> VerificationKey PaymentKey
vkOf (CardanoSigningKey Secret (SigningKey PaymentKey)
sk) = Secret (SigningKey PaymentKey) -> VerificationKey PaymentKey
forall s k. HasVerificationKey s k => s -> VerificationKey k
getVerificationKey Secret (SigningKey PaymentKey)
sk

-- TODO: unify with BehaviorSpec's ?
--
-- An adversarial-lag network: every broadcast is appended synchronously to
-- each node's 'mailbox' — one shared total order, like the etcd based
-- production network — but each node's single delivery thread (see
-- 'connectNode') drains its mailbox with a random per-message delay. Per-node
-- delivery order is preserved while nodes fall behind each other and behind
-- their own chain observations, which is exactly the interleaving class that
-- wedged heads before (e.g. a ReqSn overtaking the deposit observation).
createMockNetwork ::
  (MonadSTM m, MonadTime m) =>
  DraftHydraNode Tx m ->
  TVar m [(Party, Message Tx)] ->
  TVar m [MockHydraNode m] ->
  Network m (Message Tx)
createMockNetwork :: forall (m :: * -> *).
(MonadSTM m, MonadTime m) =>
DraftHydraNode Tx m
-> TVar m [(Party, Message Tx)]
-> TVar m [MockHydraNode m]
-> Network m (Message Tx)
createMockNetwork DraftHydraNode Tx m
draftNode TVar m [(Party, Message Tx)]
networkHistory TVar m [MockHydraNode m]
nodes =
  Network{Message Tx -> m ()
broadcast :: Message Tx -> m ()
$sel:broadcast:Network :: Message Tx -> m ()
broadcast}
 where
  broadcast :: Message Tx -> m ()
broadcast Message Tx
msg = do
    UTCTime
now <- m UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
    STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      -- Append to the persisted log first (see 'mockChainAndNetwork'), then
      -- fan out to every connected node's delayed mailbox.
      TVar m [(Party, Message Tx)]
-> ([(Party, Message Tx)] -> [(Party, Message Tx)]) -> STM m ()
forall a. TVar m a -> (a -> a) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
TVar m a -> (a -> a) -> STM m ()
modifyTVar TVar m [(Party, Message Tx)]
networkHistory ([(Party, Message Tx)]
-> [(Party, Message Tx)] -> [(Party, Message Tx)]
forall a. Semigroup a => a -> a -> a
<> [(Party
sender, Message Tx
msg)])
      [MockHydraNode m]
allNodes <- TVar m [MockHydraNode m] -> STM m [MockHydraNode m]
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m [MockHydraNode m]
nodes
      [MockHydraNode m] -> (MockHydraNode m -> STM m ()) -> STM m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [MockHydraNode m]
allNodes ((MockHydraNode m -> STM m ()) -> STM m ())
-> (MockHydraNode m -> STM m ()) -> STM m ()
forall a b. (a -> b) -> a -> b
$ \MockHydraNode{TQueue m (UTCTime, Party, Message Tx)
$sel:mailbox:MockHydraNode :: forall (m :: * -> *).
MockHydraNode m -> TQueue m (UTCTime, Party, Message Tx)
mailbox :: TQueue m (UTCTime, Party, Message Tx)
mailbox} ->
        TQueue m (UTCTime, Party, Message Tx)
-> (UTCTime, Party, Message Tx) -> STM m ()
forall a. TQueue m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> a -> STM m ()
writeTQueue TQueue m (UTCTime, Party, Message Tx)
mailbox (UTCTime
now, Party
sender, Message Tx
msg)

  DraftHydraNode{$sel:env:DraftHydraNode :: forall tx (m :: * -> *). DraftHydraNode tx m -> Environment
env = Environment{$sel:party:Environment :: Environment -> Party
party = Party
sender}} = DraftHydraNode Tx m
draftNode

-- | Upper bound of the random delivery delay per network message and node,
-- see 'createMockNetwork'. One block time: enough for messages to routinely
-- cross block boundaries relative to other nodes' chain observations, while
-- staying far below the ~600s a parked network input survives (TTL x
-- 'waitDelay') so delays alone never exhaust a message's retry budget.
maxNetworkLatency :: DiffTime
maxNetworkLatency :: DiffTime
maxNetworkLatency = DiffTime
20

data MockHydraNode m = MockHydraNode
  { forall (m :: * -> *). MockHydraNode m -> HydraNode Tx m
node :: HydraNode Tx m
  , forall (m :: * -> *). MockHydraNode m -> ChainSyncHandler m
chainHandler :: ChainSyncHandler m
  , forall (m :: * -> *).
MockHydraNode m -> TQueue m (UTCTime, Party, Message Tx)
mailbox :: TQueue m (UTCTime, Party, Message Tx)
  -- ^ Pending network deliveries to this node (with their arrival time), see
  -- 'createMockNetwork'.
  }

createMockChain ::
  (MonadTimer m, MonadThrow (STM m)) =>
  Tracer m CardanoChainLog ->
  ChainContext ->
  DepositPeriod ->
  SubmitTx m ->
  m TimeHandle ->
  TxIn ->
  LocalChainState m Tx ->
  Chain Tx m
createMockChain :: forall (m :: * -> *).
(MonadTimer m, MonadThrow (STM m)) =>
Tracer m CardanoChainLog
-> ChainContext
-> DepositPeriod
-> SubmitTx m
-> m TimeHandle
-> TxIn
-> LocalChainState m Tx
-> Chain Tx m
createMockChain Tracer m CardanoChainLog
tracer ChainContext
ctx DepositPeriod
depositPeriod SubmitTx m
submitTx m TimeHandle
timeHandle TxIn
seedInput LocalChainState m Tx
chainState =
  -- NOTE: The wallet basically does nothing
  let wallet :: TinyWallet m
wallet =
        TinyWallet
          { $sel:getUTxO:TinyWallet :: STM m (Map TxIn TxOut)
getUTxO = Map TxIn (BabbageTxOut ConwayEra)
-> STM m (Map TxIn (BabbageTxOut ConwayEra))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map TxIn (BabbageTxOut ConwayEra)
forall a. Monoid a => a
mempty
          , $sel:getSeedInput:TinyWallet :: STM m (Maybe TxIn)
getSeedInput = Maybe TxIn -> STM m (Maybe TxIn)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn -> Maybe TxIn
forall a. a -> Maybe a
Just TxIn
seedInput)
          , $sel:sign:TinyWallet :: Tx -> Tx
sign = Tx -> Tx
forall a. a -> a
id
          , $sel:coverFee:TinyWallet :: UTxO -> Tx -> m (Either ErrCoverFee Tx)
coverFee = \UTxO
_ Tx
tx -> Either ErrCoverFee Tx -> m (Either ErrCoverFee Tx)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Either ErrCoverFee Tx
forall a b. b -> Either a b
Right Tx
tx)
          , $sel:evaluateScriptCosts:TinyWallet :: Tx -> UTxO -> m (Either EvaluationError EvaluationReport)
evaluateScriptCosts = \Tx
tx UTxO
utxo -> Either EvaluationError EvaluationReport
-> m (Either EvaluationError EvaluationReport)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either EvaluationError EvaluationReport
 -> m (Either EvaluationError EvaluationReport))
-> Either EvaluationError EvaluationReport
-> m (Either EvaluationError EvaluationReport)
forall a b. (a -> b) -> a -> b
$ Tx -> UTxO -> Either EvaluationError EvaluationReport
evaluateTx Tx
tx UTxO
utxo
          , $sel:isTxWithinSizeLimits:TinyWallet :: Tx -> m Bool
isTxWithinSizeLimits = \Tx
_ -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
          , $sel:getPParams:TinyWallet :: m (PParams LedgerEra)
getPParams = PParams ConwayEra -> m (PParams ConwayEra)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PParams LedgerEra
PParams ConwayEra
defaultPParams
          , $sel:reset:TinyWallet :: m ()
reset = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          , $sel:update:TinyWallet :: BlockHeader -> [Tx] -> m ()
update = \BlockHeader
_ [Tx]
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          }
   in Tracer m CardanoChainLog
-> m TimeHandle
-> TinyWallet m
-> ChainContext
-> DepositPeriod
-> LocalChainState m Tx
-> SubmitTx m
-> Chain Tx m
forall (m :: * -> *).
(MonadSTM m, MonadThrow (STM m)) =>
Tracer m CardanoChainLog
-> GetTimeHandle m
-> TinyWallet m
-> ChainContext
-> DepositPeriod
-> LocalChainState m Tx
-> SubmitTx m
-> Chain Tx m
mkChain
        Tracer m CardanoChainLog
tracer
        m TimeHandle
timeHandle
        TinyWallet m
wallet
        ChainContext
ctx
        DepositPeriod
depositPeriod
        LocalChainState m Tx
chainState
        SubmitTx m
submitTx

-- NOTE: This is a workaround until the upstream PR is merged:
-- https://github.com/input-output-hk/io-sim/issues/133

-- | Drain the queue, preserving submission order (a mempool applies dependent
-- transactions oldest first; reversing them would drop e.g. a re-queued
-- increment flushed together with its deposit after a chain fork).
flushQueue :: MonadSTM m => TQueue m a -> STM m [a]
flushQueue :: forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m [a]
flushQueue TQueue m a
queue = [a] -> STM m [a]
go []
 where
  go :: [a] -> STM m [a]
go [a]
as = do
    Maybe a
hasA <- TQueue m a -> STM m (Maybe a)
forall a. TQueue m a -> STM m (Maybe a)
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m (Maybe a)
tryReadTQueue TQueue m a
queue
    case Maybe a
hasA of
      Just a
a -> [a] -> STM m [a]
go (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
as)
      Maybe a
Nothing -> [a] -> STM m [a]
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
as)