{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE MonoLocalBinds      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeOperators       #-}
{-

Defines the system threads. One thread for each simulated agent, and a block
maker thread for the blockchain / network.

-}
module Plutus.Trace.Emulator.System
  ( launchSystemThreads
  , appendNewTipBlock
  ) where

import Cardano.Node.Emulator.Internal.Node (ChainControlEffect, modifySlot, processBlock)
import Control.Monad (forM_, void)
import Control.Monad.Freer
import Control.Monad.Freer.Coroutine
import Data.Default (def)
import Data.Foldable (traverse_)
import Data.Maybe (maybeToList)
import Wallet.Emulator.MultiAgent (MultiAgentControlEffect, MultiAgentEffect, walletAction, walletControlAction)

import Data.String (IsString (..))
import Ledger (Block, Slot)
import Plutus.ChainIndex (ChainIndexControlEffect, ChainSyncBlock (Block), Tip (Tip, TipAtGenesis), appendBlocks,
                          blockId, fromOnChainTx, getTip)
import Plutus.Trace.Emulator.Types (EmulatorMessage (..))
import Plutus.Trace.Scheduler (EmSystemCall, MessageCall (..), Priority (..), Tag, fork, mkSysCall, sleep)
import Wallet.Emulator.NodeClient (ChainClientNotification (..), clientNotify)
import Wallet.Emulator.Wallet (Wallet (..))

{- Note [Simulator Time]

Simulator time is measured in slots, and the current time is part of the state
of the emulated node. Advancing the clock is done by the 'blockMaker' thread, a
thread that does nothing but produce a new block & slot each time it is woken
up.

Threads that need to do to multiple things in the same slot (for example,
contract instances handling several requests) suspend themselves with the
'Normal' priority. The block maker thread suspends itself with 'Sleeping', so
every time it is woken up, all threads with the 'Normal' priority have been
processed. As a result, the simulated clock advances to the next slot whenever
there is nothing left to do in the current slot.

-}

{- Note [Simulated Agents]

Each of the simulated agents runs its own thread. The agent listens to block
added and slot changed notifications, and updates its chain index accordingly.

Every contract instance runs in the context of an agent. If we want to test how
a contract instance reacts to network issues, we can freeze the agent's thread
and unfreeze it later on. While frozen, the agent thread will not update its
internal chain index, so it keeps an outdated view of the blockchain. When the
thread is unfrozen, it will receive & process all blockchain events since the
last time it ran in the order they arrived. So no messages are dropped - they
just arrive later.

-}

-- | Start the system threads.
launchSystemThreads :: forall effs a.
    ( Member ChainControlEffect effs
    , Member MultiAgentEffect effs
    , Member MultiAgentControlEffect effs
    )
    => [Wallet]
    -> Eff (Yield (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage) ': effs) ()
launchSystemThreads :: [Wallet]
-> Eff
     (Yield
        (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage)
        : effs)
     ()
launchSystemThreads [Wallet]
wallets = do
    Maybe EmulatorMessage
_ <- Priority
-> Eff
     (Yield
        (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage)
        : effs)
     (Maybe EmulatorMessage)
forall (effs :: [* -> *]) systemEvent (effs2 :: [* -> *]) a.
Member
  (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent))
  effs2 =>
Priority -> Eff effs2 (Maybe systemEvent)
sleep @effs @EmulatorMessage @_ @a Priority
Sleeping
    -- 1. Threads for updating the agents' states. See note [Simulated Agents]
    (Wallet
 -> Eff
      (Yield
         (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage)
         : effs)
      (Maybe EmulatorMessage))
-> [Wallet]
-> Eff
     (Yield
        (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage)
        : effs)
     ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\Wallet
w -> Tag
-> Priority
-> Eff
     (Reader ThreadId
        : Yield
            (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage)
        : effs)
     ()
-> Eff
     (Yield
        (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage)
        : effs)
     (Maybe EmulatorMessage)
forall (effs :: [* -> *]) systemEvent (effs2 :: [* -> *]) a.
Member
  (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent))
  effs2 =>
Tag
-> Priority
-> Eff
     (Reader ThreadId
        : Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)
        : effs)
     ()
-> Eff effs2 (Maybe systemEvent)
fork @effs @EmulatorMessage @_ @a (Wallet -> Tag
agentTag Wallet
w) Priority
Normal (Eff
   (Reader ThreadId
      : Yield
          (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage)
      : effs)
   ()
 -> Eff
      (Yield
         (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage)
         : effs)
      (Maybe EmulatorMessage))
-> Eff
     (Reader ThreadId
        : Yield
            (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage)
        : effs)
     ()
-> Eff
     (Yield
        (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage)
        : effs)
     (Maybe EmulatorMessage)
forall a b. (a -> b) -> a -> b
$ Wallet
-> Eff
     (Reader ThreadId
        : Yield
            (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage)
        : effs)
     ()
forall (effs :: [* -> *]) (effs2 :: [* -> *]) a.
(Member MultiAgentEffect effs2,
 Member MultiAgentControlEffect effs2,
 Member
   (Yield
      (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage))
   effs2) =>
Wallet -> Eff effs2 ()
agentThread @effs @_ @a Wallet
w) [Wallet]
wallets
    -- 2. Block maker thread. See note [Simulator Time]
    Eff
  (Yield
     (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage)
     : effs)
  (Maybe EmulatorMessage)
-> Eff
     (Yield
        (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage)
        : effs)
     ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Eff
   (Yield
      (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage)
      : effs)
   (Maybe EmulatorMessage)
 -> Eff
      (Yield
         (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage)
         : effs)
      ())
-> Eff
     (Yield
        (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage)
        : effs)
     (Maybe EmulatorMessage)
-> Eff
     (Yield
        (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage)
        : effs)
     ()
forall a b. (a -> b) -> a -> b
$ Tag
-> Priority
-> Eff
     (Reader ThreadId
        : Yield
            (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage)
        : effs)
     ()
-> Eff
     (Yield
        (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage)
        : effs)
     (Maybe EmulatorMessage)
forall (effs :: [* -> *]) systemEvent (effs2 :: [* -> *]) a.
Member
  (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent))
  effs2 =>
Tag
-> Priority
-> Eff
     (Reader ThreadId
        : Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)
        : effs)
     ()
-> Eff effs2 (Maybe systemEvent)
fork @effs @EmulatorMessage @_ @a Tag
blockMakerTag Priority
Normal ((Member
   ChainControlEffect
   (Reader ThreadId
      : Yield
          (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage)
      : effs),
 Member
   (Yield
      (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage))
   (Reader ThreadId
      : Yield
          (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage)
      : effs)) =>
Eff
  (Reader ThreadId
     : Yield
         (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage)
     : effs)
  ()
forall (effs :: [* -> *]) (effs2 :: [* -> *]) a.
(Member ChainControlEffect effs2,
 Member
   (Yield
      (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage))
   effs2) =>
Eff effs2 ()
blockMaker @effs @_ @a)

-- | Tag for an agent thread. See note [Thread Tag]
agentTag :: Wallet -> Tag
agentTag :: Wallet -> Tag
agentTag (Wallet Maybe String
_ WalletId
i) = String -> Tag
forall a. IsString a => String -> a
fromString (String
"W " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> WalletId -> String
forall a. Show a => a -> String
show WalletId
i)

-- | Tag for the block maker thread. See note [Thread Tag]
blockMakerTag :: Tag
blockMakerTag :: Tag
blockMakerTag = Tag
"block maker"

-- | The block maker thread. See note [Simulator Time]
blockMaker :: forall effs effs2 a.
    ( Member ChainControlEffect effs2
    , Member (Yield (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage)) effs2
    )
    => Eff effs2 ()
blockMaker :: Eff effs2 ()
blockMaker = Eff effs2 ()
go where
    go :: Eff effs2 ()
go = do
        Block
newBlock <- Eff effs2 Block
forall (effs :: [* -> *]).
Member ChainControlEffect effs =>
Eff effs Block
processBlock
        Slot
newSlot <- (Slot -> Slot) -> Eff effs2 Slot
forall (effs :: [* -> *]).
Member ChainControlEffect effs =>
(Slot -> Slot) -> Eff effs Slot
modifySlot Slot -> Slot
forall a. Enum a => a -> a
succ
        Maybe EmulatorMessage
_ <- Priority
-> SysCall effs EmulatorMessage a
-> Eff effs2 (Maybe EmulatorMessage)
forall (effs :: [* -> *]) systemEvent (effs2 :: [* -> *]) a.
Member
  (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent))
  effs2 =>
Priority
-> SysCall effs systemEvent a -> Eff effs2 (Maybe systemEvent)
mkSysCall @effs @_ @_ @a Priority
Sleeping (SysCall effs EmulatorMessage a
 -> Eff effs2 (Maybe EmulatorMessage))
-> SysCall effs EmulatorMessage a
-> Eff effs2 (Maybe EmulatorMessage)
forall a b. (a -> b) -> a -> b
$ MessageCall EmulatorMessage -> SysCall effs EmulatorMessage a
forall a b. a -> Either a b
Left (MessageCall EmulatorMessage -> SysCall effs EmulatorMessage a)
-> MessageCall EmulatorMessage -> SysCall effs EmulatorMessage a
forall a b. (a -> b) -> a -> b
$ EmulatorMessage -> MessageCall EmulatorMessage
forall systemEvent. systemEvent -> MessageCall systemEvent
Broadcast (EmulatorMessage -> MessageCall EmulatorMessage)
-> EmulatorMessage -> MessageCall EmulatorMessage
forall a b. (a -> b) -> a -> b
$ [Block] -> Slot -> EmulatorMessage
NewSlot [Block
newBlock] Slot
newSlot
        Maybe EmulatorMessage
_ <- Priority -> Eff effs2 (Maybe EmulatorMessage)
forall (effs :: [* -> *]) systemEvent (effs2 :: [* -> *]) a.
Member
  (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent))
  effs2 =>
Priority -> Eff effs2 (Maybe systemEvent)
sleep @effs @EmulatorMessage @effs2 @a Priority
Sleeping
        Eff effs2 ()
go

-- | Thread for a simulated agent. See note [Simulated Agents]
agentThread :: forall effs effs2 a.
    ( Member MultiAgentEffect effs2
    , Member MultiAgentControlEffect effs2
    , Member (Yield (EmSystemCall effs EmulatorMessage a) (Maybe EmulatorMessage)) effs2
    )
    => Wallet
    -> Eff effs2 ()
agentThread :: Wallet -> Eff effs2 ()
agentThread Wallet
wllt = Eff effs2 ()
go where
    go :: Eff effs2 ()
go = do
        Maybe EmulatorMessage
e <- Priority -> Eff effs2 (Maybe EmulatorMessage)
forall (effs :: [* -> *]) systemEvent (effs2 :: [* -> *]) a.
Member
  (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent))
  effs2 =>
Priority -> Eff effs2 (Maybe systemEvent)
sleep @effs @EmulatorMessage @_ @a Priority
Sleeping
        let clientNotis :: [ChainClientNotification]
clientNotis = Maybe EmulatorMessage -> [EmulatorMessage]
forall a. Maybe a -> [a]
maybeToList Maybe EmulatorMessage
e [EmulatorMessage]
-> (EmulatorMessage -> [ChainClientNotification])
-> [ChainClientNotification]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                NewSlot [Block]
blocks Slot
slot -> (Block -> ChainClientNotification)
-> [Block] -> [ChainClientNotification]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Block -> ChainClientNotification
BlockValidated [Block]
blocks [ChainClientNotification]
-> [ChainClientNotification] -> [ChainClientNotification]
forall a. [a] -> [a] -> [a]
++ [Slot -> ChainClientNotification
SlotChanged Slot
slot]
                EmulatorMessage
_                   -> []
        [ChainClientNotification]
-> (ChainClientNotification -> Eff effs2 ()) -> Eff effs2 ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ChainClientNotification]
clientNotis ((ChainClientNotification -> Eff effs2 ()) -> Eff effs2 ())
-> (ChainClientNotification -> Eff effs2 ()) -> Eff effs2 ()
forall a b. (a -> b) -> a -> b
$ \ChainClientNotification
n -> Wallet -> Eff EmulatedWalletControlEffects () -> Eff effs2 ()
forall (effs :: [* -> *]) r.
Member MultiAgentControlEffect effs =>
Wallet -> Eff EmulatedWalletControlEffects r -> Eff effs r
walletControlAction Wallet
wllt (Eff EmulatedWalletControlEffects () -> Eff effs2 ())
-> Eff EmulatedWalletControlEffects () -> Eff effs2 ()
forall a b. (a -> b) -> a -> b
$ ChainClientNotification -> Eff EmulatedWalletControlEffects ()
forall (effs :: [* -> *]).
Member NodeClientControlEffect effs =>
ChainClientNotification -> Eff effs ()
clientNotify ChainClientNotification
n

        Tip
currentTip <- Wallet -> Eff EmulatedWalletEffects Tip -> Eff effs2 Tip
forall (effs :: [* -> *]) r.
Member MultiAgentEffect effs =>
Wallet -> Eff EmulatedWalletEffects r -> Eff effs r
walletAction Wallet
wllt Eff EmulatedWalletEffects Tip
forall (effs :: [* -> *]).
Member ChainIndexQueryEffect effs =>
Eff effs Tip
getTip
        Wallet -> Eff EmulatedWalletControlEffects () -> Eff effs2 ()
forall (effs :: [* -> *]) r.
Member MultiAgentControlEffect effs =>
Wallet -> Eff EmulatedWalletControlEffects r -> Eff effs r
walletControlAction Wallet
wllt (Eff EmulatedWalletControlEffects () -> Eff effs2 ())
-> Eff EmulatedWalletControlEffects () -> Eff effs2 ()
forall a b. (a -> b) -> a -> b
$ do
          case Maybe EmulatorMessage
e of
            Just (NewSlot [Block]
blocks Slot
slot) -> do
              Tip -> Block -> Slot -> Eff EmulatedWalletControlEffects ()
forall (effs :: [* -> *]).
Member ChainIndexControlEffect effs =>
Tip -> Block -> Slot -> Eff effs ()
appendNewTipBlock Tip
currentTip ([Block] -> Block
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Block]
blocks) Slot
slot
            Maybe EmulatorMessage
_ -> () -> Eff EmulatedWalletControlEffects ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        Eff effs2 ()
go

-- | Append a block to the chain index for a specific slot.
appendNewTipBlock ::
    ( Member ChainIndexControlEffect effs
    )
    => Tip -- ^ Most recent tip
    -> Block -- ^ List of transactions
    -> Slot -- ^ Next slot to append the block
    -> Eff effs ()
appendNewTipBlock :: Tip -> Block -> Slot -> Eff effs ()
appendNewTipBlock Tip
lastTip Block
block Slot
newSlot = do
  let nextBlockNo :: BlockNumber
nextBlockNo = case Tip
lastTip of Tip
TipAtGenesis -> BlockNumber
0
                                    Tip Slot
_ BlockId
_ BlockNumber
n    -> BlockNumber
n BlockNumber -> BlockNumber -> BlockNumber
forall a. Num a => a -> a -> a
+ BlockNumber
1
      newTip :: Tip
newTip = Slot -> BlockId -> BlockNumber -> Tip
Tip Slot
newSlot (Block -> BlockId
blockId Block
block) BlockNumber
nextBlockNo
  [ChainSyncBlock] -> Eff effs ()
forall (effs :: [* -> *]).
Member ChainIndexControlEffect effs =>
[ChainSyncBlock] -> Eff effs ()
appendBlocks [Tip -> [(ChainIndexTx, TxProcessOption)] -> ChainSyncBlock
Block Tip
newTip ((OnChainTx -> (ChainIndexTx, TxProcessOption))
-> Block -> [(ChainIndexTx, TxProcessOption)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\OnChainTx
tx -> (OnChainTx -> ChainIndexTx
fromOnChainTx OnChainTx
tx, TxProcessOption
forall a. Default a => a
def)) Block
block)]