View on GitHub
File Changes
import           Control.Lens.Indexed            (itraverse_)
import           Control.Monad.IO.Class          (liftIO)
import           Control.Monad.Logger            (logDebugN, logInfoN, runStdoutLoggingT)
-
import           Control.Monad.Reader            (MonadReader, ReaderT, asks, runReaderT)
import qualified Data.Aeson                      as JSON
import qualified Data.ByteString.Lazy.Char8      as BS8
import           Data.Foldable                   (traverse_)
import qualified System.Remote.Monitoring        as EKG

                      
data Command
-
    = DbStats
-
    | Simulate
-
    | Migrate
+
    = Migrate
    | MockNode
    | MockWallet
    | WalletClient
    subparser
        (mconcat
             [ migrationParser
-
             , simulationParser
-
             , dbStatsParser
             , mockWalletParser
             , walletClientParser
             , mockNodeParser
                            ]))
                  (fullDesc <> progDesc "Manage your smart contracts.")))

                      
-
dbStatsParser :: Mod CommandFields Command
-
dbStatsParser =
-
    command "stats" $
-
    info
-
        (pure DbStats)
-
        (fullDesc <> progDesc "Report some useful database statistics.")
-

                      
migrationParser :: Mod CommandFields Command
migrationParser =
    command "migrate" $
    info
        (pure Migrate)
        (fullDesc <> progDesc "Update the database with the latest schema.")

                      
-
simulationParser :: Mod CommandFields Command
-
simulationParser =
-
    command "simulate" $
-
    info
-
        (pure Simulate)
-
        (fullDesc <> progDesc "Seed the event stream with simulated events.")
-

                      
mockNodeParser :: Mod CommandFields Command
mockNodeParser =
    command "node-server" $
        (fullDesc <> progDesc "Show the state history of a smart contract.")

                      
------------------------------------------------------------
-
localReaderT :: MonadReader f m => (f -> e) -> ReaderT e m a -> m a
-
localReaderT f action = do
-
    env <- asks f
-
    runReaderT action env
-

                      
runCliCommand :: Command -> App ()
runCliCommand Migrate = App.migrate
-
runCliCommand Simulate = localReaderT App.dbConnection Core.simulate
-
runCliCommand DbStats = Core.dbStats
runCliCommand MockWallet = WalletServer.main
runCliCommand MockNode = NodeServer.main NodeServer.defaultConfig
runCliCommand WalletClient = liftIO WalletClient.main
        Plutus.SCB.Utils
    other-modules:
        Plutus.SCB.Events.Contract
-
        Plutus.SCB.Events.Mock
        Plutus.SCB.Events.Node
        Plutus.SCB.Events.User
        Plutus.SCB.Events.Wallet
-- Of note in this module is the use of 'nullProjection' as a way of
-- ignoring the 'state'.
module Plutus.SCB.Command
-
    ( saveTxAggregate
-
    , saveRequestResponseAggregate
+
    ( installCommand
+
    , saveBalancedTx
+
    , saveBalancedTxResult
+
    , saveContractState
    ) where

                      
-
import           Data.Maybe        (catMaybes)
import           Eventful          (Aggregate (Aggregate), aggregateCommandHandler, aggregateProjection)
-
import           Plutus.SCB.Events (ChainEvent (..), ContractRequest, ContractResponse, RequestEvent, ResponseEvent,
-
                                    Tx (Tx), entries)
+
import qualified Ledger
+
import           Plutus.SCB.Events (ChainEvent (UserEvent), UserEvent (ContractStateTransition, InstallContract))
+
import qualified Plutus.SCB.Events as Events
import           Plutus.SCB.Query  (nullProjection)
+
import           Plutus.SCB.Types  (ActiveContractState, Contract)

                      
-
-- | Turns a mock transaction into two mock entries.
-
--
-
-- Like all the mock code, this is here to exercise the framework
-
-- while we wait for real events, so the question, "Should 'Tx' be a
-
-- single event?" is moot.
-
saveTxAggregate :: Aggregate () ChainEvent Tx
-
saveTxAggregate =
+
installCommand :: Aggregate () ChainEvent Contract
+
installCommand =
    Aggregate
        { aggregateProjection = nullProjection
-
        , aggregateCommandHandler = \() Tx {entries} -> RecordEntry <$> entries
+
        , aggregateCommandHandler =
+
              \() contract -> [UserEvent $ InstallContract contract]
        }

                      
-
-- | Stores a request, and its possible response and/or cancellation,
-
-- as the appropriate set of events.
-
saveRequestResponseAggregate ::
-
       Aggregate () ChainEvent ( RequestEvent ContractRequest
-
                               , Maybe (RequestEvent ContractRequest)
-
                               , Maybe (ResponseEvent ContractResponse))
-
saveRequestResponseAggregate =
+
saveBalancedTx :: Aggregate () ChainEvent Ledger.Tx
+
saveBalancedTx = Aggregate {aggregateProjection, aggregateCommandHandler}
+
  where
+
    aggregateProjection = nullProjection
+
    aggregateCommandHandler _ txn = [Events.WalletEvent $ Events.BalancedTx txn]
+

                      
+
saveBalancedTxResult :: Aggregate () ChainEvent Ledger.TxId
+
saveBalancedTxResult = Aggregate {aggregateProjection, aggregateCommandHandler}
+
  where
+
    aggregateProjection = nullProjection
+
    aggregateCommandHandler _ txId =
+
        [Events.NodeEvent $ Events.SubmittedTx txId]
+

                      
+
saveContractState :: Aggregate () ChainEvent ActiveContractState
+
saveContractState =
    Aggregate {aggregateProjection = nullProjection, aggregateCommandHandler}
  where
-
    aggregateCommandHandler _ (request, mCancellation, mResponse) =
-
        catMaybes
-
            [ Just $ RecordRequest request
-
            , RecordRequest <$> mCancellation
-
            , RecordResponse <$> mResponse
-
            ]
+
    aggregateCommandHandler _ state =
+
        [UserEvent $ ContractStateTransition state]
{-# OPTIONS_GHC -Wno-orphans #-}

                      
module Plutus.SCB.Core
-
    ( simulate
-
    , dbStats
-
    , dbConnect
+
    ( dbConnect
    , installContract
    , activateContract
    , reportContractStatus
    , addProcessBus
    ) where

                      
-
import           Control.Concurrent              (forkIO, myThreadId, threadDelay)
-
import           Control.Concurrent.Async        (concurrently_)
-
import           Control.Concurrent.STM          (TVar, atomically, newTVarIO, readTVarIO, writeTVar)
import           Control.Error.Util              (note)
-
import           Control.Monad                   (void, when)
+
import           Control.Monad                   (void)
import           Control.Monad.Except            (ExceptT, MonadError, throwError)
import           Control.Monad.Except.Extras     (mapError)
import           Control.Monad.IO.Class          (MonadIO, liftIO)
import           Control.Monad.IO.Unlift         (MonadUnliftIO)
-
import           Control.Monad.Logger            (LoggingT, MonadLogger, logDebugN, logInfoN, runStdoutLoggingT)
-
import           Control.Monad.Reader            (MonadReader, ReaderT, ask, runReaderT)
+
import           Control.Monad.Logger            (LoggingT, MonadLogger, logDebugN, logInfoN)
+
import           Control.Monad.Reader            (MonadReader, ReaderT, ask)
import           Control.Monad.Trans.Class       (lift)
import           Data.Aeson                      (FromJSON, ToJSON, withObject, (.:))
import qualified Data.Aeson                      as JSON
import qualified Data.UUID                       as UUID
import           Database.Persist.Sqlite         (ConnectionPool, createSqlitePoolFromInfo, mkSqliteConnectionInfo,
                                                  retryOnBusy, runSqlPool)
-
import           Eventful                        (Aggregate (Aggregate), EventStoreWriter, GlobalStreamProjection,
+
import           Eventful                        (Aggregate, EventStoreWriter, GlobalStreamProjection,
                                                  ProcessManager (ProcessManager), Projection,
                                                  StreamEvent (StreamEvent), UUID, VersionedEventStoreReader,
-
                                                  VersionedStreamEvent, aggregateCommandHandler, aggregateProjection,
-
                                                  applyProcessManagerCommandsAndEvents, commandStoredAggregate,
-
                                                  getLatestStreamProjection, globalStreamProjection, projectionMapMaybe,
+
                                                  VersionedStreamEvent, applyProcessManagerCommandsAndEvents,
+
                                                  commandStoredAggregate, getLatestStreamProjection,
+
                                                  globalStreamProjection, projectionMapMaybe,
                                                  serializedEventStoreWriter, serializedGlobalEventStoreReader,
                                                  serializedVersionedEventStoreReader, streamProjectionState,
                                                  synchronousEventBusWrapper, uuidNextRandom)
import qualified Language.Plutus.Contract.Wallet as Wallet
import qualified Ledger
import           Options.Applicative.Help.Pretty (pretty, (<+>))
-
import           Plutus.SCB.Arbitrary            (genResponse)
-
import           Plutus.SCB.Command              (saveRequestResponseAggregate, saveTxAggregate)
-
import           Plutus.SCB.Events               (ChainEvent (UserEvent), EventId (EventId),
-
                                                  RequestEvent (CancelRequest, IssueRequest),
-
                                                  ResponseEvent (ResponseEvent), Tx,
+
import           Plutus.SCB.Command              (installCommand, saveBalancedTx, saveBalancedTxResult,
+
                                                  saveContractState)
+
import           Plutus.SCB.Events               (ChainEvent (UserEvent),
                                                  UserEvent (ContractStateTransition, InstallContract))
-
import qualified Plutus.SCB.Events               as Events
-
import           Plutus.SCB.Query                (balances, eventCount, latestContractStatus, monoidProjection,
-
                                                  nullProjection, requestStats, setProjection, trialBalance)
-
import qualified Plutus.SCB.Relation             as Relation
+
import           Plutus.SCB.Query                (latestContractStatus, monoidProjection, nullProjection, setProjection)
import           Plutus.SCB.Types                (ActiveContract (ActiveContract),
                                                  ActiveContractState (ActiveContractState), Contract (Contract),
                                                  DbConfig (DbConfig), PartiallyDecodedResponse,
                                                  SCBError (ActiveContractStateNotFound, ContractCommandError, ContractNotFound, WalletError),
                                                  activeContract, activeContractId, activeContractPath, contractPath,
                                                  dbConfigFile, dbConfigPoolSize, hooks, newState,
                                                  partiallyDecodedResponse)
-
import           Plutus.SCB.Utils                (liftError, logInfoS, render, tshow)
-
import           Test.QuickCheck                 (arbitrary, frequency, generate)
+
import           Plutus.SCB.Utils                (liftError, render, tshow)
import           Wallet.API                      (NodeAPI, WalletAPI, WalletAPIError, WalletDiagnostics, logMsg)
import qualified Wallet.API                      as WAPI

                      
-
data ThreadState
-
    = Running
-
    | Stopped
-
    deriving (Show, Eq)
-

                      
newtype Connection =
    Connection (SqlEventStoreConfig SqlEvent JSONString, ConnectionPool)

                      
-
-- | A long-ish running process that fills the database with lots of event data.
-
simulate :: (MonadIO m, MonadLogger m, MonadReader Connection m) => m ()
-
simulate = do
-
    logInfoN "Simulating"
-
    connection <- ask
-
    runWriters connection
-

                      
-
-- | Dump various statistics and reports from various queries over the event store database.
-
dbStats :: (MonadLogger m, MonadEventStore ChainEvent m) => m ()
-
dbStats = do
-
    logInfoN "Querying"
-
    reportTrialBalance
-
    reportClosingBalances
-
    reportEventCount
-
    reportRequestStats
-

                      
-
------------------------------------------------------------
-
-- | Write lots of events into the store. At the moment this code
-
-- exercises the eventstore and the multi-threaded generation/storage of
-
-- events.
-
runWriters ::
-
       forall m. (MonadLogger m, MonadIO m)
-
    => Connection
-
    -> m ()
-
runWriters connection = do
-
    threadState <- liftIO $ newTVarIO Running
-
        --
-
    logInfoN "Started writers"
-
    let writerAction =
-
            runStdoutLoggingT . flip runReaderT connection $ do
-
                tx :: Tx <- liftIO $ generate arbitrary
-
                void $ runAggregateCommand saveTxAggregate mockEventSource tx
-
                --
-
                requestId <- liftIO $ EventId <$> uuidNextRandom
-
                request <- liftIO $ generate arbitrary
-
                cancellation <-
-
                    liftIO $
-
                    generate $
-
                    frequency
-
                        [ (1, pure $ Just (CancelRequest requestId))
-
                        , (10, pure Nothing)
-
                        ]
-
                response <-
-
                    liftIO $
-
                    generate $
-
                    frequency
-
                        [ ( 10
-
                          , case genResponse request of
-
                                Nothing -> pure Nothing
-
                                Just generator ->
-
                                    Just . ResponseEvent requestId <$> generator)
-
                        , (1, pure Nothing)
-
                        ]
-
                me <- liftIO myThreadId
-
                logInfoN $ "(" <> tshow me <> ") Write"
-
                void $
-
                    runAggregateCommand
-
                        saveRequestResponseAggregate
-
                        contractEventSource
-
                        (IssueRequest requestId request, cancellation, response)
-
                liftIO pauseBeforeRepeat
-
        runWriterAction =
-
            void . forkIO $ repeatIOAction threadState writerAction
-
    liftIO $
-
        concurrently_
-
            (concurrently_ runWriterAction runWriterAction)
-
            (do pauseForWrites
-
                atomically $ writeTVar threadState Stopped)
-
    logInfoN "Stopped writers"
-
  where
-
    pauseForWrites = void $ threadDelay (5 * 60 * 1000 * 1000)
-
    pauseBeforeRepeat = void $ threadDelay (500 * 1000)
-

                      
-
repeatIOAction :: TVar ThreadState -> IO a -> IO ()
-
repeatIOAction threadState action = go
-
  where
-
    go = do
-
        state <- readTVarIO threadState
-
        when (state == Running) $ do
-
            void action
-
            go
-

                      
-
------------------------------------------------------------
-
reportTrialBalance :: (MonadLogger m, MonadEventStore ChainEvent m) => m ()
-
reportTrialBalance = do
-
    trialBalanceProjection <- runGlobalQuery trialBalance
-
    logInfoN "Trial Balance"
-
    logInfoS trialBalanceProjection
-

                      
-
reportEventCount :: (MonadLogger m, MonadEventStore ChainEvent m) => m ()
-
reportEventCount = do
-
    eventCountProjection <- runGlobalQuery eventCount
-
    logInfoN $ "EventCount: " <> tshow eventCountProjection
-

                      
-
reportRequestStats :: (MonadLogger m, MonadEventStore ChainEvent m) => m ()
-
reportRequestStats = do
-
    requestStatsProjection <- runGlobalQuery requestStats
-
    logInfoN $ render requestStatsProjection
-

                      
-
reportClosingBalances :: (MonadLogger m, MonadEventStore ChainEvent m) => m ()
-
reportClosingBalances = do
-
    updatedProjection <- runGlobalQuery balances
-
    logInfoN "Closing Balances"
-
    let closingBalances = Relation.fromMap updatedProjection
-
    let report = (,) <$> Events.users <*> closingBalances
-
    logInfoS report
-

                      
-
------------------------------------------------------------
installContract ::
       (MonadLogger m, MonadEventStore ChainEvent m) => FilePath -> m ()
installContract filePath = do

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

                      
-- | A structure which ties together all possible event types into one parent.
data ChainEvent
-
    = RecordEntry !Events.Mock.Entry
-
    | RecordRequest
+
    = RecordRequest
          !(Events.Contract.RequestEvent Events.Contract.ContractRequest)
    | RecordResponse
          !(Events.Contract.ResponseEvent Events.Contract.ContractResponse)
-
{-# LANGUAGE DeriveAnyClass             #-}
-
{-# LANGUAGE DeriveGeneric              #-}
-
{-# LANGUAGE DerivingStrategies         #-}
-
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-
{-# LANGUAGE OverloadedStrings          #-}
-
{-# LANGUAGE RecordWildCards            #-}
-
{-# LANGUAGE ScopedTypeVariables        #-}
-
{-# LANGUAGE TypeApplications           #-}
-
{-# OPTIONS_GHC -fno-warn-orphans #-}
-

                      
-
-- | Temporary scaffolding - this is something easy and ledger-like
-
-- that I can use while we're waiting for real events.
-
--
-
-- In this simulation we can easily create transactions that move
-
-- money between different users by posting equal and opposite
-
-- entries to their accounts.
-
--
-
-- This gives us some dummy data we can easily ask some interesting
-
-- questions of, like, "Do the account balance?", and "Who owns what
-
-- now?"
-
module Plutus.SCB.Events.Mock where
-

                      
-
import           Data.Aeson          (FromJSON, ToJSON)
-
import qualified Data.Set            as Set
-
import           Data.Text           (Text)
-
import           GHC.Generics        (Generic)
-
import           Ledger.Ada          (lovelaceValueOf)
-
import           Ledger.Value        (Value, scale)
-
import           Plutus.SCB.Relation (Table)
-
import qualified Plutus.SCB.Relation as Relation
-
import           Test.QuickCheck     (Arbitrary, arbitrary, elements)
-

                      
-
newtype AccountId =
-
    AccountId
-
        { unAccountId :: Int
-
        }
-
    deriving (Show, Eq, Generic, Ord)
-
    deriving newtype (Num, FromJSON, ToJSON)
-

                      
-
instance Arbitrary AccountId where
-
    arbitrary =
-
        elements $ maybe [] Set.toList $ Relation.extract $ Relation.keys users
-

                      
-
users :: Table AccountId Text
-
users =
-
    Relation.fromList
-
        [(0, "Bank"), (1, "Jann"), (2, "Michael"), (3, "David"), (4, "Kris")]
-

                      
-
data Entry =
-
    Entry
-
        { accountId :: AccountId
-
        , amount    :: Value
-
        }
-
    deriving (Show, Eq, Generic, FromJSON, ToJSON)
-

                      
-
instance Arbitrary Value where
-
    arbitrary = elements (lovelaceValueOf <$> [1 .. 100])
-

                      
-
instance Arbitrary Entry where
-
    arbitrary = do
-
        accountId <- arbitrary
-
        amount <- arbitrary
-
        pure Entry {..}
-

                      
-
newtype Tx =
-
    Tx
-
        { entries :: [Entry]
-
        }
-
    deriving (Show, Eq)
-

                      
-
instance Arbitrary Tx where
-
    arbitrary = do
-
        from :: AccountId <- arbitrary
-
        to <- arbitrary
-
        value <- arbitrary
-
        pure
-
            Tx
-
                { entries =
-
                      [ Entry {accountId = from, amount = value}
-
                      , Entry
-
                            { accountId = to
-
                            , amount = scale @Integer @Value (-1) value
-
                            }
-
                      ]
-
                }
{-# LANGUAGE DerivingStrategies  #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE NamedFieldPuns      #-}
-
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
-
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeFamilies        #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

                      
    , monoidProjection
    , setProjection
    , eventCount
-
    , balances
-
    , trialBalance
-
    , requestStats
    , latestContractStatus
-
    , RequestStats
    ) where

                      
-
import           Control.Lens                    (makeLenses, over)
-
import           Control.Monad                   ((>=>))
import           Data.Map.Strict                 (Map)
import qualified Data.Map.Strict                 as Map
-
import           Data.Maybe                      (fromMaybe)
import           Data.Set                        (Set)
import qualified Data.Set                        as Set
import           Data.UUID                       (UUID)
import           Eventful                        (Projection (Projection), StreamEvent (StreamEvent), StreamProjection,
                                                  VersionedStreamEvent, projectionEventHandler, projectionSeed,
                                                  streamProjectionState)
-
import           Ledger.Ada                      (lovelaceValueOf)
-
import           Ledger.Value                    (Value)
-
import           Options.Applicative.Help.Pretty (Pretty, indent, int, pretty, vsep, (<+>))
-
import           Plutus.SCB.Events               (AccountId, ChainEvent (..), Entry (Entry), EventId,
-
                                                  RequestEvent (CancelRequest, IssueRequest),
-
                                                  ResponseEvent (ResponseEvent), UserEvent (ContractStateTransition),
-
                                                  accountId, amount)
+
import           Options.Applicative.Help.Pretty (Pretty, pretty)
+
import           Plutus.SCB.Events               (ChainEvent (UserEvent), UserEvent (ContractStateTransition))
import           Plutus.SCB.Types                (ActiveContractState, activeContract, activeContractId)

                      
-- | The empty projection. Particularly useful for commands that have no 'state'.
  where
    projectionEventHandler count _ = count + 1

                      
-
-- | Fold over each entry and store the total amounts seen, indexed by
-
-- 'AccountId'. This will give us a final balance of all the mock entries.
-
balances :: Projection (Map AccountId Value) (VersionedStreamEvent ChainEvent)
-
balances = Projection {projectionSeed = mempty, projectionEventHandler}
-
  where
-
    projectionEventHandler acc (StreamEvent _ _ (RecordEntry Entry { accountId
-
                                                                   , amount
-
                                                                   })) =
-
        Map.alter updater accountId acc
-
      where
-
        updater :: Maybe Value -> Maybe Value
-
        updater current = Just $ amount <> fromMaybe (lovelaceValueOf 0) current
-
    projectionEventHandler acc _ = acc
-

                      
-
-- | The trial balance adds up all 'Entry' types in the database. If
-
-- we've done our double-entry accounting correctly, this should
-
-- always be zero (because every entry has an equal and opposite entry
-
-- somewhere else).
-
trialBalance :: Projection Value (VersionedStreamEvent ChainEvent)
-
trialBalance = Projection {projectionSeed = mempty, projectionEventHandler}
-
  where
-
    projectionEventHandler total (StreamEvent _ _ (RecordEntry Entry {amount})) =
-
        total <> amount
-
    projectionEventHandler total _ = total
-

                      
-- | Retain the latest status for a given contract.
latestContractStatus ::
       Projection (Map UUID ActiveContractState) (StreamEvent key position ChainEvent)
    projectionEventHandler m _ = m

                      
------------------------------------------------------------
-
data RequestStats =
-
    RequestStats
-
        { _made      :: Int
-
        , _cancelled :: Int
-
        , _responded :: Int
-
        , _openIds   :: Set EventId
-
        }
-
    deriving (Show, Eq)
-

                      
-
makeLenses ''RequestStats
-

                      
-
-- | Query out some interesting statistics about the Contract events we've seen.
-
--
-
-- Implementation detail: Noteworthy here is the use of the @(->)@
-
-- monad so that we can easily compose projection handlers with '>=>'.
-
requestStats :: Projection RequestStats (VersionedStreamEvent ChainEvent)
-
requestStats =
-
    Projection
-
        { projectionSeed = RequestStats 0 0 0 Set.empty
-
        , projectionEventHandler = trackEventIds >=> countMessageTypes
-
        }
-

                      
-
-- | Tickers for each kind of message.
-
countMessageTypes ::
-
       RequestStats -> VersionedStreamEvent ChainEvent -> RequestStats
-
countMessageTypes stats (StreamEvent _ _ event) =
-
    case event of
-
        RecordRequest (IssueRequest _ _)   -> over made (+ 1) stats
-
        RecordRequest (CancelRequest _)    -> over cancelled (+ 1) stats
-
        RecordResponse (ResponseEvent _ _) -> over responded (+ 1) stats
-
        _                                  -> stats
-
  --
-

                      
-
-- | When we see a request, track its 'EventId'. When it is canceled
-
-- or responded to, remove it.
-
-- We'll be left with a list of unanswered (open) requests.
-
trackEventIds :: RequestStats -> VersionedStreamEvent ChainEvent -> RequestStats
-
trackEventIds stats (StreamEvent _ _ event) =
-
    case event of
-
        RecordRequest (IssueRequest eventId _) ->
-
            over openIds (Set.insert eventId) stats
-
        RecordRequest (CancelRequest eventId) ->
-
            over openIds (Set.delete eventId) stats
-
        RecordResponse (ResponseEvent eventId _) ->
-
            over openIds (Set.delete eventId) stats
-
        _ -> stats
-

                      
-
instance Pretty RequestStats where
-
    pretty RequestStats {_made, _cancelled, _responded, _openIds} =
-
        vsep
-
            [ "Request Stats:"
-
            , indent 2 $
-
              vsep
-
                  [ "Made:" <+> int _made
-
                  , "Cancelled:" <+> int _cancelled
-
                  , "Responded:" <+> int _responded
-
                  , "Open:" <+> int (Set.size _openIds)
-
                  ]
-
            ]
-

                      
-- | The Pretty instance for 'StreamProjection' just pretty prints its resulting 'state'.
instance Pretty state =>
         Pretty (StreamProjection key position state event) where
    , tshow
    , render
    , liftError
+
    , liftLocalReader
    ) where

                      
import           Control.Monad.Except            (MonadError, throwError)
import           Control.Monad.Logger            (MonadLogger, logDebugN, logErrorN, logInfoN)
+
import           Control.Monad.Reader            (MonadReader, ReaderT, asks, runReaderT)
import           Data.Text                       (Text)
import qualified Data.Text                       as Text
import           Options.Applicative.Help.Pretty (Pretty, displayS, pretty, renderPretty)
    action >>= \case
        Left err -> throwError err
        Right value -> pure value
+

                      
+
liftLocalReader :: MonadReader f m => (f -> e) -> ReaderT e m a -> m a
+
liftLocalReader f action = do
+
    env <- asks f
+
    runReaderT action env
    ( tests
    ) where

                      
-
import           Control.Monad                                 (void)
import           Control.Monad.Except                          (ExceptT, runExceptT)
import           Control.Monad.IO.Class                        (MonadIO, liftIO)
import           Control.Monad.Logger                          (LoggingT, runStderrLoggingT)
import qualified Data.Set                                      as Set
import           Data.Text                                     (Text)
import qualified Data.Text                                     as Text
-
import           Eventful                                      (Aggregate, Projection, StreamEvent (StreamEvent),
-
                                                                VersionedStreamEvent, aggregateCommandHandler,
-
                                                                aggregateProjection, commandStoredAggregate,
-
                                                                getLatestStreamProjection, latestProjection, nil,
-
                                                                projectionSeed)
+
import           Eventful                                      (commandStoredAggregate, getLatestStreamProjection)
import           Eventful.Store.Memory                         (EventMap, emptyEventMap, stateEventStoreReader,
                                                                stateEventStoreWriter, stateGlobalEventStoreReader)
import           Language.Plutus.Contract.Resumable            (ResumableError)
import           Language.Plutus.Contract.Servant              (initialResponse, runUpdate)
import qualified Language.PlutusTx.Coordination.Contracts.Game as Contracts.Game
-
import           Ledger.Value                                  (isZero)
-
import           Plutus.SCB.Command                            (saveTxAggregate)
+
import           Plutus.SCB.Command                            ()
import           Plutus.SCB.Core
import           Plutus.SCB.Events                             (ChainEvent)
-
import qualified Plutus.SCB.Query                              as Query
import           Plutus.SCB.Types                              (SCBError (ContractCommandError, ContractNotFound))
import           Test.QuickCheck.Instances.UUID                ()
import           Test.Tasty                                    (TestTree, testGroup)
-
import           Test.Tasty.HUnit                              (HasCallStack, assertEqual, assertFailure, testCase)
-
import           Test.Tasty.QuickCheck                         (property, testProperty)
+
import           Test.Tasty.HUnit                              (assertEqual, testCase)

                      
tests :: TestTree
-
tests =
-
    testGroup
-
        "SCB.Core"
-
        [eventCountTests, trialBalanceTests, installContractTests]
-

                      
-
eventCountTests :: TestTree
-
eventCountTests =
-
    testGroup
-
        "saveTx/eventCount"
-
        [ testProperty "Overall balance is always 0" $ \txs ->
-
              property $
-
              isZero $
-
              runCommandQueryChain saveTxAggregate Query.trialBalance txs
-
        ]
-

                      
-
trialBalanceTests :: TestTree
-
trialBalanceTests =
-
    testGroup
-
        "saveTx/trialBalance"
-
        [ testProperty "Overall balance is always 0" $ \txs ->
-
              property $
-
              isZero $
-
              runCommandQueryChain saveTxAggregate Query.trialBalance txs
-
        ]
+
tests = testGroup "SCB.Core" [installContractTests]

                      
installContractTests :: TestTree
installContractTests =
        => StateT (EventMap ChainEvent) (LoggingT (ExceptT SCBError m)) a
        -> m a
    runScenario action = do
-
      result <- runExceptT $ runStderrLoggingT $ evalStateT action emptyEventMap
-
      case result of
-
        Left err    -> error $ show err
-
        Right value -> pure value
-

                      
-
runCommandQueryChain ::
-
       Aggregate aState event command
-
    -> Projection pState (VersionedStreamEvent event)
-
    -> [command]
-
    -> pState
-
runCommandQueryChain aggregate projection commands =
-
    latestProjection projection $
-
    fmap (StreamEvent nil 1) $
-
    foldMap
-
        (aggregateCommandHandler
-
             aggregate
-
             (projectionSeed (aggregateProjection aggregate)))
-
        commands
+
        result <-
+
            runExceptT $ runStderrLoggingT $ evalStateT action emptyEventMap
+
        case result of
+
            Left err    -> error $ show err
+
            Right value -> pure value

                      
instance Monad m => MonadEventStore event (StateT (EventMap event) m) where
    refreshProjection = getLatestStreamProjection stateGlobalEventStoreReader