View on GitHub
File Changes
import qualified Cardano.Wallet.Client           as WalletClient
import qualified Cardano.Wallet.MockServer       as WalletServer
import           Control.Lens.Indexed            (itraverse_)
-
import           Control.Monad.IO.Unlift         (MonadUnliftIO, liftIO)
-
import           Control.Monad.Logger            (LogLevel (LevelDebug), MonadLogger, filterLogger, logDebugN, logInfoN,
-
                                                  runStdoutLoggingT)
-
import           Control.Monad.Reader            (MonadReader, runReaderT)
+
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_)
                                                  showHelpOnEmpty, showHelpOnError, str, strArgument, strOption,
                                                  subparser, value, (<|>))
import           Options.Applicative.Help.Pretty (int, parens, pretty, (<+>))
-
import           Plutus.SCB.Core                 (Connection, MonadEventStore, dbConnect)
+
import           Plutus.SCB.App                  (App, runApp)
+
import qualified Plutus.SCB.App                  as App
import qualified Plutus.SCB.Core                 as Core
-
import           Plutus.SCB.Events               (ChainEvent)
-
import           Plutus.SCB.Types                (SCBError)
import           Plutus.SCB.Utils                (logErrorS, render)
import           System.Exit                     (ExitCode (ExitFailure, ExitSuccess), exitWith)
import qualified System.Remote.Monitoring        as EKG
        (fullDesc <> progDesc "Show the state history of a smart contract.")

                      
------------------------------------------------------------
-
runCliCommand ::
-
       ( MonadUnliftIO m
-
       , MonadLogger m
-
       , MonadReader Connection m
-
       , MonadEventStore ChainEvent m
-
       )
-
    => Command
-
    -> m (Either SCBError ())
-
runCliCommand Simulate = Right <$> Core.simulate
-
runCliCommand DbStats = Right <$> Core.dbStats
-
runCliCommand Migrate = Right <$> Core.migrate
-
runCliCommand MockWallet = Right <$> WalletServer.main
-
runCliCommand MockNode = Right <$> NodeServer.main NodeServer.defaultConfig
-
runCliCommand WalletClient = Right <$> liftIO WalletClient.main
-
runCliCommand NodeClient = Right <$> liftIO NodeClient.main
-
runCliCommand (InstallContract path) = Right <$> Core.installContract path
-
-- runCliCommand (ActivateContract path) = Core.activateContract path
-
runCliCommand (ContractStatus uuid) = Right <$> Core.reportContractStatus uuid
+
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
+
runCliCommand NodeClient = liftIO NodeClient.main
+
runCliCommand (InstallContract path) = Core.installContract path
+
runCliCommand (ActivateContract path) = Core.activateContract path
+
runCliCommand (ContractStatus uuid) = Core.reportContractStatus uuid
runCliCommand ReportInstalledContracts = do
    logInfoN "Installed Contracts"
    traverse_ (logInfoN . render) =<< Core.installedContracts
-
    pure $ Right ()
+
    pure ()
runCliCommand ReportActiveContracts = do
    logInfoN "Active Contracts"
    traverse_ (logInfoN . render) =<< Core.activeContracts
-
    pure $ Right ()
-
-- runCliCommand (UpdateContract uuid endpoint payload) =
-
--     Core.updateContract uuid endpoint payload
+
    pure ()
+
runCliCommand (UpdateContract uuid endpoint payload) =
+
    Core.updateContract uuid endpoint payload
runCliCommand (ReportContractHistory uuid) = do
    logInfoN "Contract History"
    itraverse_
        (\index contract ->
             logInfoN $ render (parens (int index) <+> pretty contract)) =<<
        Core.activeContractHistory uuid
-
    pure $ Right ()

                      
main :: IO ()
main = do
            (info (helper <*> versionOption <*> commandLineParser) idm)
    config <- liftIO $ decodeFileThrow configPath
    traverse_ (EKG.forkServer "localhost") ekgPort
-
    returnCode <-
-
        runStdoutLoggingT $
-
        filterLogger (\_ level -> level > LevelDebug) $ do
-
            logInfoN $ "Running: " <> Text.pack (show cmd)
-
            connection <- runReaderT dbConnect config
-
            result <- runReaderT (runCliCommand cmd) connection
-
            logDebugN $ "Ran: " <> Text.pack (show result)
-
            case result of
-
                Left err -> do
-
                    logErrorS err
-
                    pure (ExitFailure 1)
-
                Right () -> pure ExitSuccess
-
    exitWith returnCode
+
    result <-
+
        do runApp config $ do
+
               logInfoN $ "Running: " <> Text.pack (show cmd)
+
               result <- runCliCommand cmd
+
               logDebugN $ "Ran: " <> Text.pack (show result)
+
               pure result
+
    case result of
+
        Left err -> do
+
            runStdoutLoggingT $ logErrorS err
+
            exitWith (ExitFailure 1)
+
        Right _ -> exitWith ExitSuccess
        Cardano.Wallet.Client
        Cardano.Wallet.MockServer
        Cardano.Wallet.Types
+
        Plutus.SCB.App
        Plutus.SCB.Arbitrary
        Plutus.SCB.Command
        Plutus.SCB.ContractCLI
    other-modules:
        Plutus.SCB.Events.Contract
        Plutus.SCB.Events.Mock
-
        Plutus.SCB.Events.User
        Plutus.SCB.Events.Node
+
        Plutus.SCB.Events.User
+
        Plutus.SCB.Events.Wallet
        Servant.Extra
    hs-source-dirs: src
    build-depends:
        eventful-memory -any,
        eventful-sql-common -any,
        eventful-sqlite -any,
+
        freer-simple -any,
        generic-arbitrary -any,
        http-client -any,
        lens -any,
        monad-logger -any,
        mtl -any,
        optparse-applicative -any,
+
        persistent -any,
        persistent-sqlite -any,
        playground-common -any,
        prettyprinter >=1.1.0.1,
        base >=4.9 && <5,
        bytestring -any,
        ekg -any,
+
        freer-simple -any,
        lens -any,
        monad-logger -any,
        mtl -any,
        optparse-applicative -any,
        playground-common -any,
        plutus-scb -any,
+
        plutus-wallet-api -any,
        text -any,
        unliftio-core -any,
        uuid -any,
    build-depends:
        QuickCheck -any,
        aeson -any,
+
        aeson-pretty -any,
        base >=4.9 && <5,
        containers -any,
        eventful-core -any,
        eventful-memory -any,
+
        freer-simple -any,
        monad-logger -any,
        mtl -any,
        plutus-contract -any,

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

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

                      
import           Cardano.Node.RandomTx
import           Cardano.Node.SimpleLog
healthcheck = pure NoContent

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

                      
addBlock :: (Member SimpleLog effs, Member ChainEffect effs) => Eff effs ()
addBlock = do
        void $ processChainEffects stateVar addBlock
        liftIO $ threadDelay $ fromIntegral $ toMicroseconds slotLength

                      
-
-- | Generates a random transaction once in each 'mscRandomTxInterval' of the 
+
-- | Generates a random transaction once in each 'mscRandomTxInterval' of the
--   config
transactionGenerator ::
    ( MonadIO m
        void $ processChainEffects stateVar (genRandomTx >>= addTx)
        liftIO $ threadDelay $ fromIntegral $ toMicroseconds itvl

                      
-
-- | Discards old blocks according to the 'BlockReaperConfig'. (avoids memory 
+
-- | Discards old blocks according to the 'BlockReaperConfig'. (avoids memory
--   leak)
blockReaper ::
    ( MonadIO m
    ) where

                      
import           Cardano.Wallet.Types   (WalletId)
-
import           Ledger                 (PubKey, Value)
+
import qualified Data.ByteString.Lazy      as BSL
+
import           Ledger                 (PubKey, Value,Signature)
import           Servant.API            ((:<|>), (:>), Capture, Get, JSON, Post, ReqBody)
import           Wallet.Emulator.Wallet (Wallet)

                      
+
-- | Note: This API uses the wholly-fictitious notion of an "active" wallet.
+
-- This is purely to fit in easily with the 'WalletAPI's 'ownPubKey'
+
-- call, which assumes there is a single public key we own. This will
+
-- have to be revisited later.
type API
     = "wallets" :> (Get '[ JSON] [Wallet]
+
                     :<|> "active" :> "pubkey" :> Get '[ JSON] PubKey
+
                     :<|> "active" :> "sign" :> ReqBody '[JSON] BSL.ByteString :> Post '[ JSON] Signature
                     :<|> (Capture "walletId" WalletId :> ("coin-selections" :> "random" :> ReqBody '[ JSON] Value :> Get '[ JSON] ( [Value]
                                                                                                                                   , Value)
                                                           :<|> "addresses" :> "new" :> Post '[ JSON] PubKey)))

                      
import           Cardano.Wallet.API     (API)
import           Cardano.Wallet.Types   (WalletId)
+
import qualified Data.ByteString.Lazy   as BSL
import           Data.Function          ((&))
import           Data.Proxy             (Proxy (Proxy))
-
import           Ledger                 (PubKey, Value)
+
import           Ledger                 (PubKey, Signature, Value)
import           Network.HTTP.Client    (defaultManagerSettings, newManager)
import           Servant.Client         (ClientM, client, mkClientEnv, parseBaseUrl, runClientM)
import           Servant.Extra          (left, right)
selectCoins :: WalletId -> Value -> ClientM ([Value], Value)
allocateAddress :: WalletId -> ClientM PubKey
getWallets :: ClientM [Wallet]
-
(getWallets, selectCoins, allocateAddress) =
-
    (getWallets_, selectCoins_, allocateAddress_)
+
getOwnPubKey :: ClientM PubKey
+
sign :: BSL.ByteString -> ClientM Signature
+
(getWallets, getOwnPubKey, sign, selectCoins, allocateAddress) =
+
    (getWallets_, getOwnPubKey_, sign_, selectCoins_, allocateAddress_)
  where
    api = client (Proxy @API)
    getWallets_ = left api
-
    selectCoins_ walletId = right api walletId & left
-
    allocateAddress_ walletId = right api walletId & right
+
    getOwnPubKey_ = right api & left
+
    sign_ = right api & right & left
+
    byWalletId = right api & right & right
+
    selectCoins_ walletId = byWalletId walletId & left
+
    allocateAddress_ walletId = byWalletId walletId & right

                      
main :: IO ()
main = do
{-# LANGUAGE TypeApplications  #-}
{-# LANGUAGE TypeOperators     #-}

                      
-
module Cardano.Wallet.MockServer where
+
module Cardano.Wallet.MockServer
+
    ( main
+
    ) where

                      
import           Cardano.Wallet.API       (API)
import           Cardano.Wallet.Types     (WalletId)
import           Control.Monad.Except     (ExceptT)
import           Control.Monad.IO.Class   (MonadIO, liftIO)
import           Control.Monad.Logger     (MonadLogger, logInfoN)
+
import qualified Data.ByteString.Lazy     as BSL
import           Data.Proxy               (Proxy (Proxy))
-
import           Ledger                   (PubKey, Value)
+
import           Ledger                   (PubKey, Signature, Value)
+
import qualified Ledger.Crypto            as Crypto
import           Network.Wai.Handler.Warp (run)
import           Plutus.SCB.Arbitrary     ()
import           Plutus.SCB.Utils         (tshow)
import           Servant.Extra            (capture)
import           Test.QuickCheck          (arbitrary, generate)
import           Wallet.Emulator.Wallet   (Wallet (Wallet))
+
import qualified Wallet.Emulator.Wallet   as EM

                      
wallets :: Monad m => m [Wallet]
wallets = pure $ Wallet <$> [1 .. 10]
allocateAddress :: MonadIO m => WalletId -> m PubKey
allocateAddress _ = liftIO $ generate arbitrary

                      
+
getOwnPubKey :: Monad m => m PubKey
+
getOwnPubKey = pure $ EM.walletPubKey activeWallet
+

                      
+
activeWallet :: Wallet
+
activeWallet = Wallet 1
+

                      
+
sign :: Monad m => BSL.ByteString -> m Signature
+
sign bs = do
+
    let privK = EM.walletPrivKey activeWallet
+
    pure (Crypto.sign (BSL.toStrict bs) privK)
+

                      
------------------------------------------------------------
asHandler :: ExceptT ServantErr IO a -> Handler a
asHandler = Handler
app =
    serve (Proxy @API) $
    hoistServer (Proxy @API) asHandler $
-
    wallets :<|> capture (selectCoin :<|> allocateAddress)
+
    wallets :<|> getOwnPubKey :<|> sign :<|>
+
    capture (selectCoin :<|> allocateAddress)

                      
main :: (MonadIO m, MonadLogger m) => m ()
main = do
+
{-# LANGUAGE DerivingStrategies    #-}
+
{-# LANGUAGE FlexibleInstances     #-}
+
{-# LANGUAGE MultiParamTypeClasses #-}
+
{-# LANGUAGE OverloadedStrings     #-}
+
{-# LANGUAGE RecordWildCards       #-}
+

                      
+
module Plutus.SCB.App where
+

                      
+
import qualified Cardano.Node.Client        as NodeClient
+
import qualified Cardano.Wallet.Client      as WalletClient
+
import           Control.Monad              (void)
+
import           Control.Monad.Except       (ExceptT (ExceptT), MonadError, runExceptT, throwError)
+
import           Control.Monad.IO.Class     (MonadIO, liftIO)
+
import           Control.Monad.Logger       (LogLevel (LevelDebug), LoggingT, MonadLogger, filterLogger, logInfoN,
+
                                             runStdoutLoggingT)
+
import           Control.Monad.Reader       (MonadReader, ReaderT (ReaderT),  asks, runReaderT)
+
import           Data.Aeson                 (FromJSON, ToJSON, eitherDecode)
+
import qualified Data.Aeson.Encode.Pretty   as JSON
+
import qualified Data.ByteString.Lazy.Char8 as BSL8
+
import qualified Data.Text                  as Text
+
import           Database.Persist.Sqlite    (retryOnBusy, runSqlPool)
+
import           Eventful                   (commandStoredAggregate, getLatestStreamProjection,
+
                                             serializedEventStoreWriter, serializedGlobalEventStoreReader,
+
                                             serializedVersionedEventStoreReader)
+
import           Eventful.Store.Sql         (jsonStringSerializer, sqlEventStoreReader, sqlGlobalEventStoreReader)
+
import           Eventful.Store.Sqlite      (initializeSqliteEventStore, sqliteEventStoreWriter)
+
import           Network.HTTP.Client        (defaultManagerSettings, newManager)
+
import           Plutus.SCB.Core            (Connection (Connection), ContractCommand (InitContract, UpdateContract),
+
                                             MonadContract, MonadEventStore, addProcessBus, dbConnect, invokeContract,
+
                                             refreshProjection, runAggregateCommand)
+
import           Plutus.SCB.Types           (DbConfig,
+
                                             SCBError (ContractCommandError, NodeClientError, WalletClientError))
+
import           Servant.Client             (ClientEnv, ClientM, ServantError, mkClientEnv, parseBaseUrl, runClientM)
+
import           System.Exit                (ExitCode (ExitFailure, ExitSuccess))
+
import           System.Process             (readProcessWithExitCode)
+
import           Wallet.API                 (NodeAPI, WalletAPI, WalletDiagnostics, logMsg, ownPubKey, sign, slot,
+
                                             startWatching, submitTxn, updatePaymentWithChange, watchedAddresses)
+

                      
+
------------------------------------------------------------
+
data Env =
+
    Env
+
        { dbConnection    :: Connection
+
        , walletClientEnv :: ClientEnv
+
        , nodeClientEnv   :: ClientEnv
+
        }
+

                      
+
newtype App a =
+
    App
+
        { unApp :: ExceptT SCBError (ReaderT Env (LoggingT IO)) a
+
        }
+
    deriving newtype ( Functor
+
                     , Applicative
+
                     , Monad
+
                     , MonadLogger
+
                     , MonadIO
+
                     , MonadReader Env
+
                     , MonadError SCBError
+
                     )
+

                      
+
instance NodeAPI App where
+
    submitTxn = void . runNodeClientM . NodeClient.addTx
+
    slot = runNodeClientM NodeClient.getCurrentSlot
+

                      
+
instance WalletAPI App where
+
    ownPubKey = runWalletClientM WalletClient.getOwnPubKey
+
    sign bs = runWalletClientM $ WalletClient.sign bs
+
    updatePaymentWithChange value payment = undefined
+
    watchedAddresses = pure mempty
+
    startWatching address = pure ()
+

                      
+
runAppClientM ::
+
       (Env -> ClientEnv) -> (ServantError -> SCBError) -> ClientM a -> App a
+
runAppClientM f wrapErr action =
+
    App $ do
+
        env <- asks f
+
        result <- liftIO $ runClientM action env
+
        case result of
+
            Left err    -> throwError $ wrapErr err
+
            Right value -> pure value
+

                      
+
runWalletClientM :: ClientM a -> App a
+
runWalletClientM = runAppClientM walletClientEnv WalletClientError
+

                      
+
runNodeClientM :: ClientM a -> App a
+
runNodeClientM = runAppClientM nodeClientEnv NodeClientError
+

                      
+
runApp :: DbConfig -> App a -> IO (Either SCBError a)
+
runApp dbConfig (App action) =
+
    runStdoutLoggingT . filterLogger (\_ level -> level > LevelDebug) $ do
+
        nodeManager <- liftIO $ newManager defaultManagerSettings
+
        nodeBaseUrl <- parseBaseUrl "http://localhost:8081"
+
        let nodeClientEnv = mkClientEnv nodeManager nodeBaseUrl
+
        walletManager <- liftIO $ newManager defaultManagerSettings
+
        walletBaseUrl <- parseBaseUrl "http://localhost:8082"
+
        let walletClientEnv = mkClientEnv walletManager walletBaseUrl
+
        dbConnection <- runReaderT dbConnect dbConfig
+
        runReaderT (runExceptT action) $ Env {..}
+

                      
+
instance (FromJSON event, ToJSON event) => MonadEventStore event App where
+
    refreshProjection projection =
+
        App $ do
+
            (Connection (sqlConfig, connectionPool)) <- asks dbConnection
+
            let reader =
+
                    serializedGlobalEventStoreReader jsonStringSerializer $
+
                    sqlGlobalEventStoreReader sqlConfig
+
            ExceptT . fmap Right . flip runSqlPool connectionPool $
+
                getLatestStreamProjection reader projection
+
    runAggregateCommand aggregate identifier input =
+
        App $ do
+
            (Connection (sqlConfig, connectionPool)) <- asks dbConnection
+
            let reader =
+
                    serializedVersionedEventStoreReader jsonStringSerializer $
+
                    sqlEventStoreReader sqlConfig
+
            let writer =
+
                    addProcessBus
+
                        (serializedEventStoreWriter jsonStringSerializer $
+
                         sqliteEventStoreWriter sqlConfig)
+
                        reader
+
            ExceptT $
+
                fmap Right . retryOnBusy . flip runSqlPool connectionPool $
+
                commandStoredAggregate writer reader aggregate identifier input
+

                      
+
instance MonadContract App where
+
    invokeContract contractCommand =
+
        App $ do
+
            (exitCode, stdout, stderr) <-
+
                liftIO $
+
                case contractCommand of
+
                    InitContract contractPath ->
+
                        readProcessWithExitCode contractPath ["init"] ""
+
                    UpdateContract contractPath payload ->
+
                        readProcessWithExitCode
+
                            contractPath
+
                            ["update"]
+
                            (BSL8.unpack (JSON.encodePretty payload))
+
            case exitCode of
+
                ExitFailure code ->
+
                    pure . Left $ ContractCommandError code (Text.pack stderr)
+
                ExitSuccess ->
+
                    case eitherDecode (BSL8.pack stdout) of
+
                        Right value -> pure $ Right value
+
                        Left err ->
+
                            pure . Left $ ContractCommandError 0 (Text.pack err)
+

                      
+
instance WalletDiagnostics App where
+
    logMsg = App . logInfoN
+

                      
+
-- | Initialize/update the database to hold events.
+
migrate :: App ()
+
migrate =
+
    App $ do
+
        logInfoN "Migrating"
+
        Connection (sqlConfig, connectionPool) <- asks dbConnection
+
        ExceptT . fmap Right . flip runSqlPool connectionPool $
+
            initializeSqliteEventStore sqlConfig connectionPool
+
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
+
{-# LANGUAGE TypeOperators         #-}
+
{-# OPTIONS_GHC -Wno-orphans #-}

                      
module Plutus.SCB.Core
-
    ( migrate
-
    , simulate
+
    ( simulate
    , dbStats
    , dbConnect
    , installContract
    , activeContracts
    , activeContractsProjection
    , activeContractHistory
-
    , Connection
+
    , Connection(Connection)
    , ContractCommand(..)
    , MonadContract
    , invokeContract
    , runAggregateCommand
    , runGlobalQuery
    , updateContract
+
    , 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.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           Data.Aeson                      (FromJSON, ToJSON, eitherDecode, withObject, (.:))
+
import           Control.Monad.Trans.Class       (lift)
+
import           Data.Aeson                      (FromJSON, ToJSON, withObject, (.:))
import qualified Data.Aeson                      as JSON
-
import qualified Data.Aeson.Encode.Pretty        as JSON
import           Data.Aeson.Types                (Parser)
import qualified Data.Aeson.Types                as JSON
-
import qualified Data.ByteString.Lazy.Char8      as BSL8
+
import           Data.Foldable                   (traverse_)
import           Data.Map.Strict                 (Map)
import qualified Data.Map.Strict                 as Map
import           Data.Set                        (Set)
import qualified Data.Set                        as Set
import           Data.Text                       (Text)
import qualified Data.Text                       as Text
import qualified Data.UUID                       as UUID
-
import           Database.Persist.Sqlite         (ConnectionPool, SqlPersistT, createSqlitePoolFromInfo,
-
                                                  mkSqliteConnectionInfo, retryOnBusy, runSqlPool)
+
import           Database.Persist.Sqlite         (ConnectionPool, createSqlitePoolFromInfo, mkSqliteConnectionInfo,
+
                                                  retryOnBusy, runSqlPool)
import           Eventful                        (Aggregate (Aggregate), EventStoreWriter, GlobalStreamProjection,
                                                  ProcessManager (ProcessManager), Projection,
                                                  StreamEvent (StreamEvent), UUID, VersionedEventStoreReader,
                                                  synchronousEventBusWrapper, uuidNextRandom)
import           Eventful.Store.Sql              (JSONString, SqlEvent, SqlEventStoreConfig, defaultSqlEventStoreConfig,
                                                  jsonStringSerializer, sqlEventStoreReader, sqlGlobalEventStoreReader)
-
import           Eventful.Store.Sqlite           (initializeSqliteEventStore, sqliteEventStoreWriter)
+
import           Eventful.Store.Sqlite           (sqliteEventStoreWriter)
import qualified Language.Plutus.Contract        as Contract
+
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.Types                (ActiveContract (ActiveContract),
                                                  ActiveContractState (ActiveContractState), Contract (Contract),
                                                  DbConfig (DbConfig), PartiallyDecodedResponse,
-
                                                  SCBError (ActiveContractStateNotFound, ContractCommandError, ContractNotFound),
+
                                                  SCBError (ActiveContractStateNotFound, ContractCommandError, ContractNotFound, WalletError),
                                                  activeContract, activeContractId, activeContractPath, contractPath,
                                                  dbConfigFile, dbConfigPoolSize, hooks, newState,
                                                  partiallyDecodedResponse)
-
import           Plutus.SCB.Utils                (logInfoS, render, tshow)
-
import           System.Exit                     (ExitCode (ExitFailure, ExitSuccess))
-
import           System.Process                  (readProcessWithExitCode)
+
import           Plutus.SCB.Utils                (liftError, logInfoS, render, tshow)
import           Test.QuickCheck                 (arbitrary, frequency, generate)
+
import           Wallet.API                      (NodeAPI, WalletAPI, WalletAPIError, WalletDiagnostics, logMsg)
+
import qualified Wallet.API                      as WAPI

                      
data ThreadState
    = Running
newtype Connection =
    Connection (SqlEventStoreConfig SqlEvent JSONString, ConnectionPool)

                      
-
-- | Initialize/update the database to hold events.
-
migrate :: (MonadUnliftIO m, MonadLogger m, MonadReader Connection m) => m ()
-
migrate = do
-
    logInfoN "Migrating"
-
    Connection (sqlConfig, connectionPool) <- ask
-
    initializeSqliteEventStore sqlConfig connectionPool
-

                      
-- | A long-ish running process that fills the database with lots of event data.
-
simulate :: (MonadUnliftIO m, MonadLogger m, MonadReader Connection m) => m ()
+
simulate :: (MonadIO m, MonadLogger m, MonadReader Connection m) => m ()
simulate = do
    logInfoN "Simulating"
    connection <- ask
    let writerAction =
            runStdoutLoggingT . flip runReaderT connection $ do
                tx :: Tx <- liftIO $ generate arbitrary
-
                void $
-
                    runAggregateCommand
-
                        saveTxAggregate
-
                        (UUID.fromWords 0 0 0 1)
-
                        tx
+
                void $ runAggregateCommand saveTxAggregate mockEventSource tx
                --
                requestId <- liftIO $ EventId <$> uuidNextRandom
                request <- liftIO $ generate arbitrary
                void $
                    runAggregateCommand
                        saveRequestResponseAggregate
-
                        (UUID.fromWords 0 0 0 2)
+
                        contractEventSource
                        (IssueRequest requestId request, cancellation, response)
                liftIO pauseBeforeRepeat
        runWriterAction =

                      
------------------------------------------------------------
installContract ::
-
       ( MonadLogger m, MonadEventStore ChainEvent m)
-
    => FilePath
-
    -> m ()
+
       (MonadLogger m, MonadEventStore ChainEvent m) => FilePath -> m ()
installContract filePath = do
    logInfoN $ "Installing: " <> tshow filePath
    void $
        runAggregateCommand
            installCommand
-
            (UUID.fromWords 0 0 0 3)
+
            userEventSource
            (Contract {contractPath = filePath})
    logInfoN "Installed."

                      
        }

                      
activateContract ::
-
       (MonadIO m, MonadLogger m, MonadEventStore ChainEvent m,MonadContract m)
+
       ( MonadIO m
+
       , MonadLogger m
+
       , MonadEventStore ChainEvent m
+
       , MonadContract m
+
       , MonadError SCBError m
+
       )
    => FilePath
-
    -> m (Either SCBError ())
+
    -> m ()
activateContract filePath = do
    logInfoN "Finding Contract"
-
    mContract <- lookupContract filePath
+
    contract <- liftError $ lookupContract filePath
    activeContractId <- liftIO uuidNextRandom
-
    case mContract of
-
        Left err -> pure $ Left err
-
        Right contract -> do
-
            logInfoN "Initializing Contract"
-
            mResponse <-
-
                invokeContract $ InitContract (contractPath contract)
-
            case mResponse of
-
                Left err -> pure $ Left err
-
                Right response -> do
-
                    let activeContractState =
-
                            ActiveContractState
-
                                { activeContract =
-
                                      ActiveContract
-
                                          { activeContractId
-
                                          , activeContractPath =
-
                                                contractPath contract
-
                                          }
-
                                , partiallyDecodedResponse = response
-
                                }
-
                    logInfoN "Storing Initial Contract State"
-
                    void $
-
                        runAggregateCommand
-
                            saveContractState
-
                            (UUID.fromWords 0 0 0 3)
    ( module Events.Contract
    , module Events.Mock
    , module Events.User
+
    , module Events.Node
+
    , module Events.Wallet
    , ChainEvent(..)
    ) where

                      
import           Data.Aeson                 (FromJSON, ToJSON)
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.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
          !(Events.Contract.RequestEvent Events.Contract.ContractRequest)
    | RecordResponse
          !(Events.Contract.ResponseEvent Events.Contract.ContractResponse)
-
    | UserEvent Events.User.UserEvent
-
    | NodeEvent Events.Node.NodeEvent
+
    | UserEvent !Events.User.UserEvent
+
    | NodeEvent !Events.Node.NodeEvent
+
    | WalletEvent !Events.Wallet.WalletEvent
    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)
+
module Plutus.SCB.Events.Node
+
    ( NodeEvent(..)
+
    ) where

                      
-
import           Ledger.Slot (Slot)
-
import           Ledger.Tx   (Tx)
+
import           Data.Aeson   (FromJSON, ToJSON)
+
import           GHC.Generics (Generic)

                      
-
data NodeEvent =
-
  BlockAdded [Tx]
+
import           Ledger       (Slot, Tx, TxId)
+

                      
+
data NodeEvent
+
    = BlockAdded [Tx]
  -- ^ A new block was added to the blockchain
-
  | NewSlot Slot
+
    | NewSlot Slot
  -- ^ A new slot has been added
+
    | SubmittedTx TxId
+
  -- ^ Confirmation that the transactions were received.
  -- TODO: Rollbacks?
  -- | Rollback Int -- ^ n blocks were rolled back
-
  deriving stock (Show, Eq, Generic)
-
  deriving anyclass (FromJSON, ToJSON)
+
    deriving (Show, Eq, Generic)
+
    deriving anyclass (FromJSON, ToJSON)
import           Plutus.SCB.Types (ActiveContractState, Contract)

                      
data UserEvent
-
    = InstallContract Contract
-
    | ContractStateTransition ActiveContractState
+
    = InstallContract !Contract
+
    | ContractStateTransition !ActiveContractState
    deriving (Show, Eq, Generic)
    deriving anyclass (FromJSON, ToJSON)
+
{-# LANGUAGE DeriveAnyClass     #-}
+
{-# LANGUAGE DeriveGeneric      #-}
+
{-# LANGUAGE DerivingStrategies #-}
+

                      
+
module Plutus.SCB.Events.Wallet where
+

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

                      
+
newtype WalletEvent =
+
    BalancedTx Tx
+
    deriving (Show, Eq, Generic)
+
    deriving anyclass (FromJSON, ToJSON)
import           GHC.Generics                       (Generic)
import           Language.Plutus.Contract.Resumable (ResumableError)
import           Options.Applicative.Help.Pretty    (Pretty, indent, pretty, string, text, vsep, (<+>))
+
import           Servant.Client                     (ServantError)
+
import           Wallet.API                         (WalletAPIError)

                      
newtype Contract =
    Contract
    | ContractNotFound FilePath
    | ActiveContractStateNotFound UUID
    | ContractError (ResumableError Text)
+
    | WalletClientError ServantError
+
    | NodeClientError ServantError
+
    | WalletError WalletAPIError
    | ContractCommandError Int Text
+
    | OtherError Text
    deriving (Show, Eq)

                      
data PartiallyDecodedResponse =
+
{-# LANGUAGE LambdaCase #-}
+

                      
module Plutus.SCB.Utils
    ( unfoldM
    , logDebugS
    , logInfoS
    , logErrorS
    , tshow
    , render
+
    , liftError
    ) where

                      
+
import           Control.Monad.Except            (MonadError, throwError)
import           Control.Monad.Logger            (MonadLogger, logDebugN, logErrorN, logInfoN)
import           Data.Text                       (Text)
import qualified Data.Text                       as Text

                      
render :: Pretty a => a -> Text
render x = Text.pack $ displayS (renderPretty 0.4 80 (pretty x)) ""
+

                      
+
-- | This is a lot like the 'ExceptT' constructor, except it doesn't
+
-- force you to accept a specific monad.
+
liftError :: MonadError e m => m (Either e a) -> m a
+
liftError action =
+
    action >>= \case
+
        Left err -> throwError err
+
        Right value -> pure value
    ) 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           Control.Monad.State                           (StateT, evalStateT)
              installed <- installedContracts
              liftIO $ assertEqual "" 1 $ Set.size installed
              --
-
              activationResult <- activateContract "game"
-
              liftIO $ assertRight activationResult
+
              activateContract "game"
              --
              active <- activeContracts
              liftIO $ assertEqual "" 1 $ Set.size active
        ]
  where
    runScenario ::
-
           MonadIO m => StateT (EventMap ChainEvent) (LoggingT m) a -> m a
-
    runScenario action = runStderrLoggingT $ evalStateT action emptyEventMap
+
           MonadIO m
+
        => 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
instance Monad m => MonadContract (StateT state m) where
    invokeContract (InitContract "game") =
        pure $ do
-
            value <- bar $ initialResponse Contracts.Game.game
-
            foo $ JSON.eitherDecode (JSON.encode value)
+
            value <- fromResumable $ initialResponse Contracts.Game.game
+
            fromString $ JSON.eitherDecode (JSON.encode value)
    invokeContract (UpdateContract "game" payload) =
        pure $ do
-
            request <- foo $ JSON.parseEither JSON.parseJSON payload
-
            value <- bar $ runUpdate Contracts.Game.game request
-
            foo $ JSON.eitherDecode (JSON.encode value)
+
            request <- fromString $ JSON.parseEither JSON.parseJSON payload
+
            value <- fromResumable $ runUpdate Contracts.Game.game request
+
            fromString $ JSON.eitherDecode (JSON.encode value)
    invokeContract (InitContract contractPath) =
        pure $ Left $ ContractNotFound contractPath
    invokeContract (UpdateContract contractPath _) =
        pure $ Left $ ContractNotFound contractPath

                      
-
foo :: Either String a -> Either SCBError a
-
foo = first (ContractCommandError 0 . Text.pack)
+
fromString :: Either String a -> Either SCBError a
+
fromString = first (ContractCommandError 0 . Text.pack)

                      
-
bar :: Either (ResumableError Text) a -> Either SCBError a
-
bar = first (ContractCommandError 0 . Text.pack . show)
-

                      
-
assertRight :: (HasCallStack, Show e) => Either e a -> IO ()
-
assertRight (Right _) = pure ()
-
assertRight (Left value) =
-
    void $
-
    assertFailure $ "Expected (Right _), got: (Left " <> show value <> ")"
+
fromResumable :: Either (ResumableError Text) a -> Either SCBError a
+
fromResumable = first (ContractCommandError 0 . Text.pack . show)