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

module Hydra.Model.MockChain where

import Hydra.Cardano.Api
import Hydra.Prelude hiding (Any, label)

import Cardano.Api.UTxO (fromPairs)
import Control.Concurrent.Class.MonadSTM (
  MonadLabelledSTM,
  MonadSTM (newTVarIO, writeTVar),
  labelTQueueIO,
  labelTVarIO,
  modifyTVar,
  newTQueueIO,
  newTVarIO,
  readTVarIO,
  throwSTM,
  tryReadTQueue,
  writeTQueue,
  writeTVar,
 )
import Control.Monad.Class.MonadAsync (async, link)
import Control.Monad.Class.MonadFork (labelThisThread)
import Data.Sequence (Seq (Empty, (:|>)))
import Data.Sequence qualified as Seq
import Data.Time (secondsToNominalDiffTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import GHC.IO.Exception (userError)
import Hydra.API.Server (Server (..))
import Hydra.BehaviorSpec (SimulatedChainNetwork (..))
import Hydra.Cardano.Api.Pretty (renderTxWithUTxO)
import Hydra.Chain (
  Chain (..),
  PostChainTx (
    CloseTx,
    closingSnapshot,
    headId,
    headParameters,
    openVersion
  ),
  initHistory,
 )
import Hydra.Chain.ChainState (ChainSlot (..))
import Hydra.Chain.Direct.Handlers (
  ChainSyncHandler (..),
  DirectChainLog,
  LocalChainState,
  SubmitTx,
  chainSyncHandler,
  mkChain,
  newLocalChainState,
  onRollBackward,
  onRollForward,
 )
import Hydra.Chain.Direct.State (ChainContext (..), initialChainState)
import Hydra.Chain.Direct.TimeHandle (TimeHandle, mkTimeHandle)
import Hydra.Chain.Direct.Wallet (TinyWallet (..))
import Hydra.HeadLogic (
  ClosedState (..),
  HeadState (..),
  IdleState (..),
  InitialState (..),
  Input (..),
  OpenState (..),
  defaultTTL,
 )
import Hydra.Ledger (Ledger (..), ValidationError (..), collectTransactions)
import Hydra.Ledger.Cardano (adjustUTxO, fromChainSlot)
import Hydra.Ledger.Cardano.Evaluate (eraHistoryWithoutHorizon, evaluateTx)
import Hydra.Logging (Tracer)
import Hydra.Model.Payment (CardanoSigningKey (..))
import Hydra.Network (Network (..))
import Hydra.Network.Message (Message, NetworkEvent (..))
import Hydra.Node (DraftHydraNode (..), HydraNode (..), NodeState (..), connect)
import Hydra.Node.InputQueue (InputQueue (..))
import Hydra.Tx.BlueprintTx (CommitBlueprintTx (..))
import Hydra.Tx.Crypto (HydraKey)
import Hydra.Tx.Environment (Environment (Environment, participants, party))
import Hydra.Tx.Party (Party (..), deriveParty, getParty)
import Hydra.Tx.ScriptRegistry (registryUTxO)
import Hydra.Tx.Snapshot (ConfirmedSnapshot (..))
import Hydra.Tx.Utils (verificationKeyToOnChainId)
import Test.Hydra.Tx.Fixture (testNetworkId)
import Test.Hydra.Tx.Gen (genScriptRegistry, genTxOutAdaOnly)
import Test.QuickCheck (getPositive)

-- | 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
  ) =>
  Tracer m DirectChainLog ->
  [(SigningKey HydraKey, CardanoSigningKey)] ->
  UTxO ->
  m (SimulatedChainNetwork Tx m)
mockChainAndNetwork :: forall (m :: * -> *).
(MonadTimer m, MonadAsync m, MonadMask m, MonadThrow (STM m),
 MonadLabelledSTM m, MonadFork m, MonadDelay m) =>
Tracer m DirectChainLog
-> [(SigningKey HydraKey, CardanoSigningKey)]
-> UTxO
-> m (SimulatedChainNetwork Tx m)
mockChainAndNetwork Tracer m DirectChainLog
tr [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys UTxO
commits = do
  TVar m [MockHydraNode m]
nodes <- [MockHydraNode m] -> m (TVar m [MockHydraNode m])
forall a. a -> m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO []
  TVar m [MockHydraNode m] -> String -> m ()
forall a. TVar m a -> String -> m ()
forall (m :: * -> *) a.
MonadLabelledSTM m =>
TVar m a -> String -> m ()
labelTVarIO TVar m [MockHydraNode m]
nodes String
"nodes"
  TQueue m Tx
queue <- m (TQueue m Tx)
forall a. m (TQueue m a)
forall (m :: * -> *) a. MonadSTM m => m (TQueue m a)
newTQueueIO
  TQueue m Tx -> String -> m ()
forall a. TQueue m a -> String -> m ()
forall (m :: * -> *) a.
MonadLabelledSTM m =>
TQueue m a -> String -> m ()
labelTQueueIO TQueue m Tx
queue String
"chain-queue"
  TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain <- (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> m (TVar
        m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO))
forall a. a -> m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO (ChainSlot
0 :: ChainSlot, Natural
0 :: Natural, Seq (BlockHeader, [Tx], UTxO)
forall a. Seq a
Empty, UTxO
initialUTxO)
  Async m ()
tickThread <- m () -> m (Async m ())
forall a. m a -> m (Async m a)
forall (m :: * -> *) a. MonadAsync m => m a -> m (Async m a)
async (String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread String
"chain" m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TVar m [MockHydraNode m]
-> TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> TQueue m Tx
-> m ()
forall {f :: * -> *} {b} {t :: * -> *} {b}.
(MonadDelay f, MonadSTM f, Integral b, Foldable t, Functor t) =>
TVar f (t (MockHydraNode f))
-> TVar f (ChainSlot, b, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> TQueue f Tx
-> f b
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 [MockHydraNode m]
-> TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> TQueue m Tx
-> DraftHydraNode Tx m
-> m (HydraNode Tx m)
connectNode 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 ()
forall {m :: * -> *} {b} {t :: * -> *} {a} {d}.
(MonadSTM m, Integral b, Foldable t, MonadDelay m, Functor t) =>
TVar m (t (MockHydraNode m))
-> TVar m (a, b, Seq (BlockHeader, [Tx], d), d) -> b -> m ()
rollbackAndForward TVar m [MockHydraNode m]
nodes TVar m (ChainSlot, Natural, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain
      , $sel:simulateCommit:SimulatedChainNetwork :: (Party, UTxOType Tx) -> m ()
simulateCommit = TVar m [MockHydraNode m] -> (Party, UTxO) -> m ()
forall {m :: * -> *} {t :: * -> *}.
(MonadSTM m, Foldable t, MonadThrow m) =>
TVar m (t (MockHydraNode m)) -> (Party, UTxO) -> m ()
simulateCommit TVar m [MockHydraNode m]
nodes
      , $sel:closeWithInitialSnapshot:SimulatedChainNetwork :: (Party, UTxOType Tx) -> m ()
closeWithInitialSnapshot = TVar m [MockHydraNode m] -> (Party, UTxO) -> m ()
forall {m :: * -> *} {t :: * -> *}.
(MonadThrow m, MonadSTM m, Foldable t) =>
TVar m (t (MockHydraNode m)) -> (Party, UTxO) -> m ()
closeWithInitialSnapshot TVar m [MockHydraNode m]
nodes
      }
 where
  initialUTxO :: UTxO
initialUTxO = UTxO
forall {ctx}. UTxO' (TxOut ctx)
seedUTxO UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
commits UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> ScriptRegistry -> UTxO
registryUTxO ScriptRegistry
scriptRegistry

  seedUTxO :: UTxO' (TxOut ctx)
seedUTxO = [(TxIn, TxOut ctx)] -> UTxO' (TxOut ctx)
forall out. [(TxIn, out)] -> UTxO' out
fromPairs [(TxIn
seedInput, (Gen (VerificationKey PaymentKey)
forall a. Arbitrary a => Gen a
arbitrary Gen (VerificationKey PaymentKey)
-> (VerificationKey PaymentKey -> Gen (TxOut ctx))
-> Gen (TxOut ctx)
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 ctx)
forall ctx. VerificationKey PaymentKey -> Gen (TxOut ctx)
genTxOutAdaOnly) Gen (TxOut ctx) -> Int -> TxOut ctx
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 = SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey (SigningKey PaymentKey -> VerificationKey PaymentKey)
-> ((SigningKey HydraKey, CardanoSigningKey)
    -> SigningKey PaymentKey)
-> (SigningKey HydraKey, CardanoSigningKey)
-> VerificationKey PaymentKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoSigningKey -> SigningKey PaymentKey
signingKey (CardanoSigningKey -> SigningKey PaymentKey)
-> ((SigningKey HydraKey, CardanoSigningKey) -> CardanoSigningKey)
-> (SigningKey HydraKey, CardanoSigningKey)
-> SigningKey PaymentKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SigningKey HydraKey, CardanoSigningKey) -> CardanoSigningKey
forall a b. (a, b) -> b
snd ((SigningKey HydraKey, CardanoSigningKey)
 -> VerificationKey PaymentKey)
-> [(SigningKey HydraKey, CardanoSigningKey)]
-> [VerificationKey PaymentKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys
    Environment
env{participants = verificationKeyToOnChainId <$> vks}

  connectNode :: 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 [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.
(MonadSTM m, IsChainState tx) =>
ChainStateHistory tx -> m (LocalChainState m tx)
newLocalChainState (ChainStateType Tx -> ChainStateHistory Tx
forall 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} = 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
-> [(SigningKey HydraKey, CardanoSigningKey)]
-> (VerificationKey PaymentKey, [VerificationKey PaymentKey])
findOwnCardanoKey Party
ownParty [(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
            }
    let getTimeHandle :: m TimeHandle
getTimeHandle = 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
$ Gen TimeHandle
fixedTimeHandleIndefiniteHorizon Gen TimeHandle -> Int -> TimeHandle
forall a. Gen a -> Int -> a
`generateWith` Int
42
    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
err) ->
                IOError -> STM m ()
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (IOError -> STM m ()) -> (Text -> IOError) -> Text -> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOError
userError (String -> IOError) -> (Text -> String) -> Text -> IOError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString (Text -> STM m ()) -> Text -> STM m ()
forall a b. (a -> b) -> a -> b
$
                  [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines
                    [ 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: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ValidationError -> Text
forall b a. (Show a, IsString b) => a -> b
show ValidationError
err
                    ]
              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 DirectChainLog
-> ChainContext
-> (Tx -> m ())
-> m TimeHandle
-> TxIn
-> LocalChainState m Tx
-> Chain Tx m
forall (m :: * -> *).
(MonadTimer m, MonadThrow (STM m)) =>
Tracer m DirectChainLog
-> ChainContext
-> SubmitTx m
-> m TimeHandle
-> TxIn
-> LocalChainState m Tx
-> Chain Tx m
createMockChain
            Tracer m DirectChainLog
tr
            ChainContext
ctx
            Tx -> m ()
submitTx
            m TimeHandle
getTimeHandle
            TxIn
seedInput
            LocalChainState m Tx
localChainState
        mockServer :: Server tx m
mockServer = Server{$sel:sendOutput:Server :: ServerOutput tx -> m ()
sendOutput = m () -> ServerOutput tx -> m ()
forall a b. a -> b -> a
const (m () -> ServerOutput tx -> m ())
-> m () -> ServerOutput tx -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()}
    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 [MockHydraNode m] -> Network m (Message Tx)
forall (m :: * -> *).
MonadSTM m =>
DraftHydraNode Tx m
-> TVar m [MockHydraNode m] -> Network m (Message Tx)
createMockNetwork DraftHydraNode Tx m
draftNode TVar m [MockHydraNode m]
nodes) Server Tx m
forall {tx}. Server tx m
mockServer DraftHydraNode Tx m
draftNode
    let node' :: HydraNode Tx m
node' = (HydraNode Tx m
node :: HydraNode Tx m){env = updateEnvironment env}
    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 DirectChainLog
-> ChainCallback Tx m
-> m TimeHandle
-> ChainContext
-> LocalChainState m Tx
-> ChainSyncHandler m
forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Tracer m DirectChainLog
-> ChainCallback Tx m
-> GetTimeHandle m
-> ChainContext
-> LocalChainState m Tx
-> ChainSyncHandler m
chainSyncHandler
                  Tracer m DirectChainLog
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
getTimeHandle
                  ChainContext
ctx
                  LocalChainState m Tx
localChainState
            }
    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
$ 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 :)
    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'

  simulateCommit :: TVar m (t (MockHydraNode m)) -> (Party, UTxO) -> m ()
simulateCommit TVar m (t (MockHydraNode m))
nodes (Party
party, UTxO
lookupUTxO) = do
    t (MockHydraNode m)
hydraNodes <- TVar m (t (MockHydraNode m)) -> m (t (MockHydraNode m))
forall a. TVar m a -> m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar m (t (MockHydraNode m))
nodes
    case (MockHydraNode m -> Bool)
-> t (MockHydraNode m) -> Maybe (MockHydraNode m)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Party -> MockHydraNode m -> Bool
forall {m :: * -> *}. Party -> MockHydraNode m -> Bool
matchingParty Party
party) t (MockHydraNode m)
hydraNodes of
      Maybe (MockHydraNode m)
Nothing -> Text -> m ()
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"simulateCommit: 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 => Tx -> m ()
submitTx :: MonadThrow m => Tx -> m ()
$sel:submitTx:Chain :: forall tx (m :: * -> *). Chain tx m -> MonadThrow m => tx -> m ()
submitTx, MonadThrow m =>
HeadId -> CommitBlueprintTx Tx -> m (Either (PostTxError Tx) Tx)
draftCommitTx :: MonadThrow m =>
HeadId -> CommitBlueprintTx Tx -> m (Either (PostTxError Tx) Tx)
$sel:draftCommitTx:Chain :: forall tx (m :: * -> *).
Chain tx m
-> MonadThrow m =>
   HeadId -> CommitBlueprintTx tx -> m (Either (PostTxError tx) tx)
draftCommitTx}, $sel:nodeState:HydraNode :: forall tx (m :: * -> *). HydraNode tx m -> NodeState tx m
nodeState = NodeState{STM m (HeadState Tx)
queryHeadState :: STM m (HeadState Tx)
$sel:queryHeadState:NodeState :: forall tx (m :: * -> *). NodeState tx m -> STM m (HeadState tx)
queryHeadState}}
          } -> do
          HeadState Tx
hs <- STM m (HeadState Tx) -> m (HeadState Tx)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (HeadState Tx)
queryHeadState
          let hId :: HeadId
hId = case HeadState Tx
hs of
                Idle IdleState{} -> Text -> HeadId
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"HeadState is Idle: no HeadId to commit"
                Initial InitialState{HeadId
headId :: HeadId
$sel:headId:InitialState :: forall tx. InitialState tx -> HeadId
headId} -> HeadId
headId
                Open OpenState{HeadId
headId :: HeadId
$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId} -> HeadId
headId
                Closed ClosedState{HeadId
headId :: HeadId
$sel:headId:ClosedState :: forall tx. ClosedState tx -> HeadId
headId} -> HeadId
headId
              blueprintTx :: Tx
blueprintTx = UTxO -> Tx
txSpendingUTxO UTxO
lookupUTxO
          -- NOTE: We don't need to sign a tx here since the MockChain
          -- doesn't actually validate transactions using a real ledger.
          Either (PostTxError Tx) Tx
eTx <- MonadThrow m =>
HeadId -> CommitBlueprintTx Tx -> m (Either (PostTxError Tx) Tx)
HeadId -> CommitBlueprintTx Tx -> m (Either (PostTxError Tx) Tx)
draftCommitTx HeadId
hId CommitBlueprintTx{UTxO
UTxOType Tx
lookupUTxO :: UTxO
$sel:lookupUTxO:CommitBlueprintTx :: UTxOType Tx
lookupUTxO, Tx
blueprintTx :: Tx
$sel:blueprintTx:CommitBlueprintTx :: Tx
blueprintTx}
          case Either (PostTxError Tx) Tx
eTx of
            Left PostTxError Tx
e -> PostTxError Tx -> m ()
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

  -- REVIEW: Is this still needed now as we have TxTraceSpec?
  closeWithInitialSnapshot :: TVar m (t (MockHydraNode m)) -> (Party, UTxO) -> m ()
closeWithInitialSnapshot TVar m (t (MockHydraNode m))
nodes (Party
party, UTxO
modelInitialUTxO) = do
    t (MockHydraNode m)
hydraNodes <- TVar m (t (MockHydraNode m)) -> m (t (MockHydraNode m))
forall a. TVar m a -> m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar m (t (MockHydraNode m))
nodes
    case (MockHydraNode m -> Bool)
-> t (MockHydraNode m) -> Maybe (MockHydraNode m)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Party -> MockHydraNode m -> Bool
forall {m :: * -> *}. Party -> MockHydraNode m -> Bool
matchingParty Party
party) t (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:nodeState:HydraNode :: forall tx (m :: * -> *). HydraNode tx m -> NodeState tx m
nodeState = NodeState{STM m (HeadState Tx)
$sel:queryHeadState:NodeState :: forall tx (m :: * -> *). NodeState tx m -> STM m (HeadState tx)
queryHeadState :: STM m (HeadState Tx)
queryHeadState}}
          } -> do
          HeadState Tx
hs <- STM m (HeadState Tx) -> m (HeadState Tx)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (HeadState Tx)
queryHeadState
          case HeadState Tx
hs of
            Idle IdleState{} -> Text -> m ()
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Cannot post Close tx when in Idle state"
            Initial InitialState{} -> Text -> m ()
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Cannot post Close tx when in Initial 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, $sel:initialUTxO:InitialSnapshot :: UTxOType Tx
initialUTxO = UTxO
UTxOType Tx
modelInitialUTxO}
                  }
            Closed ClosedState{} -> Text -> m ()
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Cannot post Close tx when in Closed state"

  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 f (t (MockHydraNode f))
-> TVar f (ChainSlot, b, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> TQueue f Tx
-> f b
simulateChain TVar f (t (MockHydraNode f))
nodes TVar f (ChainSlot, b, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain TQueue f Tx
queue =
    f () -> f b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (f () -> f b) -> f () -> f b
forall a b. (a -> b) -> a -> b
$ TVar f (t (MockHydraNode f))
-> TVar f (ChainSlot, b, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> TQueue f Tx
-> f ()
forall {m :: * -> *} {b} {t :: * -> *}.
(MonadDelay m, MonadSTM m, Integral b, Foldable t, Functor t) =>
TVar m (t (MockHydraNode m))
-> TVar m (ChainSlot, b, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> TQueue m Tx
-> m ()
rollForward TVar f (t (MockHydraNode f))
nodes TVar f (ChainSlot, b, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain TQueue f Tx
queue

  rollForward :: TVar m (t (MockHydraNode m))
-> TVar m (ChainSlot, b, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> TQueue m Tx
-> m ()
rollForward TVar m (t (MockHydraNode m))
nodes TVar m (ChainSlot, b, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain TQueue m Tx
queue = do
    DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
blockTime
    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
      [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, b, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> [Tx] -> STM m ()
forall {m :: * -> *} {b}.
MonadSTM m =>
TVar m (ChainSlot, b, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> [Tx] -> STM m ()
addNewBlockToChain TVar m (ChainSlot, b, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain [Tx]
transactions
    TVar m (t (MockHydraNode m))
-> TVar m (ChainSlot, b, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> m ()
forall {m :: * -> *} {b} {t :: * -> *} {a} {d}.
(MonadSTM m, Integral b, Foldable t, Functor t) =>
TVar m (t (MockHydraNode m))
-> TVar m (a, b, Seq (BlockHeader, [Tx], d), d) -> m ()
doRollForward TVar m (t (MockHydraNode m))
nodes TVar m (ChainSlot, b, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain

  doRollForward :: TVar m (t (MockHydraNode m))
-> TVar m (a, b, Seq (BlockHeader, [Tx], d), d) -> m ()
doRollForward TVar m (t (MockHydraNode m))
nodes TVar m (a, b, Seq (BlockHeader, [Tx], d), d)
chain = do
    (a
slotNum, b
position, Seq (BlockHeader, [Tx], d)
blocks, d
_) <- TVar m (a, b, Seq (BlockHeader, [Tx], d), d)
-> m (a, b, Seq (BlockHeader, [Tx], d), d)
forall a. TVar m a -> m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar m (a, b, Seq (BlockHeader, [Tx], d), d)
chain
    case Int -> Seq (BlockHeader, [Tx], d) -> Maybe (BlockHeader, [Tx], d)
forall a. Int -> Seq a -> Maybe a
Seq.lookup (b -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral b
position) Seq (BlockHeader, [Tx], d)
blocks of
      Just (BlockHeader
header, [Tx]
txs, d
utxo) -> do
        let position' :: b
position' = b
position b -> b -> b
forall a. Num a => a -> a -> a
+ b
1
        t (ChainSyncHandler m)
allHandlers <- (MockHydraNode m -> ChainSyncHandler m)
-> t (MockHydraNode m) -> t (ChainSyncHandler m)
forall a b. (a -> b) -> t a -> t 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 (t (MockHydraNode m) -> t (ChainSyncHandler m))
-> m (t (MockHydraNode m)) -> m (t (ChainSyncHandler m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar m (t (MockHydraNode m)) -> m (t (MockHydraNode m))
forall a. TVar m a -> m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar m (t (MockHydraNode m))
nodes
        -- NOTE: Need to reset the mocked chain ledger to this utxo before
        -- calling the node handlers (as they might submit transactions
        -- directly).
        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
$ TVar m (a, b, Seq (BlockHeader, [Tx], d), d)
-> (a, b, Seq (BlockHeader, [Tx], d), d) -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (a, b, Seq (BlockHeader, [Tx], d), d)
chain (a
slotNum, b
position', Seq (BlockHeader, [Tx], d)
blocks, d
utxo)
        t (ChainSyncHandler m) -> (ChainSyncHandler m -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t (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], d)
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 (t (MockHydraNode m))
-> TVar m (a, b, Seq (BlockHeader, [Tx], d), d) -> b -> m ()
rollbackAndForward TVar m (t (MockHydraNode m))
nodes TVar m (a, b, Seq (BlockHeader, [Tx], d), d)
chain b
numberOfBlocks = do
    TVar m (t (MockHydraNode m))
-> TVar m (a, b, Seq (BlockHeader, [Tx], d), d) -> b -> m ()
forall {m :: * -> *} {b} {t :: * -> *} {a} {b} {d}.
(MonadSTM m, Integral b, Foldable t, Functor t) =>
TVar m (t (MockHydraNode m))
-> TVar m (a, b, Seq (BlockHeader, b, d), d) -> b -> m ()
doRollBackward TVar m (t (MockHydraNode m))
nodes TVar m (a, b, Seq (BlockHeader, [Tx], d), d)
chain b
numberOfBlocks
    Int -> m () -> m ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ (b -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral b
numberOfBlocks) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      TVar m (t (MockHydraNode m))
-> TVar m (a, b, Seq (BlockHeader, [Tx], d), d) -> m ()
forall {m :: * -> *} {b} {t :: * -> *} {a} {d}.
(MonadSTM m, Integral b, Foldable t, Functor t) =>
TVar m (t (MockHydraNode m))
-> TVar m (a, b, Seq (BlockHeader, [Tx], d), d) -> m ()
doRollForward TVar m (t (MockHydraNode m))
nodes TVar m (a, b, Seq (BlockHeader, [Tx], d), d)
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 (t (MockHydraNode m))
-> TVar m (a, b, Seq (BlockHeader, b, d), d) -> b -> m ()
doRollBackward TVar m (t (MockHydraNode m))
nodes TVar m (a, b, Seq (BlockHeader, b, d), d)
chain b
nbBlocks = do
    (a
slotNum, b
position, Seq (BlockHeader, b, d)
blocks, d
_) <- TVar m (a, b, Seq (BlockHeader, b, d), d)
-> m (a, b, Seq (BlockHeader, b, d), d)
forall a. TVar m a -> m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar m (a, b, Seq (BlockHeader, b, d), d)
chain
    case Int -> Seq (BlockHeader, b, d) -> Maybe (BlockHeader, b, d)
forall a. Int -> Seq a -> Maybe a
Seq.lookup (b -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (b -> Int) -> b -> Int
forall a b. (a -> b) -> a -> b
$ b
position b -> b -> b
forall a. Num a => a -> a -> a
- b
nbBlocks) Seq (BlockHeader, b, d)
blocks of
      Just (BlockHeader
header, b
_, d
utxo) -> do
        let position' :: b
position' = b
position b -> b -> b
forall a. Num a => a -> a -> a
- b
nbBlocks b -> b -> b
forall a. Num a => a -> a -> a
+ b
1
        t (ChainSyncHandler m)
allHandlers <- (MockHydraNode m -> ChainSyncHandler m)
-> t (MockHydraNode m) -> t (ChainSyncHandler m)
forall a b. (a -> b) -> t a -> t 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 (t (MockHydraNode m) -> t (ChainSyncHandler m))
-> m (t (MockHydraNode m)) -> m (t (ChainSyncHandler m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar m (t (MockHydraNode m)) -> m (t (MockHydraNode m))
forall a. TVar m a -> m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar m (t (MockHydraNode m))
nodes
        let point :: ChainPoint
point = BlockHeader -> ChainPoint
getChainPoint BlockHeader
header
        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
$ TVar m (a, b, Seq (BlockHeader, b, d), d)
-> (a, b, Seq (BlockHeader, b, d), d) -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (a, b, Seq (BlockHeader, b, d), d)
chain (a
slotNum, b
position', Seq (BlockHeader, b, d)
blocks, d
utxo)
        t (ChainSyncHandler m) -> (ChainSyncHandler m -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t (ChainSyncHandler m)
allHandlers (ChainSyncHandler m -> ChainPoint -> m ()
forall (m :: * -> *). ChainSyncHandler m -> ChainPoint -> m ()
`onRollBackward` ChainPoint
point)
      Maybe (BlockHeader, b, d)
Nothing ->
        () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  addNewBlockToChain :: TVar m (ChainSlot, b, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> [Tx] -> STM m ()
addNewBlockToChain TVar m (ChainSlot, b, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain [Tx]
transactions =
    TVar m (ChainSlot, b, Seq (BlockHeader, [Tx], UTxO), UTxO)
-> ((ChainSlot, b, Seq (BlockHeader, [Tx], UTxO), UTxO)
    -> (ChainSlot, b, Seq (BlockHeader, [Tx], UTxO), UTxO))
-> 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 (ChainSlot, b, Seq (BlockHeader, [Tx], UTxO), UTxO)
chain (((ChainSlot, b, Seq (BlockHeader, [Tx], UTxO), UTxO)
  -> (ChainSlot, b, Seq (BlockHeader, [Tx], UTxO), UTxO))
 -> STM m ())
-> ((ChainSlot, b, Seq (BlockHeader, [Tx], UTxO), UTxO)
    -> (ChainSlot, b, Seq (BlockHeader, [Tx], UTxO), UTxO))
-> STM m ()
forall a b. (a -> b) -> a -> b
$ \(ChainSlot
slotNum, b
position, Seq (BlockHeader, [Tx], UTxO)
blocks, UTxO
utxo) -> do
      -- 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 = 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 silently dropped which emulates the chain behaviour that
          -- only the client is potentially witnessing the failure, and 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 UTxO
UTxOType Tx
utxo [Tx]
transactions
       in (ChainSlot
newSlot, b
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', UTxO
UTxOType Tx
utxo'), UTxO
UTxOType Tx
utxo')

-- | Construct fixed 'TimeHandle' that starts from 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.
fixedTimeHandleIndefiniteHorizon :: Gen TimeHandle
fixedTimeHandleIndefiniteHorizon :: Gen TimeHandle
fixedTimeHandleIndefiniteHorizon = do
  let startSeconds :: Pico
startSeconds = Pico
0
  let startTime :: UTCTime
startTime = POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime) -> POSIXTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ Pico -> POSIXTime
secondsToNominalDiffTime Pico
startSeconds
  Pico
uptimeSeconds <- Positive Pico -> Pico
forall a. Positive a -> a
getPositive (Positive Pico -> Pico) -> Gen (Positive Pico) -> Gen Pico
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Positive Pico)
forall a. Arbitrary a => Gen a
arbitrary
  let currentSlotNo :: SlotNo
currentSlotNo = Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ Pico -> Word64
forall b. Integral b => Pico -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Pico -> Word64) -> Pico -> Word64
forall a b. (a -> b) -> a -> b
$ Pico
uptimeSeconds Pico -> Pico -> Pico
forall a. Num a => a -> a -> a
+ Pico
startSeconds
  TimeHandle -> Gen TimeHandle
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TimeHandle -> Gen TimeHandle) -> TimeHandle -> Gen TimeHandle
forall a b. (a -> b) -> a -> b
$ HasCallStack => SlotNo -> SystemStart -> EraHistory -> TimeHandle
SlotNo -> SystemStart -> EraHistory -> TimeHandle
mkTimeHandle SlotNo
currentSlotNo (UTCTime -> SystemStart
SystemStart UTCTime
startTime) EraHistory
eraHistoryWithoutHorizon

-- | A trimmed down ledger whose only purpose is to validate
-- on-chain scripts.
scriptLedger ::
  Ledger Tx
scriptLedger :: Ledger Tx
scriptLedger =
  Ledger{ChainSlot -> UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
ChainSlot
-> UTxOType Tx
-> [Tx]
-> Either (Tx, ValidationError) (UTxOType Tx)
forall {t}. t -> UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
$sel:applyTransactions:Ledger :: ChainSlot
-> UTxOType Tx
-> [Tx]
-> Either (Tx, ValidationError) (UTxOType Tx)
applyTransactions :: forall {t}. t -> 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 :: t -> UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
applyTransactions t
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 = [ScriptExecutionError] -> Text
forall b a. (Show a, IsString b) => a -> b
show ([ScriptExecutionError] -> Text)
-> ([Either ScriptExecutionError ExecutionUnits]
    -> [ScriptExecutionError])
-> [Either ScriptExecutionError ExecutionUnits]
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either ScriptExecutionError ExecutionUnits]
-> [ScriptExecutionError]
forall a b. [Either a b] -> [a]
lefts ([Either ScriptExecutionError ExecutionUnits] -> Text)
-> [Either ScriptExecutionError ExecutionUnits] -> Text
forall a b. (a -> b) -> a -> b
$ EvaluationReport -> [Either ScriptExecutionError ExecutionUnits]
forall a. Map ScriptWitnessIndex a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList EvaluationReport
report})
          | Bool
otherwise ->
              t -> UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
applyTransactions t
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 knowlege of the cardano keys which are stored only at the `ChainComponent` level.
findOwnCardanoKey :: Party -> [(SigningKey HydraKey, CardanoSigningKey)] -> (VerificationKey PaymentKey, [VerificationKey PaymentKey])
findOwnCardanoKey :: Party
-> [(SigningKey HydraKey, CardanoSigningKey)]
-> (VerificationKey PaymentKey, [VerificationKey PaymentKey])
findOwnCardanoKey Party
me [(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 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [(SigningKey HydraKey, CardanoSigningKey)] -> Text
forall b a. (Show a, IsString b) => a -> b
show [(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 <- SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey (SigningKey PaymentKey -> VerificationKey PaymentKey)
-> ((SigningKey HydraKey, CardanoSigningKey)
    -> SigningKey PaymentKey)
-> (SigningKey HydraKey, CardanoSigningKey)
-> VerificationKey PaymentKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoSigningKey -> SigningKey PaymentKey
signingKey (CardanoSigningKey -> SigningKey PaymentKey)
-> ((SigningKey HydraKey, CardanoSigningKey) -> CardanoSigningKey)
-> (SigningKey HydraKey, CardanoSigningKey)
-> SigningKey PaymentKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SigningKey HydraKey, CardanoSigningKey) -> CardanoSigningKey
forall a b. (a, b) -> b
snd ((SigningKey HydraKey, CardanoSigningKey)
 -> VerificationKey PaymentKey)
-> Maybe (SigningKey HydraKey, CardanoSigningKey)
-> Maybe (VerificationKey PaymentKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((SigningKey HydraKey, CardanoSigningKey) -> Bool)
-> [(SigningKey HydraKey, CardanoSigningKey)]
-> Maybe (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)
-> ((SigningKey HydraKey, CardanoSigningKey) -> Party)
-> (SigningKey HydraKey, CardanoSigningKey)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SigningKey HydraKey -> Party
deriveParty (SigningKey HydraKey -> Party)
-> ((SigningKey HydraKey, CardanoSigningKey)
    -> SigningKey HydraKey)
-> (SigningKey HydraKey, CardanoSigningKey)
-> Party
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SigningKey HydraKey, CardanoSigningKey) -> SigningKey HydraKey
forall a b. (a, b) -> a
fst) [(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
$ ((SigningKey HydraKey, CardanoSigningKey)
 -> VerificationKey PaymentKey)
-> [(SigningKey HydraKey, CardanoSigningKey)]
-> [VerificationKey PaymentKey]
forall a b. (a -> b) -> [a] -> [b]
map (SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey (SigningKey PaymentKey -> VerificationKey PaymentKey)
-> ((SigningKey HydraKey, CardanoSigningKey)
    -> SigningKey PaymentKey)
-> (SigningKey HydraKey, CardanoSigningKey)
-> VerificationKey PaymentKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoSigningKey -> SigningKey PaymentKey
signingKey (CardanoSigningKey -> SigningKey PaymentKey)
-> ((SigningKey HydraKey, CardanoSigningKey) -> CardanoSigningKey)
-> (SigningKey HydraKey, CardanoSigningKey)
-> SigningKey PaymentKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SigningKey HydraKey, CardanoSigningKey) -> CardanoSigningKey
forall a b. (a, b) -> b
snd) [(SigningKey HydraKey, CardanoSigningKey)]
seedKeys)

-- TODO: unify with BehaviorSpec's ?
createMockNetwork :: MonadSTM m => DraftHydraNode Tx m -> TVar m [MockHydraNode m] -> Network m (Message Tx)
createMockNetwork :: forall (m :: * -> *).
MonadSTM m =>
DraftHydraNode Tx m
-> TVar m [MockHydraNode m] -> Network m (Message Tx)
createMockNetwork DraftHydraNode Tx m
draftNode 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
    [HydraNode Tx m]
allNodes <- (MockHydraNode m -> HydraNode Tx m)
-> [MockHydraNode m] -> [HydraNode Tx m]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MockHydraNode m -> HydraNode Tx m
forall (m :: * -> *). MockHydraNode m -> HydraNode Tx m
node ([MockHydraNode m] -> [HydraNode Tx m])
-> m [MockHydraNode m] -> m [HydraNode Tx 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
    (HydraNode Tx m -> m ()) -> [HydraNode Tx m] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HydraNode Tx m -> Message Tx -> m ()
`handleMessage` Message Tx
msg) [HydraNode Tx m]
allNodes

  handleMessage :: HydraNode Tx m -> Message Tx -> m ()
handleMessage HydraNode{InputQueue m (Input Tx)
inputQueue :: InputQueue m (Input Tx)
$sel:inputQueue:HydraNode :: forall tx (m :: * -> *). HydraNode tx m -> InputQueue m (Input tx)
inputQueue} Message Tx
msg =
    InputQueue m (Input Tx) -> Input Tx -> m ()
forall (m :: * -> *) e. InputQueue m e -> e -> m ()
enqueue InputQueue m (Input Tx)
inputQueue (Input Tx -> m ())
-> (NetworkEvent (Message Tx) -> Input Tx)
-> NetworkEvent (Message Tx)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> NetworkEvent (Message Tx) -> Input Tx
forall tx. Natural -> NetworkEvent (Message tx) -> Input tx
NetworkInput Natural
defaultTTL (NetworkEvent (Message Tx) -> m ())
-> NetworkEvent (Message Tx) -> m ()
forall a b. (a -> b) -> a -> b
$ ReceivedMessage{Party
sender :: Party
$sel:sender:ConnectivityEvent :: Party
sender, Message Tx
msg :: Message Tx
$sel:msg:ConnectivityEvent :: Message Tx
msg}

  sender :: Party
sender = DraftHydraNode Tx m -> Party
forall a. HasParty a => a -> Party
getParty DraftHydraNode Tx m
draftNode

data MockHydraNode m = MockHydraNode
  { forall (m :: * -> *). MockHydraNode m -> HydraNode Tx m
node :: HydraNode Tx m
  , forall (m :: * -> *). MockHydraNode m -> ChainSyncHandler m
chainHandler :: ChainSyncHandler m
  }

createMockChain ::
  (MonadTimer m, MonadThrow (STM m)) =>
  Tracer m DirectChainLog ->
  ChainContext ->
  SubmitTx m ->
  m TimeHandle ->
  TxIn ->
  LocalChainState m Tx ->
  Chain Tx m
createMockChain :: forall (m :: * -> *).
(MonadTimer m, MonadThrow (STM m)) =>
Tracer m DirectChainLog
-> ChainContext
-> SubmitTx m
-> m TimeHandle
-> TxIn
-> LocalChainState m Tx
-> Chain Tx m
createMockChain Tracer m DirectChainLog
tracer ChainContext
ctx 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 StandardCrypto))
-> STM m (Map TxIn (BabbageTxOut (ConwayEra StandardCrypto)))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map TxIn (BabbageTxOut (ConwayEra StandardCrypto))
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: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 DirectChainLog
-> m TimeHandle
-> TinyWallet m
-> ChainContext
-> LocalChainState m Tx
-> SubmitTx m
-> Chain Tx m
forall (m :: * -> *).
(MonadSTM m, MonadThrow (STM m)) =>
Tracer m DirectChainLog
-> GetTimeHandle m
-> TinyWallet m
-> ChainContext
-> LocalChainState m Tx
-> SubmitTx m
-> Chain Tx m
mkChain
        Tracer m DirectChainLog
tracer
        m TimeHandle
timeHandle
        TinyWallet m
wallet
        ChainContext
ctx
        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
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]
as