{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE DerivingVia       #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData        #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeApplications  #-}

{-# OPTIONS_GHC -Wno-orphans #-}

{-| This module exports data types for logging, events and configuration
-}
module Cardano.Node.Types
    (
      -- * Logging types
      PABServerLogMsg (..)

     -- * Event types
    , BlockEvent (..)

     -- * Effects
    , NodeServerEffects
    , ChainSyncHandle

     -- *  State types
    , AppState (..)
    , initialAppState
    , initialChainState

    -- * Lens functions
    , chainState
    , eventHistory

    -- * Config types
    , PABServerConfig (..)
    , NodeMode (..)
    , _MockNode
    , _AlonzoNode

    -- * newtype wrappers
    , NodeUrl (..)
    )
        where

import Cardano.BM.Data.Tracer (ToObject)
import Cardano.BM.Data.Tracer.Extras (Tagged (Tagged), mkObjectStr)
import Cardano.Chain (MockNodeServerChainState, fromEmulatorChainState)
import Cardano.Node.Emulator.Chain (ChainControlEffect, ChainEffect, ChainEvent)
import Cardano.Node.Emulator.TimeSlot (SlotConfig)
import Cardano.Protocol.Socket.Client qualified as Client
import Cardano.Protocol.Socket.Mock.Client qualified as Client
import Control.Lens (makeLenses, makePrisms, view)
import Control.Monad.Freer.Extras.Log (LogMessage, LogMsg)
import Control.Monad.Freer.Reader (Reader)
import Control.Monad.Freer.State (State)
import Control.Monad.IO.Class (MonadIO)
import Data.Aeson (FromJSON, ToJSON)
import Data.Default (Default, def)
import Data.Either (fromRight)
import Data.Map qualified as Map
import Data.Text (Text)
import Data.Time.Clock (UTCTime)
import Data.Time.Format.ISO8601 qualified as F
import Data.Time.Units (Millisecond)
import Data.Time.Units.Extra ()
import GHC.Generics (Generic)
import Ledger (Block)
import Ledger.CardanoWallet (WalletNumber)
import Plutus.Contract.Trace qualified as Trace
import Prettyprinter (Pretty, pretty, viaShow, vsep, (<+>))
import Servant.Client (BaseUrl (BaseUrl, baseUrlPort), Scheme (Http))
import Wallet.Emulator (Wallet, WalletNumber (WalletNumber))
import Wallet.Emulator qualified as EM
import Wallet.Emulator.MultiAgent qualified as MultiAgent

import Cardano.Api qualified as C
import Cardano.Api.NetworkId.Extra (NetworkIdWrapper (unNetworkIdWrapper), testnetNetworkId)
import Cardano.BM.Tracing (toObject)
import Cardano.Node.Emulator.Params (pNetworkId, testnet)
import Plutus.PAB.Arbitrary ()

-- Configuration ------------------------------------------------------------------------------------------------------

{- Note [Slot numbers in mock node]

The mock node has an internal clock that generates new slots in a regular
interval. Slots are identified by consecutive integers. What should the
initial slot number be? We can either set it to 0, so that the slot number
is the number of intervals that have passed since the process was started.
Or we can define an initial timestamp, so that the slot number is the number
of intervals since that timestamp.

The first option of counting from 0 is useful for integration tests where we
want the test outcome to be independent of when the test was run. This approach
is used in the PAB simulator.
The second option, counting from a timestamp, is more realistic and it is
useful for frontends that need to convert the slot number back to a timestamp.
We use this approach for the "proper" pab executable.

-}

newtype NodeUrl = NodeUrl BaseUrl
    deriving (Int -> NodeUrl -> ShowS
[NodeUrl] -> ShowS
NodeUrl -> String
(Int -> NodeUrl -> ShowS)
-> (NodeUrl -> String) -> ([NodeUrl] -> ShowS) -> Show NodeUrl
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NodeUrl] -> ShowS
$cshowList :: [NodeUrl] -> ShowS
show :: NodeUrl -> String
$cshow :: NodeUrl -> String
showsPrec :: Int -> NodeUrl -> ShowS
$cshowsPrec :: Int -> NodeUrl -> ShowS
Show, NodeUrl -> NodeUrl -> Bool
(NodeUrl -> NodeUrl -> Bool)
-> (NodeUrl -> NodeUrl -> Bool) -> Eq NodeUrl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeUrl -> NodeUrl -> Bool
$c/= :: NodeUrl -> NodeUrl -> Bool
== :: NodeUrl -> NodeUrl -> Bool
$c== :: NodeUrl -> NodeUrl -> Bool
Eq) via BaseUrl

-- | Which node we're connecting to
data NodeMode =
    MockNode -- ^ Connect to the PAB mock node.
    | AlonzoNode -- ^ Connect to an Alonzo node
    | NoChainSyncEvents -- ^ Do not connect to any node for chain sync events. Connect to Alonzo node for slot notifications.
    deriving stock (Int -> NodeMode -> ShowS
[NodeMode] -> ShowS
NodeMode -> String
(Int -> NodeMode -> ShowS)
-> (NodeMode -> String) -> ([NodeMode] -> ShowS) -> Show NodeMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NodeMode] -> ShowS
$cshowList :: [NodeMode] -> ShowS
show :: NodeMode -> String
$cshow :: NodeMode -> String
showsPrec :: Int -> NodeMode -> ShowS
$cshowsPrec :: Int -> NodeMode -> ShowS
Show, NodeMode -> NodeMode -> Bool
(NodeMode -> NodeMode -> Bool)
-> (NodeMode -> NodeMode -> Bool) -> Eq NodeMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeMode -> NodeMode -> Bool
$c/= :: NodeMode -> NodeMode -> Bool
== :: NodeMode -> NodeMode -> Bool
$c== :: NodeMode -> NodeMode -> Bool
Eq, (forall x. NodeMode -> Rep NodeMode x)
-> (forall x. Rep NodeMode x -> NodeMode) -> Generic NodeMode
forall x. Rep NodeMode x -> NodeMode
forall x. NodeMode -> Rep NodeMode x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep NodeMode x -> NodeMode
$cfrom :: forall x. NodeMode -> Rep NodeMode x
Generic)
    deriving anyclass (Value -> Parser [NodeMode]
Value -> Parser NodeMode
(Value -> Parser NodeMode)
-> (Value -> Parser [NodeMode]) -> FromJSON NodeMode
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [NodeMode]
$cparseJSONList :: Value -> Parser [NodeMode]
parseJSON :: Value -> Parser NodeMode
$cparseJSON :: Value -> Parser NodeMode
FromJSON, [NodeMode] -> Encoding
[NodeMode] -> Value
NodeMode -> Encoding
NodeMode -> Value
(NodeMode -> Value)
-> (NodeMode -> Encoding)
-> ([NodeMode] -> Value)
-> ([NodeMode] -> Encoding)
-> ToJSON NodeMode
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [NodeMode] -> Encoding
$ctoEncodingList :: [NodeMode] -> Encoding
toJSONList :: [NodeMode] -> Value
$ctoJSONList :: [NodeMode] -> Value
toEncoding :: NodeMode -> Encoding
$ctoEncoding :: NodeMode -> Encoding
toJSON :: NodeMode -> Value
$ctoJSON :: NodeMode -> Value
ToJSON)

makePrisms ''NodeMode

-- | Node server configuration
data PABServerConfig =
    PABServerConfig
        { PABServerConfig -> BaseUrl
pscBaseUrl                    :: BaseUrl
        -- ^ base url of the service
        , PABServerConfig -> [WalletNumber]
pscInitialTxWallets           :: [WalletNumber]
        -- ^ The wallets that receive money from the initial transaction.
        , PABServerConfig -> String
pscSocketPath                 :: FilePath
        -- ^ Path to the socket used to communicate with the server.
        , PABServerConfig -> Integer
pscKeptBlocks                 :: Integer
        -- ^ The number of blocks to keep for replaying to a newly connected clients
        , PABServerConfig -> SlotConfig
pscSlotConfig                 :: SlotConfig
        -- ^ Beginning of slot 0.
        , PABServerConfig -> NetworkIdWrapper
pscNetworkId                  :: NetworkIdWrapper
        -- ^ NetworkId that's used with the CardanoAPI.
        , PABServerConfig -> Maybe String
pscProtocolParametersJsonPath :: Maybe FilePath
        -- ^ Path to a JSON file containing the protocol parameters
        , PABServerConfig -> Maybe Text
pscPassphrase                 :: Maybe Text
        -- ^ Wallet passphrase
        , PABServerConfig -> NodeMode
pscNodeMode                   :: NodeMode
        -- ^ Whether to connect to an Alonzo node or a mock node
        }
    deriving stock (Int -> PABServerConfig -> ShowS
[PABServerConfig] -> ShowS
PABServerConfig -> String
(Int -> PABServerConfig -> ShowS)
-> (PABServerConfig -> String)
-> ([PABServerConfig] -> ShowS)
-> Show PABServerConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PABServerConfig] -> ShowS
$cshowList :: [PABServerConfig] -> ShowS
show :: PABServerConfig -> String
$cshow :: PABServerConfig -> String
showsPrec :: Int -> PABServerConfig -> ShowS
$cshowsPrec :: Int -> PABServerConfig -> ShowS
Show, PABServerConfig -> PABServerConfig -> Bool
(PABServerConfig -> PABServerConfig -> Bool)
-> (PABServerConfig -> PABServerConfig -> Bool)
-> Eq PABServerConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PABServerConfig -> PABServerConfig -> Bool
$c/= :: PABServerConfig -> PABServerConfig -> Bool
== :: PABServerConfig -> PABServerConfig -> Bool
$c== :: PABServerConfig -> PABServerConfig -> Bool
Eq, (forall x. PABServerConfig -> Rep PABServerConfig x)
-> (forall x. Rep PABServerConfig x -> PABServerConfig)
-> Generic PABServerConfig
forall x. Rep PABServerConfig x -> PABServerConfig
forall x. PABServerConfig -> Rep PABServerConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PABServerConfig x -> PABServerConfig
$cfrom :: forall x. PABServerConfig -> Rep PABServerConfig x
Generic)
    deriving anyclass (Value -> Parser [PABServerConfig]
Value -> Parser PABServerConfig
(Value -> Parser PABServerConfig)
-> (Value -> Parser [PABServerConfig]) -> FromJSON PABServerConfig
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [PABServerConfig]
$cparseJSONList :: Value -> Parser [PABServerConfig]
parseJSON :: Value -> Parser PABServerConfig
$cparseJSON :: Value -> Parser PABServerConfig
FromJSON, [PABServerConfig] -> Encoding
[PABServerConfig] -> Value
PABServerConfig -> Encoding
PABServerConfig -> Value
(PABServerConfig -> Value)
-> (PABServerConfig -> Encoding)
-> ([PABServerConfig] -> Value)
-> ([PABServerConfig] -> Encoding)
-> ToJSON PABServerConfig
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [PABServerConfig] -> Encoding
$ctoEncodingList :: [PABServerConfig] -> Encoding
toJSONList :: [PABServerConfig] -> Value
$ctoJSONList :: [PABServerConfig] -> Value
toEncoding :: PABServerConfig -> Encoding
$ctoEncoding :: PABServerConfig -> Encoding
toJSON :: PABServerConfig -> Value
$ctoJSON :: PABServerConfig -> Value
ToJSON)


defaultPABServerConfig :: PABServerConfig
defaultPABServerConfig :: PABServerConfig
defaultPABServerConfig =
    PABServerConfig :: BaseUrl
-> [WalletNumber]
-> String
-> Integer
-> SlotConfig
-> NetworkIdWrapper
-> Maybe String
-> Maybe Text
-> NodeMode
-> PABServerConfig
PABServerConfig
      -- See Note [pab-ports] in 'test/full/Plutus/PAB/CliSpec.hs'.
      { pscBaseUrl :: BaseUrl
pscBaseUrl = Scheme -> String -> Int -> String -> BaseUrl
BaseUrl Scheme
Http String
"localhost" Int
9082 String
""
      , pscInitialTxWallets :: [WalletNumber]
pscInitialTxWallets =
          [ Integer -> WalletNumber
WalletNumber Integer
1
          , Integer -> WalletNumber
WalletNumber Integer
2
          , Integer -> WalletNumber
WalletNumber Integer
3
          ]
      , pscSocketPath :: String
pscSocketPath = String
"./node-server.sock"
      , pscKeptBlocks :: Integer
pscKeptBlocks = Integer
100
      , pscSlotConfig :: SlotConfig
pscSlotConfig = SlotConfig
forall a. Default a => a
def
      , pscNetworkId :: NetworkIdWrapper
pscNetworkId = NetworkIdWrapper
testnetNetworkId
      , pscProtocolParametersJsonPath :: Maybe String
pscProtocolParametersJsonPath = Maybe String
forall a. Maybe a
Nothing
      , pscPassphrase :: Maybe Text
pscPassphrase = Maybe Text
forall a. Maybe a
Nothing
      , pscNodeMode :: NodeMode
pscNodeMode  = NodeMode
MockNode
      }

instance Default PABServerConfig where
  def :: PABServerConfig
def = PABServerConfig
defaultPABServerConfig

instance Pretty PABServerConfig where
  pretty :: PABServerConfig -> Doc ann
pretty PABServerConfig{ BaseUrl
pscBaseUrl :: BaseUrl
pscBaseUrl :: PABServerConfig -> BaseUrl
pscBaseUrl, String
pscSocketPath :: String
pscSocketPath :: PABServerConfig -> String
pscSocketPath, NetworkIdWrapper
pscNetworkId :: NetworkIdWrapper
pscNetworkId :: PABServerConfig -> NetworkIdWrapper
pscNetworkId, Integer
pscKeptBlocks :: Integer
pscKeptBlocks :: PABServerConfig -> Integer
pscKeptBlocks } =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [ Doc ann
"Socket:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
pscSocketPath
         , Doc ann
"Network Id:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> NetworkId -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (NetworkIdWrapper -> NetworkId
unNetworkIdWrapper NetworkIdWrapper
pscNetworkId)
         , Doc ann
"Port:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (BaseUrl -> Int
baseUrlPort BaseUrl
pscBaseUrl)
         , Doc ann
"Security Param:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
pscKeptBlocks
         ]

-- | The types of handles varies based on the type of clients (mocked or
-- real nodes) and we need a generic way of handling either type of response.
type ChainSyncHandle = Either (Client.ChainSyncHandle Block) (Client.ChainSyncHandle Client.ChainSyncEvent)

-- Logging ------------------------------------------------------------------------------------------------------------

-- | Top-level logging data type for structural logging
-- inside the PAB server.
data PABServerLogMsg =
    StartingSlotCoordination UTCTime Millisecond
    | NoRandomTxGeneration
    | StartingRandomTx
    | KeepingOldBlocks
    | RemovingOldBlocks
    | StartingPABServer Int
    | ProcessingChainEvent ChainEvent
    | BlockOperation BlockEvent
    | CreatingRandomTransaction
    | TxSendCalledWithoutMock
    deriving ((forall x. PABServerLogMsg -> Rep PABServerLogMsg x)
-> (forall x. Rep PABServerLogMsg x -> PABServerLogMsg)
-> Generic PABServerLogMsg
forall x. Rep PABServerLogMsg x -> PABServerLogMsg
forall x. PABServerLogMsg -> Rep PABServerLogMsg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PABServerLogMsg x -> PABServerLogMsg
$cfrom :: forall x. PABServerLogMsg -> Rep PABServerLogMsg x
Generic, Int -> PABServerLogMsg -> ShowS
[PABServerLogMsg] -> ShowS
PABServerLogMsg -> String
(Int -> PABServerLogMsg -> ShowS)
-> (PABServerLogMsg -> String)
-> ([PABServerLogMsg] -> ShowS)
-> Show PABServerLogMsg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PABServerLogMsg] -> ShowS
$cshowList :: [PABServerLogMsg] -> ShowS
show :: PABServerLogMsg -> String
$cshow :: PABServerLogMsg -> String
showsPrec :: Int -> PABServerLogMsg -> ShowS
$cshowsPrec :: Int -> PABServerLogMsg -> ShowS
Show, [PABServerLogMsg] -> Encoding
[PABServerLogMsg] -> Value
PABServerLogMsg -> Encoding
PABServerLogMsg -> Value
(PABServerLogMsg -> Value)
-> (PABServerLogMsg -> Encoding)
-> ([PABServerLogMsg] -> Value)
-> ([PABServerLogMsg] -> Encoding)
-> ToJSON PABServerLogMsg
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [PABServerLogMsg] -> Encoding
$ctoEncodingList :: [PABServerLogMsg] -> Encoding
toJSONList :: [PABServerLogMsg] -> Value
$ctoJSONList :: [PABServerLogMsg] -> Value
toEncoding :: PABServerLogMsg -> Encoding
$ctoEncoding :: PABServerLogMsg -> Encoding
toJSON :: PABServerLogMsg -> Value
$ctoJSON :: PABServerLogMsg -> Value
ToJSON, Value -> Parser [PABServerLogMsg]
Value -> Parser PABServerLogMsg
(Value -> Parser PABServerLogMsg)
-> (Value -> Parser [PABServerLogMsg]) -> FromJSON PABServerLogMsg
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [PABServerLogMsg]
$cparseJSONList :: Value -> Parser [PABServerLogMsg]
parseJSON :: Value -> Parser PABServerLogMsg
$cparseJSON :: Value -> Parser PABServerLogMsg
FromJSON)

instance Pretty PABServerLogMsg where
    pretty :: PABServerLogMsg -> Doc ann
pretty = \case
        PABServerLogMsg
NoRandomTxGeneration      -> Doc ann
"Not creating random transactions"
        PABServerLogMsg
StartingRandomTx          -> Doc ann
"Starting random transaction generation thread"
        PABServerLogMsg
KeepingOldBlocks          -> Doc ann
"Not starting block reaper thread (old blocks will be retained in-memory forever"
        PABServerLogMsg
RemovingOldBlocks         -> Doc ann
"Starting block reaper thread (old blocks will be removed)"
        StartingPABServer Int
p      -> Doc ann
"Starting PAB Server on port" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
p
        StartingSlotCoordination UTCTime
initialSlotTime Millisecond
slotLength  ->
            Doc ann
"Starting slot coordination thread."
            Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"Initial slot time:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (UTCTime -> String
forall t. ISO8601 t => t -> String
F.iso8601Show UTCTime
initialSlotTime)
            Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"Slot length:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Millisecond -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow Millisecond
slotLength
        ProcessingChainEvent ChainEvent
e    -> Doc ann
"Processing chain event" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ChainEvent -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ChainEvent
e
        BlockOperation BlockEvent
e          -> Doc ann
"Block operation" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> BlockEvent -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty BlockEvent
e
        PABServerLogMsg
CreatingRandomTransaction -> Doc ann
"Generating a random transaction"
        PABServerLogMsg
TxSendCalledWithoutMock   -> Doc ann
"Cannot send transaction without a mocked environment."

instance ToObject PABServerLogMsg where
    toObject :: TracingVerbosity -> PABServerLogMsg -> Object
toObject TracingVerbosity
_ = \case
        PABServerLogMsg
NoRandomTxGeneration      ->  Text -> () -> Object
forall k. StructuredLog k => Text -> k -> Object
mkObjectStr Text
"Not creating random transactions" ()
        PABServerLogMsg
StartingRandomTx          ->  Text -> () -> Object
forall k. StructuredLog k => Text -> k -> Object
mkObjectStr Text
"Starting random transaction generation thread" ()
        PABServerLogMsg
KeepingOldBlocks          ->  Text -> () -> Object
forall k. StructuredLog k => Text -> k -> Object
mkObjectStr Text
"Not starting block reaper thread (old blocks will be retained in-memory forever" ()
        PABServerLogMsg
RemovingOldBlocks         ->  Text -> () -> Object
forall k. StructuredLog k => Text -> k -> Object
mkObjectStr Text
"Starting block reaper thread (old blocks will be removed)" ()
        StartingPABServer Int
p      ->  Text -> Tagged "port" Int -> Object
forall k. StructuredLog k => Text -> k -> Object
mkObjectStr Text
"Starting PAB Server on port " (Int -> Tagged "port" Int
forall k (s :: k) b. b -> Tagged s b
Tagged @"port" Int
p)
        StartingSlotCoordination UTCTime
i Millisecond
l  -> Text
-> (Tagged "initial-slot-time" String,
    Tagged "slot-length" Millisecond)
-> Object
forall k. StructuredLog k => Text -> k -> Object
mkObjectStr Text
"Starting slot coordination thread" (String -> Tagged "initial-slot-time" String
forall k (s :: k) b. b -> Tagged s b
Tagged @"initial-slot-time" (UTCTime -> String
forall t. ISO8601 t => t -> String
F.iso8601Show  UTCTime
i), Millisecond -> Tagged "slot-length" Millisecond
forall k (s :: k) b. b -> Tagged s b
Tagged @"slot-length" Millisecond
l)
        ProcessingChainEvent ChainEvent
e    ->  Text -> Tagged "event" ChainEvent -> Object
forall k. StructuredLog k => Text -> k -> Object
mkObjectStr Text
"Processing chain event" (ChainEvent -> Tagged "event" ChainEvent
forall k (s :: k) b. b -> Tagged s b
Tagged @"event" ChainEvent
e)
        BlockOperation BlockEvent
e          ->  Text -> Tagged "event" BlockEvent -> Object
forall k. StructuredLog k => Text -> k -> Object
mkObjectStr Text
"Block operation" (BlockEvent -> Tagged "event" BlockEvent
forall k (s :: k) b. b -> Tagged s b
Tagged @"event" BlockEvent
e)
        PABServerLogMsg
CreatingRandomTransaction ->  Text -> () -> Object
forall k. StructuredLog k => Text -> k -> Object
mkObjectStr Text
"Creating random transaction" ()
        PABServerLogMsg
TxSendCalledWithoutMock   ->  Text -> () -> Object
forall k. StructuredLog k => Text -> k -> Object
mkObjectStr Text
"Cannot send transaction without a mocked environment." ()

data BlockEvent = NewSlot
    | NewTransaction (C.Tx C.BabbageEra)
    deriving ((forall x. BlockEvent -> Rep BlockEvent x)
-> (forall x. Rep BlockEvent x -> BlockEvent) -> Generic BlockEvent
forall x. Rep BlockEvent x -> BlockEvent
forall x. BlockEvent -> Rep BlockEvent x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BlockEvent x -> BlockEvent
$cfrom :: forall x. BlockEvent -> Rep BlockEvent x
Generic, Int -> BlockEvent -> ShowS
[BlockEvent] -> ShowS
BlockEvent -> String
(Int -> BlockEvent -> ShowS)
-> (BlockEvent -> String)
-> ([BlockEvent] -> ShowS)
-> Show BlockEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BlockEvent] -> ShowS
$cshowList :: [BlockEvent] -> ShowS
show :: BlockEvent -> String
$cshow :: BlockEvent -> String
showsPrec :: Int -> BlockEvent -> ShowS
$cshowsPrec :: Int -> BlockEvent -> ShowS
Show, [BlockEvent] -> Encoding
[BlockEvent] -> Value
BlockEvent -> Encoding
BlockEvent -> Value
(BlockEvent -> Value)
-> (BlockEvent -> Encoding)
-> ([BlockEvent] -> Value)
-> ([BlockEvent] -> Encoding)
-> ToJSON BlockEvent
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [BlockEvent] -> Encoding
$ctoEncodingList :: [BlockEvent] -> Encoding
toJSONList :: [BlockEvent] -> Value
$ctoJSONList :: [BlockEvent] -> Value
toEncoding :: BlockEvent -> Encoding
$ctoEncoding :: BlockEvent -> Encoding
toJSON :: BlockEvent -> Value
$ctoJSON :: BlockEvent -> Value
ToJSON, Value -> Parser [BlockEvent]
Value -> Parser BlockEvent
(Value -> Parser BlockEvent)
-> (Value -> Parser [BlockEvent]) -> FromJSON BlockEvent
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [BlockEvent]
$cparseJSONList :: Value -> Parser [BlockEvent]
parseJSON :: Value -> Parser BlockEvent
$cparseJSON :: Value -> Parser BlockEvent
FromJSON)

instance Pretty BlockEvent where
    pretty :: BlockEvent -> Doc ann
pretty = \case
        BlockEvent
NewSlot          -> Doc ann
"Adding a new slot"
        NewTransaction Tx BabbageEra
t -> Doc ann
"Adding a transaction " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TxId -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (TxBody BabbageEra -> TxId
forall era. TxBody era -> TxId
C.getTxId (TxBody BabbageEra -> TxId) -> TxBody BabbageEra -> TxId
forall a b. (a -> b) -> a -> b
$ Tx BabbageEra -> TxBody BabbageEra
forall era. Tx era -> TxBody era
C.getTxBody Tx BabbageEra
t)


-- State --------------------------------------------------------------------------------------------------------------

-- | Application State
data AppState =
    AppState
        { AppState -> MockNodeServerChainState
_chainState   :: MockNodeServerChainState -- ^ blockchain state
        , AppState -> [LogMessage PABServerLogMsg]
_eventHistory :: [LogMessage PABServerLogMsg] -- ^ history of all log messages
        }
    deriving (Int -> AppState -> ShowS
[AppState] -> ShowS
AppState -> String
(Int -> AppState -> ShowS)
-> (AppState -> String) -> ([AppState] -> ShowS) -> Show AppState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AppState] -> ShowS
$cshowList :: [AppState] -> ShowS
show :: AppState -> String
$cshow :: AppState -> String
showsPrec :: Int -> AppState -> ShowS
$cshowsPrec :: Int -> AppState -> ShowS
Show)

makeLenses 'AppState

-- | 'AppState' with an initial transaction that pays some Ada to
--   the wallets.
initialAppState :: MonadIO m => [Wallet] -> m AppState
initialAppState :: [Wallet] -> m AppState
initialAppState [Wallet]
wallets = do
    MockNodeServerChainState
initialState <- InitialDistribution -> m MockNodeServerChainState
forall (m :: * -> *).
MonadIO m =>
InitialDistribution -> m MockNodeServerChainState
initialChainState ([Wallet] -> InitialDistribution
Trace.defaultDistFor [Wallet]
wallets)
    AppState -> m AppState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AppState -> m AppState) -> AppState -> m AppState
forall a b. (a -> b) -> a -> b
$ AppState :: MockNodeServerChainState
-> [LogMessage PABServerLogMsg] -> AppState
AppState
        { _chainState :: MockNodeServerChainState
_chainState = MockNodeServerChainState
initialState
        , _eventHistory :: [LogMessage PABServerLogMsg]
_eventHistory = [LogMessage PABServerLogMsg]
forall a. Monoid a => a
mempty
        }

-- | 'ChainState' with initial values
initialChainState :: MonadIO m => Trace.InitialDistribution -> m MockNodeServerChainState
initialChainState :: InitialDistribution -> m MockNodeServerChainState
initialChainState =
    ChainState -> m MockNodeServerChainState
forall (m :: * -> *).
MonadIO m =>
ChainState -> m MockNodeServerChainState
fromEmulatorChainState (ChainState -> m MockNodeServerChainState)
-> (InitialDistribution -> ChainState)
-> InitialDistribution
-> m MockNodeServerChainState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting ChainState EmulatorState ChainState
-> EmulatorState -> ChainState
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ChainState EmulatorState ChainState
Lens' EmulatorState ChainState
EM.chainState (EmulatorState -> ChainState)
-> (InitialDistribution -> EmulatorState)
-> InitialDistribution
-> ChainState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EmulatorState
-> Either ToCardanoError EmulatorState -> EmulatorState
forall b a. b -> Either a b -> b
fromRight (String -> EmulatorState
forall a. HasCallStack => String -> a
error String
"Can't initialise chain state") (Either ToCardanoError EmulatorState -> EmulatorState)
-> (InitialDistribution -> Either ToCardanoError EmulatorState)
-> InitialDistribution
-> EmulatorState
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    Params
-> Map PaymentPubKeyHash Value
-> Either ToCardanoError EmulatorState
MultiAgent.emulatorStateInitialDist (Params
forall a. Default a => a
def {pNetworkId :: NetworkId
pNetworkId = NetworkId
testnet}) (Map PaymentPubKeyHash Value
 -> Either ToCardanoError EmulatorState)
-> (InitialDistribution -> Map PaymentPubKeyHash Value)
-> InitialDistribution
-> Either ToCardanoError EmulatorState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Wallet -> PaymentPubKeyHash)
-> InitialDistribution -> Map PaymentPubKeyHash Value
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys Wallet -> PaymentPubKeyHash
EM.mockWalletPaymentPubKeyHash

-- Effects -------------------------------------------------------------------------------------------------------------

type NodeServerEffects m
     = '[ ChainControlEffect
        , ChainEffect
        , State MockNodeServerChainState
        , LogMsg PABServerLogMsg
        , Reader (Maybe Client.TxSendHandle)
        , State AppState
        , LogMsg PABServerLogMsg
        , m]