SCB: Work on mock node (#1841)

  • Make compile

  • Add Plutus.SCV.Events.Node

  • Add a tx to the node’s mempool

  • Log new transactions

  • node server: Make some values configurable

  • activitySimulator -> slotCoordinator

  • node server: Use chain state instead of emulator state; freer-simple

  • mock node: Add a random tx generator

  • Warnings

  • Use initial distribution

  • node server: Periodically discard old blocks

View on GitHub
File Changes
import           Data.Aeson                 (FromJSON, ToJSON)
import           Data.List                  (partition)
import           Data.Maybe                 (isNothing)
-
import           Data.Text.Prettyprint.Doc  hiding (annotate)
+
import           Data.Text.Prettyprint.Doc
import           Data.Traversable           (for)
import           GHC.Generics               (Generic)
import           Ledger                     (Block, Blockchain, Slot (..), Tx (..), TxId, lastSlot, txId)
runCliCommand DbStats = Right <$> Core.dbStats
runCliCommand Migrate = Right <$> Core.migrate
runCliCommand MockWallet = Right <$> WalletServer.main
-
runCliCommand MockNode = Right <$> NodeServer.main
+
runCliCommand MockNode = Right <$> NodeServer.main NodeServer.defaultConfig
runCliCommand WalletClient = Right <$> liftIO WalletClient.main
runCliCommand NodeClient = Right <$> liftIO NodeClient.main
-
runCliCommand (InstallContract path) = Core.installContract path
-
runCliCommand (ActivateContract path) = Core.activateContract path
+
runCliCommand (InstallContract path) = Right <$> Core.installContract path
+
-- runCliCommand (ActivateContract path) = Core.activateContract path
runCliCommand (ContractStatus uuid) = Right <$> Core.reportContractStatus uuid
runCliCommand ReportInstalledContracts = do
    logInfoN "Installed Contracts"
    logInfoN "Active Contracts"
    traverse_ (logInfoN . render) =<< Core.activeContracts
    pure $ Right ()
-
runCliCommand (UpdateContract uuid endpoint payload) =
-
    Core.updateContract uuid endpoint payload
+
-- runCliCommand (UpdateContract uuid endpoint payload) =
+
--     Core.updateContract uuid endpoint payload
runCliCommand (ReportContractHistory uuid) = do
    logInfoN "Contract History"
    itraverse_
    exposed-modules:
        Cardano.Node.API
        Cardano.Node.Client
+
        Cardano.Node.RandomTx
        Cardano.Node.MockServer
+
        Cardano.Node.SimpleLog
        Cardano.Node.Types
        Cardano.Wallet.API
        Cardano.Wallet.Client
        Plutus.SCB.Events.Contract
        Plutus.SCB.Events.Mock
        Plutus.SCB.Events.User
+
        Plutus.SCB.Events.Node
        Servant.Extra
    hs-source-dirs: src
    build-depends:
        uuid -any,
        vector -any,
        warp -any,
-
        yaml -any
+
        yaml -any,
+
        freer-simple -any,
+
        mwc-random -any,
+
        primitive -any,
+
        hedgehog -any

                      
executable plutus-scb
    main-is: Main.hs
    ( API
    ) where

                      
-
import           Ledger      (Slot)
-
import           Servant.API ((:<|>), (:>), Get, JSON, NoContent, Put)
+
import           Ledger      (Tx, Slot)
+
import           Servant.API ((:<|>), (:>), Get, JSON, NoContent, ReqBody, Post)

                      
type API
     = "healthcheck" :> Get '[ JSON] NoContent
-
       :<|> "block" :> (Get '[ JSON] Slot
-
                        :<|> "add" :> Put '[ JSON] Slot)
+
       :<|> "mempool" :> ReqBody '[ JSON] Tx :> Post '[ JSON] NoContent
+
       :<|> "slot" :> Get '[ JSON] Slot
+
       :<|> "random-tx" :> Get '[ JSON] Tx
module Cardano.Node.Client where

                      
import           Cardano.Node.API    (API)
-
import           Data.Function       ((&))
import           Data.Proxy          (Proxy (Proxy))
-
import           Ledger              (Slot)
+
import           Ledger              (Slot, Tx)
import           Network.HTTP.Client (defaultManagerSettings, newManager)
-
import           Servant             (NoContent)
+
import           Servant             (NoContent, (:<|>)(..))
import           Servant.Client      (ClientM, client, mkClientEnv, parseBaseUrl, runClientM)
-
import           Servant.Extra       (left, right)

                      
healthcheck :: ClientM NoContent
getCurrentSlot :: ClientM Slot
-
addBlock :: ClientM Slot
-
(healthcheck, getCurrentSlot, addBlock) =
-
    (healthcheck_, getCurrentSlot_, addBlock_)
+
addTx :: Tx -> ClientM NoContent
+
randomTx :: ClientM Tx
+
(healthcheck, addTx, getCurrentSlot, randomTx) =
+
    (healthcheck_, addTx_, getCurrentSlot_, randomTx_)
  where
-
    api = client (Proxy @API)
-
    healthcheck_ = left api
-
    getCurrentSlot_ = right api & left
-
    addBlock_ = right api & right
-

                      
+
    healthcheck_ :<|> addTx_ :<|> getCurrentSlot_ :<|> randomTx_ = client (Proxy @API)
+
    
main :: IO ()
main = do
    manager <- newManager defaultManagerSettings
+
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
+
{-# LANGUAGE GADTs               #-}
+
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeOperators       #-}

                      
-
module Cardano.Node.MockServer where
-

                      
-
import           Cardano.Node.API         (API)
-
import           Control.Concurrent       (forkIO, threadDelay)
-
import           Control.Concurrent.MVar  (MVar, newMVar, putMVar, takeMVar)
-
import           Control.Lens             (view)
-
import           Control.Monad            (forever, void)
-
import           Control.Monad.Except     (ExceptT (ExceptT), runExceptT, throwError)
-
import           Control.Monad.IO.Class   (MonadIO, liftIO)
-
import           Control.Monad.Logger     (MonadLogger, logInfoN)
-
import           Control.Monad.State      (StateT, get, gets, put, runStateT)
-
import qualified Data.ByteString.Lazy     as BL
-
import           Data.Proxy               (Proxy (Proxy))
-
import           Data.Text                (Text)
-
import qualified Data.Text.Encoding       as Text
-
import           Data.Time.Units          (Second, toMicroseconds)
-
import           Ledger                   (Slot)
-
import qualified Ledger.Blockchain        as Blockchain
-
import           Network.Wai.Handler.Warp (run)
-
import           Plutus.SCB.Arbitrary     ()
-
import           Plutus.SCB.Utils         (tshow)
-
import           Servant                  ((:<|>) ((:<|>)), Application, Handler (Handler), NoContent (NoContent),
-
                                           err500, errBody, hoistServer, serve)
-
import           Wallet.Emulator          (EmulatorState, MonadEmulator, emptyEmulatorState)
-
import qualified Wallet.Emulator          as EM
+
module Cardano.Node.MockServer(
+
    MockServerConfig(..)
+
    , defaultConfig
+
    , main
+
    ) where
+

                      
+
import           Cardano.Node.API               (API)
+
import           Control.Concurrent             (forkIO, threadDelay)
+
import           Control.Concurrent.MVar        (MVar, newMVar, putMVar, takeMVar)
+
import           Control.Lens                   (view, over)
+
import           Control.Monad                  (forever, void)
+
import           Control.Monad.Freer            (Eff, Member)
+
import           Control.Monad.Freer.State      (State)
+
import qualified Control.Monad.Freer.State      as Eff
+
import           Control.Monad.Freer.Writer     (Writer)
+
import qualified Control.Monad.Freer.Writer     as Eff
+
import           Control.Monad.IO.Class         (MonadIO, liftIO)
+
import           Control.Monad.Logger           (MonadLogger, logDebugN, logInfoN, runStdoutLoggingT)
+
import           Data.Foldable                  (traverse_)
+
import qualified Data.Map                       as Map
+
import           Data.Proxy                     (Proxy (Proxy))
+
import           Data.Text.Prettyprint.Doc      (Pretty (pretty))
+
import           Data.Time.Units                (Second, toMicroseconds)
+

                      
+
import qualified Network.Wai.Handler.Warp       as Warp
+
import           Servant                        ((:<|>) ((:<|>)), Application, NoContent (NoContent), hoistServer,
+
                                                 serve)
+

                      
+
import           Language.Plutus.Contract.Trace (InitialDistribution)
+
import qualified Language.Plutus.Contract.Trace as Trace
+

                      
+
import           Ledger                         (Slot, Tx)
+
import qualified Ledger
+
import qualified Ledger.Blockchain              as Blockchain
+

                      
+
import           Cardano.Node.RandomTx
+
import           Cardano.Node.SimpleLog
+

                      
+
import           Plutus.SCB.Arbitrary           ()
+
import           Plutus.SCB.Utils               (tshow)
+

                      
+
import qualified Wallet.Emulator                as EM
+
import           Wallet.Emulator.Chain          (ChainEffect, ChainEvent, ChainState)
+
import qualified Wallet.Emulator.Chain          as Chain
+
import qualified Wallet.Emulator.MultiAgent     as MultiAgent
+

                      
+
data BlockReaperConfig =
+
    BlockReaperConfig
+
        { brcInterval :: Second
+
        , brcBlocksToKeep :: Int
+
        }
+

                      
+
data MockServerConfig =
+
    MockServerConfig
+
        { mscPort                :: Int
+
        , mscSlotLength          :: Second
+
        -- ^ Duration of one slot
+
        , mscRandomTxInterval    :: Maybe Second
+
        -- ^ Time between two randomly generated transactions
+
        , mscInitialDistribution :: InitialDistribution
+
        -- ^ Initial distribution of funds to wallets
+
        , mscBlockReaper         :: Maybe BlockReaperConfig
+
        -- ^ When to discard old blocks
+
        }
+

                      
+
defaultConfig :: MockServerConfig
+
defaultConfig =
+
    MockServerConfig
+
        { mscPort = 8082
+
        , mscSlotLength = 5
+
        , mscRandomTxInterval = Just 20
+
        , mscInitialDistribution = Trace.defaultDist
+
        , mscBlockReaper = Just BlockReaperConfig{brcInterval = 600, brcBlocksToKeep = 100 }
+
        }

                      
healthcheck :: Monad m => m NoContent
healthcheck = pure NoContent

                      
-
getCurrentSlot :: MonadEmulator e m => m Slot
-
getCurrentSlot =
-
    gets (Blockchain.lastSlot . view (EM.chainState . EM.chainNewestFirst))
+
getCurrentSlot :: (Member (State ChainState) effs) => Eff effs Slot
+
getCurrentSlot = Eff.gets (Blockchain.lastSlot . view EM.chainNewestFirst)

                      
-
addBlock :: MonadEmulator e m => m Slot
+
addBlock :: (Member SimpleLog effs, Member ChainEffect effs) => Eff effs ()
addBlock = do
-
    chainState <- get
-
    let (value, newState) =
-
            EM.runEmulator chainState $
-
            EM.EmulatorAction $ EM.processEmulated $ EM.addBlocks 1
-
    case value of
-
        Left err -> throwError err
-
        Right _ -> do
-
            put newState
-
            getCurrentSlot
+
    simpleLogInfo "Adding slot"
+
    void Chain.processBlock
+

                      
+
addTx :: (Member SimpleLog effs, Member ChainEffect effs) => Tx -> Eff effs NoContent
+
addTx tx = do
+
    simpleLogInfo  $ "Adding tx " <> tshow (Ledger.txId tx)
+
    simpleLogDebug $ tshow (pretty tx)
+
    Chain.queueTx tx
+
    pure NoContent
+

                      
+
type NodeServerEffects m = [GenRandomTx, ChainEffect, State ChainState, Writer [ChainEvent], SimpleLog, m]

                      
------------------------------------------------------------
-
asHandler ::
-
       MVar EmulatorState
-
    -> StateT EmulatorState (ExceptT Text IO) a
-
    -> Handler a
-
asHandler stateVar action = Handler . ExceptT $ stepState stateVar runAction
-
  where
-
    runAction oldState = do
-
        result <- runExceptT $ runStateT action oldState
-
        case result of
-
            Left err ->
-
                pure
-
                    ( Left $
-
                      err500 {errBody = BL.fromStrict $ Text.encodeUtf8 err}
-
                    , oldState)
-
            Right (value, newState) -> pure (Right value, newState)
-

                      
-
asThread ::
-
       MVar EmulatorState
-
    -> StateT EmulatorState (ExceptT Text IO) a
-
    -> IO (Either Text a)
-
asThread stateVar action = stepState stateVar runAction
-
  where
-
    runAction oldState = do
-
        result <- runExceptT $ runStateT action oldState
-
        case result of
-
            Left err                -> pure (Left err, oldState)
-
            Right (value, newState) -> pure (Right value, newState)
-

                      
-
activitySimulator :: MVar EmulatorState -> IO ()
-
activitySimulator stateVar =
-
    forever $ do
-
        void $ asThread stateVar addBlock
-
        threadDelay $ fromIntegral $ toMicroseconds (5 :: Second)

                      
-
stepState :: MonadIO m => MVar a -> (a -> m (b, a)) -> m b
-
stepState stateVar action = do
+
runChainEffects ::
+
        ( MonadIO m, MonadLogger m )
+
        => MVar ChainState
+
        -> Eff (NodeServerEffects m) a
+
        -> m ([ChainEvent], a)
+
runChainEffects stateVar eff = do
    oldState <- liftIO $ takeMVar stateVar
-
    (value, newState) <- action oldState
+
    ((a, newState), events) <- runSimpleLog
+
        $ Eff.runWriter
+
        $ Eff.runState oldState
+
        $ Chain.handleChain
+
        $ runGenRandomTx eff
    liftIO $ putMVar stateVar newState
-
    pure value
+
    pure (events, a)
+

                      
+
processChainEffects ::
+
    ( MonadIO m, MonadLogger m )
+
    => MVar ChainState
+
{-# LANGUAGE DataKinds         #-}
+
{-# LANGUAGE FlexibleContexts  #-}
+
{-# LANGUAGE GADTs             #-}
+
{-# LANGUAGE LambdaCase        #-}
+
{-# LANGUAGE NamedFieldPuns    #-}
+
{-# LANGUAGE OverloadedStrings #-}
+
{-# LANGUAGE TypeOperators     #-}
+
module Cardano.Node.RandomTx(
+
  -- $randomTx
+
  GenRandomTx
+
  , genRandomTx
+
  , runGenRandomTx
+
  ) where
+

                      
+
import           Control.Lens              (view, (&), (.~))
+
import           Control.Monad.Freer       (Eff, LastMember, Member)
+
import qualified Control.Monad.Freer       as Eff
+
import           Control.Monad.Freer.State (State)
+
import qualified Control.Monad.Freer.State as Eff
+
import           Control.Monad.IO.Class    (MonadIO, liftIO)
+
import           Control.Monad.Primitive   (PrimMonad, PrimState)
+
import           Data.List.NonEmpty        (NonEmpty (..))
+
import qualified Data.Map                  as Map
+
import           Data.Maybe                (fromMaybe)
+
import qualified Data.Set                  as Set
+
import qualified Hedgehog.Gen              as Gen
+
import           System.Random.MWC         as MWC
+

                      
+
import qualified Ledger.Ada                as Ada
+
import qualified Ledger.Address            as Address
+
import           Ledger.Crypto             (PrivateKey, PubKey)
+
import qualified Ledger.Crypto             as Crypto
+
import           Ledger.Index              (UtxoIndex (..))
+
import           Ledger.Tx                 (Tx, TxOut (..))
+
import qualified Ledger.Tx                 as Tx
+

                      
+
import qualified Wallet.Emulator           as EM
+
import           Wallet.Emulator.Chain     (ChainState)
+
import qualified Wallet.Generators         as Generators
+

                      
+
import           Cardano.Node.SimpleLog
+

                      
+
-- $randomTx
+
-- Generate a random, valid transaction that moves some ada
+
-- around between the emulator wallets.
+

                      
+
data GenRandomTx r where
+
    GenRandomTx :: GenRandomTx Tx
+

                      
+
genRandomTx :: Member GenRandomTx effs => Eff effs Tx
+
genRandomTx = Eff.send GenRandomTx
+

                      
+
runGenRandomTx ::
+
    ( Member (State ChainState) effs
+
    , Member SimpleLog effs
+
    , LastMember m effs
+
    , MonadIO m
+
    )
+
    => Eff (GenRandomTx ': effs) a
+
    -> Eff effs a
+
runGenRandomTx = Eff.interpret (\case
+
    GenRandomTx -> do
+
        UtxoIndex utxo <- Eff.gets (view EM.index)
+
        simpleLogDebug "Generating a random transaction"
+
        Eff.sendM $ liftIO $ do
+
          gen <- MWC.createSystemRandom
+
          (sourcePrivKey, sourcePubKey) <- pickNEL gen keyPairs
+
          (_, targetPubKey) <- pickNEL gen keyPairs
+
          let
+
            sourceAddress = Address.pubKeyAddress sourcePubKey
+

                      
+
            -- outputs at the source address
+
            sourceOutputs =
+
              -- we restrict ourselves to outputs that contain no currencies other than Ada,
+
              -- so that we can then split the total amount using 'Generators.splitVal'.
+
              --
+
              -- TODO: A generalised version of 'Generators.splitVal' that works on 'Value'
+
              -- We definitely need this for creating multi currency transactions!
+
              filter (\(_, TxOut{txOutValue}) -> txOutValue == Ada.toValue (Ada.fromValue txOutValue))
+
              $ filter (\(_, TxOut{txOutAddress}) -> txOutAddress == sourceAddress)
+
              $ Map.toList utxo
+

                      
+
          -- list of inputs owned by 'sourcePrivKey' that we are going to spend
+
          -- in the transaction
+
          inputs <- sublist gen sourceOutputs
+

                      
+
          let -- Total Ada amount that we want to spend
+
              sourceAda = foldMap (Ada.fromValue . txOutValue . snd) inputs
+
              -- inputs of the transaction
+
              sourceTxIns = fmap (Tx.pubKeyTxIn . fst) inputs
+
          outputValues <- Gen.sample (Generators.splitVal 10 sourceAda)
+
          let targetTxOuts = fmap (\ada -> Tx.pubKeyTxOut (Ada.toValue ada) targetPubKey) outputValues
+

                      
+
              -- the transaction :)
+
              tx = mempty
+
                    & Tx.inputs .~ Set.fromList sourceTxIns
+
                    & Tx.outputs .~ targetTxOuts
+
                    & Tx.addSignature sourcePrivKey
+
          return tx
+
    )
+

                      
+
keyPairs :: NonEmpty (PrivateKey, PubKey)
+
keyPairs = fmap
+
  (\pk -> (pk, Crypto.toPublicKey pk))
+
  (Crypto.privateKey1 :| drop 1 Crypto.knownPrivateKeys)
+

                      
+
-- | Pick a random element from a non-empty list
+
pickNEL :: PrimMonad m => Gen (PrimState m) -> NonEmpty a -> m a
+
pickNEL gen (x :| xs) = fmap (fromMaybe x) $ pick gen (x:xs)
+

                      
+
-- | Pick a random element from a list
+
pick :: PrimMonad m => Gen (PrimState m) -> [a] -> m (Maybe a)
+
pick _   [] = return Nothing
+
pick gen xs = do
+
  idx <- MWC.uniformR (0, pred $ length xs) gen
+
  return $ Just $ xs !! idx
+

                      
+
-- | Pick a random sublist
+
sublist :: PrimMonad m => Gen (PrimState m) -> [a] -> m [a]
+
sublist gen list = do
+
  includes <- traverse (\_ -> MWC.uniform gen) [1..length list]
+
  return
+
    $ fmap fst
+
    $ filter snd
+
    $ zip list includes
+
{-# LANGUAGE DataKinds        #-}
+
{-# LANGUAGE FlexibleContexts #-}
+
{-# LANGUAGE GADTs            #-}
+
{-# LANGUAGE LambdaCase       #-}
+
module Cardano.Node.SimpleLog(
+
  -- $simpleLog
+
  SimpleLog
+
  , simpleLogDebug
+
  , simpleLogInfo
+
  , runSimpleLog
+
  ) where
+

                      
+
import           Control.Monad.Freer        (Eff, Member)
+
import qualified Control.Monad.Freer        as Eff
+
import           Control.Monad.IO.Class     (MonadIO)
+
import           Control.Monad.Logger       (MonadLogger, logDebugN, logInfoN, runStdoutLoggingT)
+
import           Data.Text                  (Text)
+

                      
+
-- $simpleLog
+
-- A @[email protected] wrapper around @[email protected]
+

                      
+
data SimpleLog r where
+
    SimpleLogInfo :: Text -> SimpleLog ()
+
    SimpleLogDebug :: Text -> SimpleLog ()
+

                      
+
simpleLogInfo :: Member SimpleLog effs => Text -> Eff effs ()
+
simpleLogInfo = Eff.send . SimpleLogInfo
+

                      
+
simpleLogDebug :: Member SimpleLog effs => Text -> Eff effs ()
+
simpleLogDebug = Eff.send . SimpleLogDebug
+

                      
+
runSimpleLog :: (MonadLogger m, MonadIO m) => Eff '[SimpleLog, m] a -> m a
+
runSimpleLog = Eff.runM . Eff.interpretM (\case
+
        SimpleLogInfo t -> runStdoutLoggingT $ logInfoN t
+
        SimpleLogDebug t -> runStdoutLoggingT $ logDebugN t)
    ) where

                      
import           Data.Aeson                 (FromJSON, ToJSON)
-
import           Data.Text                  (Text)
import           GHC.Generics               (Generic)
import           Plutus.SCB.Events.Contract as Events.Contract
+
import           Plutus.SCB.Events.Node     as Events.Node
import           Plutus.SCB.Events.Mock     as Events.Mock
import           Plutus.SCB.Events.User     as Events.User

                      
    | RecordResponse
          !(Events.Contract.ResponseEvent Events.Contract.ContractResponse)
    | UserEvent Events.User.UserEvent
-
    | NodeEvent Text
+
    | NodeEvent Events.Node.NodeEvent
    deriving (Show, Eq, Generic)
    deriving anyclass (FromJSON, ToJSON)
+
{-# LANGUAGE DeriveAnyClass     #-}
+
{-# LANGUAGE DeriveGeneric      #-}
+
{-# LANGUAGE DerivingStrategies #-}
+
module Plutus.SCB.Events.Node(
+
  NodeEvent(..)
+
  ) where
+

                      
+
import           Data.Aeson  (FromJSON, ToJSON)
+
import GHC.Generics (Generic)
+

                      
+
import           Ledger.Slot (Slot)
+
import           Ledger.Tx   (Tx)
+

                      
+
data NodeEvent =
+
  BlockAdded [Tx]
+
  -- ^ A new block was added to the blockchain
+
  | NewSlot Slot
+
  -- ^ A new slot has been added
+
  -- TODO: Rollbacks?
+
  -- | Rollback Int -- ^ n blocks were rolled back
+
  deriving stock (Show, Eq, Generic)
+
  deriving anyclass (FromJSON, ToJSON)
-- | Split a value into max. n positive-valued parts such that the sum of the
--   parts equals the original value.
splitVal :: (MonadGen m, Integral n) => Int -> n -> m [n]
+
splitVal _  0     = pure []
splitVal mx init' = go 0 0 [] where
    go i c l =
        if i >= pred mx