{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DerivingStrategies  #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}
{-

The scheduler thread that runs a contract instance.

-}
module Plutus.Trace.Emulator.ContractInstance(
    contractThread
    , getThread
    , EmulatorRuntimeError
    , runInstance
    -- * Instance state
    , ContractInstanceState(..)
    , emptyInstanceState
    , addEventInstanceState
    -- * Indexed block
    , IndexedBlock(..)
    , indexBlock
    -- * Internals
    , getHooks
    , addResponse
    ) where

import Cardano.Api qualified as C
import Control.Lens (at, preview, view, (?~))
import Control.Monad (guard, join, unless, void, when)
import Control.Monad.Freer (Eff, Member, Members, interpret, send, subsume)
import Control.Monad.Freer.Error (Error, throwError)
import Control.Monad.Freer.Extras.Log (LogMessage, LogMsg (LMessage), LogObserve, logDebug, logError, logInfo, logWarn,
                                       mapLog)
import Control.Monad.Freer.Extras.Modify (raiseEnd)
import Control.Monad.Freer.Reader (Reader, ask, runReader)
import Control.Monad.Freer.State (State, evalState, get, gets, modify, put)
import Data.Aeson qualified as JSON
import Data.Foldable (traverse_)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe (listToMaybe, mapMaybe)
import Data.Set qualified as Set
import Data.Text qualified as T
import Ledger.Address (CardanoAddress)
import Ledger.Blockchain (OnChainTx, onChainTxIsValid, unOnChain)
import Ledger.Tx (getCardanoTxId)
import Ledger.Tx.CardanoAPI (fromCardanoTxIn, toCardanoTxIn)
import Plutus.ChainIndex (ChainIndexQueryEffect, ChainIndexTx (_citxTxId),
                          ChainIndexTxOut (ChainIndexTxOut, citoAddress), RollbackState (Committed),
                          TxOutState (Spent, Unspent), TxValidity (TxInvalid, TxValid), citxInputs, fromOnChainTx,
                          txOutRefs, txOuts, validityFromChainIndex)
import Plutus.Contract (Contract)
import Plutus.Contract.Effects (PABReq, PABResp (AwaitTxStatusChangeResp), matches)
import Plutus.Contract.Effects qualified as E
import Plutus.Contract.Resumable (Request (Request, rqID, rqRequest),
                                  Response (Response, rspItID, rspResponse, rspRqID), itID)
import Plutus.Contract.Resumable qualified as State
import Plutus.Contract.Trace qualified as RequestHandler
import Plutus.Contract.Trace.RequestHandler (RequestHandler (RequestHandler), RequestHandlerLogMsg, tryHandler,
                                             wrapHandler)
import Plutus.Contract.Types (ResumableResult (ResumableResult, _finalState), lastLogs, requests, resumableResult)
import Plutus.Trace.Emulator.Types (ContractConstraints, ContractHandle (..), ContractInstanceLog (ContractInstanceLog),
                                    ContractInstanceMsg (ContractLog, CurrentRequests, Freezing, HandledRequest, InstErr, NoRequestsHandled, ReceiveEndpointCall, SendingContractState, Started, StoppedNoError, StoppedWithError),
                                    ContractInstanceState (ContractInstanceState, instContractState, instEvents, instHandlersHistory),
                                    ContractInstanceStateInternal (cisiSuspState), EmulatedWalletEffects,
                                    EmulatedWalletEffects', EmulatorAgentThreadEffs,
                                    EmulatorMessage (ContractInstanceStateRequest, ContractInstanceStateResponse, EndpointCall, Freeze, NewSlot),
                                    EmulatorRuntimeError (EmulatorJSONDecodingError, ThreadIdNotFound), EmulatorThreads,
                                    addEventInstanceState, emptyInstanceState, instanceIdThreads, toInstanceState)
import Plutus.Trace.Scheduler (MessageCall (Message, WaitForMessage), Priority (Frozen, Normal, Sleeping), ThreadId,
                               mkAgentSysCall)
import Wallet.API qualified as WAPI
import Wallet.Effects (NodeClientEffect, WalletEffect)
import Wallet.Emulator.LogMessages (TxBalanceMsg)
import Wallet.Types (ContractInstanceId)

-- | Effects available to threads that run in the context of specific
--   agents (ie wallets)
type ContractInstanceThreadEffs w s e effs =
    State (ContractInstanceStateInternal w s e ())
    ': Reader ContractInstanceId
    ': LogMsg ContractInstanceMsg
    ': EmulatorAgentThreadEffs effs

-- | Start a new thread for a contract. Most of the work happens in
--   'runInstance'.
contractThread :: forall w s e effs.
    ( Member (State EmulatorThreads) effs
    , Member (Error EmulatorRuntimeError) effs
    , ContractConstraints s
    , Show e
    , JSON.ToJSON e
    , JSON.ToJSON w
    , Monoid w
    )
    => ContractHandle w s e
    -> Eff (EmulatorAgentThreadEffs effs) ()
contractThread :: ContractHandle w s e -> Eff (EmulatorAgentThreadEffs effs) ()
contractThread ContractHandle{ContractInstanceId
chInstanceId :: forall w (s :: Row *) e. ContractHandle w s e -> ContractInstanceId
chInstanceId :: ContractInstanceId
chInstanceId, Contract w s e ()
chContract :: forall w (s :: Row *) e. ContractHandle w s e -> Contract w s e ()
chContract :: Contract w s e ()
chContract, ContractInstanceTag
chInstanceTag :: forall w (s :: Row *) e.
ContractHandle w s e -> ContractInstanceTag
chInstanceTag :: ContractInstanceTag
chInstanceTag, NetworkId
chNetworkId :: forall w (s :: Row *) e. ContractHandle w s e -> NetworkId
chNetworkId :: NetworkId
chNetworkId} = do
    forall (effs :: [* -> *]).
Member (Reader ThreadId) effs =>
Eff effs ThreadId
forall r (effs :: [* -> *]). Member (Reader r) effs => Eff effs r
ask @ThreadId Eff (EmulatorAgentThreadEffs effs) ThreadId
-> (ThreadId -> Eff (EmulatorAgentThreadEffs effs) ())
-> Eff (EmulatorAgentThreadEffs effs) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ContractInstanceId
-> ThreadId -> Eff (EmulatorAgentThreadEffs effs) ()
forall (effs :: [* -> *]).
Member (State EmulatorThreads) effs =>
ContractInstanceId -> ThreadId -> Eff effs ()
registerInstance ContractInstanceId
chInstanceId
    (LogMsg ContractInstanceMsg ~> Eff (EmulatorAgentThreadEffs effs))
-> Eff (LogMsg ContractInstanceMsg : EmulatorAgentThreadEffs effs)
   ~> Eff (EmulatorAgentThreadEffs effs)
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret ((ContractInstanceMsg -> ContractInstanceLog)
-> LogMsg ContractInstanceMsg ~> Eff (EmulatorAgentThreadEffs effs)
forall a b (effs :: [* -> *]).
Member (LogMsg b) effs =>
(a -> b) -> LogMsg a ~> Eff effs
mapLog (\ContractInstanceMsg
m -> ContractInstanceMsg
-> ContractInstanceId -> ContractInstanceTag -> ContractInstanceLog
ContractInstanceLog ContractInstanceMsg
m ContractInstanceId
chInstanceId ContractInstanceTag
chInstanceTag))
        (Eff (LogMsg ContractInstanceMsg : EmulatorAgentThreadEffs effs) ()
 -> Eff (EmulatorAgentThreadEffs effs) ())
-> Eff
     (LogMsg ContractInstanceMsg : EmulatorAgentThreadEffs effs) ()
-> Eff (EmulatorAgentThreadEffs effs) ()
forall a b. (a -> b) -> a -> b
$ ContractInstanceId
-> Eff
     (Reader ContractInstanceId
        : LogMsg ContractInstanceMsg : EmulatorAgentThreadEffs effs)
     ()
-> Eff
     (LogMsg ContractInstanceMsg : EmulatorAgentThreadEffs effs) ()
forall r (effs :: [* -> *]) a.
r -> Eff (Reader r : effs) a -> Eff effs a
runReader ContractInstanceId
chInstanceId
        (Eff
   (Reader ContractInstanceId
      : LogMsg ContractInstanceMsg : EmulatorAgentThreadEffs effs)
   ()
 -> Eff
      (LogMsg ContractInstanceMsg : EmulatorAgentThreadEffs effs) ())
-> Eff
     (Reader ContractInstanceId
        : LogMsg ContractInstanceMsg : EmulatorAgentThreadEffs effs)
     ()
-> Eff
     (LogMsg ContractInstanceMsg : EmulatorAgentThreadEffs effs) ()
forall a b. (a -> b) -> a -> b
$ ContractInstanceStateInternal w s e ()
-> Eff
     (State (ContractInstanceStateInternal w s e ())
        : Reader ContractInstanceId : LogMsg ContractInstanceMsg
        : EmulatorAgentThreadEffs effs)
     ()
-> Eff
     (Reader ContractInstanceId
        : LogMsg ContractInstanceMsg : EmulatorAgentThreadEffs effs)
     ()
forall s (effs :: [* -> *]) a.
s -> Eff (State s : effs) a -> Eff effs a
evalState (Contract w s e () -> ContractInstanceStateInternal w s e ()
forall w (s :: Row *) e a.
Monoid w =>
Contract w s e a -> ContractInstanceStateInternal w s e a
emptyInstanceState Contract w s e ()
chContract)
        (Eff
   (State (ContractInstanceStateInternal w s e ())
      : Reader ContractInstanceId : LogMsg ContractInstanceMsg
      : EmulatorAgentThreadEffs effs)
   ()
 -> Eff
      (Reader ContractInstanceId
         : LogMsg ContractInstanceMsg : EmulatorAgentThreadEffs effs)
      ())
-> Eff
     (State (ContractInstanceStateInternal w s e ())
        : Reader ContractInstanceId : LogMsg ContractInstanceMsg
        : EmulatorAgentThreadEffs effs)
     ()
-> Eff
     (Reader ContractInstanceId
        : LogMsg ContractInstanceMsg : EmulatorAgentThreadEffs effs)
     ()
forall a b. (a -> b) -> a -> b
$ do
            ContractInstanceMsg
-> Eff
     (State (ContractInstanceStateInternal w s e ())
        : Reader ContractInstanceId : LogMsg ContractInstanceMsg
        : EmulatorAgentThreadEffs effs)
     ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logInfo ContractInstanceMsg
Started
            forall (effs :: [* -> *]).
(Member (LogMsg ContractInstanceMsg) effs,
 Member (State (ContractInstanceStateInternal w s e ())) effs) =>
Eff effs ()
forall w (s :: Row *) e (effs :: [* -> *]).
(Member (LogMsg ContractInstanceMsg) effs,
 Member (State (ContractInstanceStateInternal w s e ())) effs) =>
Eff effs ()
logNewMessages @w @s @e
            forall (effs :: [* -> *]).
(Member (State (ContractInstanceStateInternal w s e ())) effs,
 Member (LogMsg ContractInstanceMsg) effs) =>
Eff effs ()
forall w (s :: Row *) e (effs :: [* -> *]).
(Member (State (ContractInstanceStateInternal w s e ())) effs,
 Member (LogMsg ContractInstanceMsg) effs) =>
Eff effs ()
logCurrentRequests @w @s @e
            Maybe EmulatorMessage
msg <- Priority
-> MessageCall EmulatorMessage
-> Eff
     (State (ContractInstanceStateInternal w s e ())
        : Reader ContractInstanceId : LogMsg ContractInstanceMsg
        : EmulatorAgentThreadEffs effs)
     (Maybe EmulatorMessage)
forall (effs :: [* -> *]) systemEvent.
Member
  (Yield (AgentSystemCall systemEvent) (Maybe systemEvent)) effs =>
Priority -> MessageCall systemEvent -> Eff effs (Maybe systemEvent)
mkAgentSysCall @_ @EmulatorMessage Priority
Normal MessageCall EmulatorMessage
forall systemEvent. MessageCall systemEvent
WaitForMessage
            NetworkId
-> Contract w s e ()
-> Maybe EmulatorMessage
-> Eff
     (State (ContractInstanceStateInternal w s e ())
        : Reader ContractInstanceId : LogMsg ContractInstanceMsg
        : EmulatorAgentThreadEffs effs)
     ()
forall w (s :: Row *) e (effs :: [* -> *]).
(ContractConstraints s, Member (Error EmulatorRuntimeError) effs,
 Show e, ToJSON e, ToJSON w, Monoid w) =>
NetworkId
-> Contract w s e ()
-> Maybe EmulatorMessage
-> Eff (ContractInstanceThreadEffs w s e effs) ()
runInstance NetworkId
chNetworkId Contract w s e ()
chContract Maybe EmulatorMessage
msg
            Contract w s e ()
-> Maybe EmulatorMessage
-> Eff
     (State (ContractInstanceStateInternal w s e ())
        : Reader ContractInstanceId : LogMsg ContractInstanceMsg
        : EmulatorAgentThreadEffs effs)
     ()
forall w (s :: Row *) e (effs :: [* -> *]).
(ContractConstraints s, Member (Error EmulatorRuntimeError) effs,
 Show e, ToJSON e, ToJSON w, Monoid w) =>
Contract w s e ()
-> Maybe EmulatorMessage
-> Eff (ContractInstanceThreadEffs w s e effs) ()
runInstanceObservableState Contract w s e ()
chContract Maybe EmulatorMessage
msg

registerInstance :: forall effs.
    ( Member (State EmulatorThreads) effs )
    => ContractInstanceId
    -> ThreadId
    -> Eff effs ()
registerInstance :: ContractInstanceId -> ThreadId -> Eff effs ()
registerInstance ContractInstanceId
i ThreadId
t = (EmulatorThreads -> EmulatorThreads) -> Eff effs ()
forall s (effs :: [* -> *]).
Member (State s) effs =>
(s -> s) -> Eff effs ()
modify ((Map ContractInstanceId ThreadId
 -> Identity (Map ContractInstanceId ThreadId))
-> EmulatorThreads -> Identity EmulatorThreads
Iso' EmulatorThreads (Map ContractInstanceId ThreadId)
instanceIdThreads ((Map ContractInstanceId ThreadId
  -> Identity (Map ContractInstanceId ThreadId))
 -> EmulatorThreads -> Identity EmulatorThreads)
-> ((Maybe ThreadId -> Identity (Maybe ThreadId))
    -> Map ContractInstanceId ThreadId
    -> Identity (Map ContractInstanceId ThreadId))
-> (Maybe ThreadId -> Identity (Maybe ThreadId))
-> EmulatorThreads
-> Identity EmulatorThreads
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map ContractInstanceId ThreadId)
-> Lens'
     (Map ContractInstanceId ThreadId)
     (Maybe (IxValue (Map ContractInstanceId ThreadId)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map ContractInstanceId ThreadId)
ContractInstanceId
i ((Maybe ThreadId -> Identity (Maybe ThreadId))
 -> EmulatorThreads -> Identity EmulatorThreads)
-> ThreadId -> EmulatorThreads -> EmulatorThreads
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ ThreadId
t)

getThread :: forall effs.
    ( Member (State EmulatorThreads) effs
    , Member (Error EmulatorRuntimeError) effs
    )
    => ContractInstanceId
    -> Eff effs ThreadId
getThread :: ContractInstanceId -> Eff effs ThreadId
getThread ContractInstanceId
t = do
    Maybe ThreadId
r <- (EmulatorThreads -> Maybe ThreadId) -> Eff effs (Maybe ThreadId)
forall s a (effs :: [* -> *]).
Member (State s) effs =>
(s -> a) -> Eff effs a
gets (Getting (Maybe ThreadId) EmulatorThreads (Maybe ThreadId)
-> EmulatorThreads -> Maybe ThreadId
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Maybe ThreadId) EmulatorThreads (Maybe ThreadId)
 -> EmulatorThreads -> Maybe ThreadId)
-> Getting (Maybe ThreadId) EmulatorThreads (Maybe ThreadId)
-> EmulatorThreads
-> Maybe ThreadId
forall a b. (a -> b) -> a -> b
$ (Map ContractInstanceId ThreadId
 -> Const (Maybe ThreadId) (Map ContractInstanceId ThreadId))
-> EmulatorThreads -> Const (Maybe ThreadId) EmulatorThreads
Iso' EmulatorThreads (Map ContractInstanceId ThreadId)
instanceIdThreads ((Map ContractInstanceId ThreadId
  -> Const (Maybe ThreadId) (Map ContractInstanceId ThreadId))
 -> EmulatorThreads -> Const (Maybe ThreadId) EmulatorThreads)
-> ((Maybe ThreadId -> Const (Maybe ThreadId) (Maybe ThreadId))
    -> Map ContractInstanceId ThreadId
    -> Const (Maybe ThreadId) (Map ContractInstanceId ThreadId))
-> Getting (Maybe ThreadId) EmulatorThreads (Maybe ThreadId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map ContractInstanceId ThreadId)
-> Lens'
     (Map ContractInstanceId ThreadId)
     (Maybe (IxValue (Map ContractInstanceId ThreadId)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map ContractInstanceId ThreadId)
ContractInstanceId
t)
    Eff effs ThreadId
-> (ThreadId -> Eff effs ThreadId)
-> Maybe ThreadId
-> Eff effs ThreadId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (EmulatorRuntimeError -> Eff effs ThreadId
forall e (effs :: [* -> *]) a.
Member (Error e) effs =>
e -> Eff effs a
throwError (EmulatorRuntimeError -> Eff effs ThreadId)
-> EmulatorRuntimeError -> Eff effs ThreadId
forall a b. (a -> b) -> a -> b
$ ContractInstanceId -> EmulatorRuntimeError
ThreadIdNotFound ContractInstanceId
t) ThreadId -> Eff effs ThreadId
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ThreadId
r

logStopped :: forall w e effs.
    ( Member (LogMsg ContractInstanceMsg) effs
    , Show e
    )
    => ResumableResult w e PABResp PABReq ()
    -> Eff effs ()
logStopped :: ResumableResult w e PABResp PABReq () -> Eff effs ()
logStopped ResumableResult{Either e (Maybe ())
_finalState :: Either e (Maybe ())
_finalState :: forall w e i o1 a. ResumableResult w e i o1 a -> Either e (Maybe a)
_finalState} =
    case Either e (Maybe ())
_finalState of
        Left e
e  -> ContractInstanceMsg -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logWarn (ContractInstanceMsg -> Eff effs ())
-> ContractInstanceMsg -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ String -> ContractInstanceMsg
StoppedWithError (String -> ContractInstanceMsg) -> String -> ContractInstanceMsg
forall a b. (a -> b) -> a -> b
$ e -> String
forall a. Show a => a -> String
show e
e
        Right Maybe ()
_ -> ContractInstanceMsg -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logInfo ContractInstanceMsg
StoppedNoError

-- | Run an instance of a contract
runInstance :: forall w s e effs.
    ( ContractConstraints s
    , Member (Error EmulatorRuntimeError) effs
    , Show e
    , JSON.ToJSON e
    , JSON.ToJSON w
    , Monoid w
    )
    => C.NetworkId
    -> Contract w s e ()
    -> Maybe EmulatorMessage
    -> Eff (ContractInstanceThreadEffs w s e effs) ()
runInstance :: NetworkId
-> Contract w s e ()
-> Maybe EmulatorMessage
-> Eff (ContractInstanceThreadEffs w s e effs) ()
runInstance NetworkId
networkId Contract w s e ()
contract Maybe EmulatorMessage
event = do
    [Request PABReq]
hks <- forall (effs :: [* -> *]).
Member (State (ContractInstanceStateInternal w s e ())) effs =>
Eff effs [Request PABReq]
forall w (s :: Row *) e (effs :: [* -> *]).
Member (State (ContractInstanceStateInternal w s e ())) effs =>
Eff effs [Request PABReq]
getHooks @w @s @e
    Bool
-> Eff (ContractInstanceThreadEffs w s e effs) ()
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Request PABReq] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Request PABReq]
hks) (Eff (ContractInstanceThreadEffs w s e effs) ()
 -> Eff (ContractInstanceThreadEffs w s e effs) ())
-> Eff (ContractInstanceThreadEffs w s e effs) ()
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall a b. (a -> b) -> a -> b
$
        (ContractInstanceStateInternal w s e ()
 -> ResumableResult w e PABResp PABReq ())
-> Eff
     (ContractInstanceThreadEffs w s e effs)
     (ResumableResult w e PABResp PABReq ())
forall s a (effs :: [* -> *]).
Member (State s) effs =>
(s -> a) -> Eff effs a
gets @(ContractInstanceStateInternal w s e ()) (Getting
  (ResumableResult w e PABResp PABReq ())
  (SuspendedContract w e PABResp PABReq ())
  (ResumableResult w e PABResp PABReq ())
-> SuspendedContract w e PABResp PABReq ()
-> ResumableResult w e PABResp PABReq ()
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (ResumableResult w e PABResp PABReq ())
  (SuspendedContract w e PABResp PABReq ())
  (ResumableResult w e PABResp PABReq ())
forall w e i o a.
Lens' (SuspendedContract w e i o a) (ResumableResult w e i o a)
resumableResult (SuspendedContract w e PABResp PABReq ()
 -> ResumableResult w e PABResp PABReq ())
-> (ContractInstanceStateInternal w s e ()
    -> SuspendedContract w e PABResp PABReq ())
-> ContractInstanceStateInternal w s e ()
-> ResumableResult w e PABResp PABReq ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContractInstanceStateInternal w s e ()
-> SuspendedContract w e PABResp PABReq ()
forall w (s :: Row *) e a.
ContractInstanceStateInternal w s e a
-> SuspendedContract w e PABResp PABReq a
cisiSuspState) Eff
  (ContractInstanceThreadEffs w s e effs)
  (ResumableResult w e PABResp PABReq ())
-> (ResumableResult w e PABResp PABReq ()
    -> Eff (ContractInstanceThreadEffs w s e effs) ())
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ResumableResult w e PABResp PABReq ()
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall w e (effs :: [* -> *]).
(Member (LogMsg ContractInstanceMsg) effs, Show e) =>
ResumableResult w e PABResp PABReq () -> Eff effs ()
logStopped
    Bool
-> Eff (ContractInstanceThreadEffs w s e effs) ()
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Request PABReq] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Request PABReq]
hks) (Eff (ContractInstanceThreadEffs w s e effs) ()
 -> Eff (ContractInstanceThreadEffs w s e effs) ())
-> Eff (ContractInstanceThreadEffs w s e effs) ()
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall a b. (a -> b) -> a -> b
$
        case Maybe EmulatorMessage
event of
            Just EmulatorMessage
Freeze -> do
                ContractInstanceMsg
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logInfo ContractInstanceMsg
Freezing
                -- freeze ourselves, see note [Freeze and Thaw]
                Priority
-> MessageCall EmulatorMessage
-> Eff
     (ContractInstanceThreadEffs w s e effs) (Maybe EmulatorMessage)
forall (effs :: [* -> *]) systemEvent.
Member
  (Yield (AgentSystemCall systemEvent) (Maybe systemEvent)) effs =>
Priority -> MessageCall systemEvent -> Eff effs (Maybe systemEvent)
mkAgentSysCall Priority
Frozen MessageCall EmulatorMessage
forall systemEvent. MessageCall systemEvent
WaitForMessage Eff (ContractInstanceThreadEffs w s e effs) (Maybe EmulatorMessage)
-> (Maybe EmulatorMessage
    -> Eff (ContractInstanceThreadEffs w s e effs) ())
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NetworkId
-> Contract w s e ()
-> Maybe EmulatorMessage
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall w (s :: Row *) e (effs :: [* -> *]).
(ContractConstraints s, Member (Error EmulatorRuntimeError) effs,
 Show e, ToJSON e, ToJSON w, Monoid w) =>
NetworkId
-> Contract w s e ()
-> Maybe EmulatorMessage
-> Eff (ContractInstanceThreadEffs w s e effs) ()
runInstance NetworkId
networkId Contract w s e ()
contract
            Just (EndpointCall ThreadId
_ EndpointDescription
desc Value
vl) -> do
                ContractInstanceMsg
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logInfo (ContractInstanceMsg
 -> Eff (ContractInstanceThreadEffs w s e effs) ())
-> ContractInstanceMsg
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall a b. (a -> b) -> a -> b
$ EndpointDescription -> Value -> ContractInstanceMsg
ReceiveEndpointCall EndpointDescription
desc Value
vl
                PABResp
e <- Value -> Eff (ContractInstanceThreadEffs w s e effs) PABResp
forall (effs :: [* -> *]).
(Member (LogMsg ContractInstanceMsg) effs,
 Member (Error EmulatorRuntimeError) effs) =>
Value -> Eff effs PABResp
decodeEvent Value
vl
                Maybe (Response PABResp)
_ <- PABResp
-> Eff
     (ContractInstanceThreadEffs w s e effs) (Maybe (Response PABResp))
forall w (s :: Row *) e (effs :: [* -> *]).
(Member (State (ContractInstanceStateInternal w s e ())) effs,
 Members EmulatedWalletEffects effs,
 Member (Reader ContractInstanceId) effs,
 Member (LogMsg ContractInstanceMsg) effs, Monoid w) =>
PABResp -> Eff effs (Maybe (Response PABResp))
respondToEvent @w @s @e PABResp
e
                Priority
-> MessageCall EmulatorMessage
-> Eff
     (ContractInstanceThreadEffs w s e effs) (Maybe EmulatorMessage)
forall (effs :: [* -> *]) systemEvent.
Member
  (Yield (AgentSystemCall systemEvent) (Maybe systemEvent)) effs =>
Priority -> MessageCall systemEvent -> Eff effs (Maybe systemEvent)
mkAgentSysCall Priority
Normal MessageCall EmulatorMessage
forall systemEvent. MessageCall systemEvent
WaitForMessage Eff (ContractInstanceThreadEffs w s e effs) (Maybe EmulatorMessage)
-> (Maybe EmulatorMessage
    -> Eff (ContractInstanceThreadEffs w s e effs) ())
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NetworkId
-> Contract w s e ()
-> Maybe EmulatorMessage
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall w (s :: Row *) e (effs :: [* -> *]).
(ContractConstraints s, Member (Error EmulatorRuntimeError) effs,
 Show e, ToJSON e, ToJSON w, Monoid w) =>
NetworkId
-> Contract w s e ()
-> Maybe EmulatorMessage
-> Eff (ContractInstanceThreadEffs w s e effs) ()
runInstance NetworkId
networkId Contract w s e ()
contract
            Just (ContractInstanceStateRequest ThreadId
sender) -> do
                ThreadId -> Eff (ContractInstanceThreadEffs w s e effs) ()
forall w (s :: Row *) e (effs :: [* -> *]).
(ToJSON e, ToJSON w) =>
ThreadId -> Eff (ContractInstanceThreadEffs w s e effs) ()
handleObservableStateRequest ThreadId
sender
                Priority
-> MessageCall EmulatorMessage
-> Eff
     (ContractInstanceThreadEffs w s e effs) (Maybe EmulatorMessage)
forall (effs :: [* -> *]) systemEvent.
Member
  (Yield (AgentSystemCall systemEvent) (Maybe systemEvent)) effs =>
Priority -> MessageCall systemEvent -> Eff effs (Maybe systemEvent)
mkAgentSysCall Priority
Normal MessageCall EmulatorMessage
forall systemEvent. MessageCall systemEvent
WaitForMessage Eff (ContractInstanceThreadEffs w s e effs) (Maybe EmulatorMessage)
-> (Maybe EmulatorMessage
    -> Eff (ContractInstanceThreadEffs w s e effs) ())
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NetworkId
-> Contract w s e ()
-> Maybe EmulatorMessage
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall w (s :: Row *) e (effs :: [* -> *]).
(ContractConstraints s, Member (Error EmulatorRuntimeError) effs,
 Show e, ToJSON e, ToJSON w, Monoid w) =>
NetworkId
-> Contract w s e ()
-> Maybe EmulatorMessage
-> Eff (ContractInstanceThreadEffs w s e effs) ()
runInstance NetworkId
networkId Contract w s e ()
contract
            Just (NewSlot [Block]
block Slot
_) -> do
                Block -> Eff (ContractInstanceThreadEffs w s e effs) ()
forall w (s :: Row *) e (effs :: [* -> *]).
(Member (State (ContractInstanceStateInternal w s e ())) effs,
 Member (LogMsg ContractInstanceMsg) effs, Monoid w) =>
Block -> Eff effs ()
processNewTransactions @w @s @e ([Block] -> Block
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [Block]
block)
                NetworkId
-> Contract w s e ()
-> Maybe EmulatorMessage
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall w (s :: Row *) e (effs :: [* -> *]).
(ContractConstraints s, Member (Error EmulatorRuntimeError) effs,
 Show e, ToJSON e, ToJSON w, Monoid w) =>
NetworkId
-> Contract w s e ()
-> Maybe EmulatorMessage
-> Eff (ContractInstanceThreadEffs w s e effs) ()
runInstance NetworkId
networkId Contract w s e ()
contract Maybe EmulatorMessage
forall a. Maybe a
Nothing
            Maybe EmulatorMessage
_ -> Bool
-> Eff
     (ContractInstanceThreadEffs w s e effs) (Maybe EmulatorMessage)
forall w (s :: Row *) e (effs :: [* -> *]).
Monoid w =>
Bool
-> Eff
     (ContractInstanceThreadEffs w s e effs) (Maybe EmulatorMessage)
waitForNextMessage Bool
True Eff (ContractInstanceThreadEffs w s e effs) (Maybe EmulatorMessage)
-> (Maybe EmulatorMessage
    -> Eff (ContractInstanceThreadEffs w s e effs) ())
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NetworkId
-> Contract w s e ()
-> Maybe EmulatorMessage
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall w (s :: Row *) e (effs :: [* -> *]).
(ContractConstraints s, Member (Error EmulatorRuntimeError) effs,
 Show e, ToJSON e, ToJSON w, Monoid w) =>
NetworkId
-> Contract w s e ()
-> Maybe EmulatorMessage
-> Eff (ContractInstanceThreadEffs w s e effs) ()
runInstance NetworkId
networkId Contract w s e ()
contract

-- | Run an instance to only answer to observable state requests even when the
-- contract has stopped.
runInstanceObservableState :: forall w s e effs.
    ( ContractConstraints s
    , Member (Error EmulatorRuntimeError) effs
    , Show e
    , JSON.ToJSON e
    , JSON.ToJSON w
    , Monoid w
    )
    => Contract w s e ()
    -> Maybe EmulatorMessage
    -> Eff (ContractInstanceThreadEffs w s e effs) ()
runInstanceObservableState :: Contract w s e ()
-> Maybe EmulatorMessage
-> Eff (ContractInstanceThreadEffs w s e effs) ()
runInstanceObservableState Contract w s e ()
contract Maybe EmulatorMessage
event = do
    case Maybe EmulatorMessage
event of
        Just (ContractInstanceStateRequest ThreadId
sender) -> do
            ThreadId -> Eff (ContractInstanceThreadEffs w s e effs) ()
forall w (s :: Row *) e (effs :: [* -> *]).
(ToJSON e, ToJSON w) =>
ThreadId -> Eff (ContractInstanceThreadEffs w s e effs) ()
handleObservableStateRequest ThreadId
sender
            Priority
-> MessageCall EmulatorMessage
-> Eff
     (ContractInstanceThreadEffs w s e effs) (Maybe EmulatorMessage)
forall (effs :: [* -> *]) systemEvent.
Member
  (Yield (AgentSystemCall systemEvent) (Maybe systemEvent)) effs =>
Priority -> MessageCall systemEvent -> Eff effs (Maybe systemEvent)
mkAgentSysCall Priority
Normal MessageCall EmulatorMessage
forall systemEvent. MessageCall systemEvent
WaitForMessage Eff (ContractInstanceThreadEffs w s e effs) (Maybe EmulatorMessage)
-> (Maybe EmulatorMessage
    -> Eff (ContractInstanceThreadEffs w s e effs) ())
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Contract w s e ()
-> Maybe EmulatorMessage
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall w (s :: Row *) e (effs :: [* -> *]).
(ContractConstraints s, Member (Error EmulatorRuntimeError) effs,
 Show e, ToJSON e, ToJSON w, Monoid w) =>
Contract w s e ()
-> Maybe EmulatorMessage
-> Eff (ContractInstanceThreadEffs w s e effs) ()
runInstanceObservableState Contract w s e ()
contract
        Maybe EmulatorMessage
_ -> Bool
-> Eff
     (ContractInstanceThreadEffs w s e effs) (Maybe EmulatorMessage)
forall w (s :: Row *) e (effs :: [* -> *]).
Monoid w =>
Bool
-> Eff
     (ContractInstanceThreadEffs w s e effs) (Maybe EmulatorMessage)
waitForNextMessage Bool
False Eff (ContractInstanceThreadEffs w s e effs) (Maybe EmulatorMessage)
-> (Maybe EmulatorMessage
    -> Eff (ContractInstanceThreadEffs w s e effs) ())
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Contract w s e ()
-> Maybe EmulatorMessage
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall w (s :: Row *) e (effs :: [* -> *]).
(ContractConstraints s, Member (Error EmulatorRuntimeError) effs,
 Show e, ToJSON e, ToJSON w, Monoid w) =>
Contract w s e ()
-> Maybe EmulatorMessage
-> Eff (ContractInstanceThreadEffs w s e effs) ()
runInstanceObservableState Contract w s e ()
contract

-- | Contract instance state request handler.
handleObservableStateRequest :: forall w s e effs.
    ( JSON.ToJSON e
    , JSON.ToJSON w
    )
    => ThreadId -- ^ Thread ID sending the request
    -> Eff (ContractInstanceThreadEffs w s e effs) ()
handleObservableStateRequest :: ThreadId -> Eff (ContractInstanceThreadEffs w s e effs) ()
handleObservableStateRequest ThreadId
sender = do
    ContractInstanceStateInternal w s e ()
state <- forall (effs :: [* -> *]).
Member (State (ContractInstanceStateInternal w s e ())) effs =>
Eff effs (ContractInstanceStateInternal w s e ())
forall s (effs :: [* -> *]). Member (State s) effs => Eff effs s
get @(ContractInstanceStateInternal w s e ())

    -- TODO: Maybe we should send it as a 'Dynamic' instead of
    -- JSON? It all stays in the same process, and it would save
    -- us having to convert to 'Value' and back.
    let stateJSON :: Value
stateJSON = ContractInstanceState w s e () -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON (ContractInstanceState w s e () -> Value)
-> ContractInstanceState w s e () -> Value
forall a b. (a -> b) -> a -> b
$ ContractInstanceStateInternal w s e ()
-> ContractInstanceState w s e ()
forall w (s :: Row *) e a.
ContractInstanceStateInternal w s e a
-> ContractInstanceState w s e a
toInstanceState ContractInstanceStateInternal w s e ()
state
    ContractInstanceMsg
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logInfo (ContractInstanceMsg
 -> Eff (ContractInstanceThreadEffs w s e effs) ())
-> ContractInstanceMsg
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> ContractInstanceMsg
SendingContractState ThreadId
sender
    Eff (ContractInstanceThreadEffs w s e effs) (Maybe EmulatorMessage)
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Eff
   (ContractInstanceThreadEffs w s e effs) (Maybe EmulatorMessage)
 -> Eff (ContractInstanceThreadEffs w s e effs) ())
-> Eff
     (ContractInstanceThreadEffs w s e effs) (Maybe EmulatorMessage)
-> Eff (ContractInstanceThreadEffs w s e effs) ()
forall a b. (a -> b) -> a -> b
$ Priority
-> MessageCall EmulatorMessage
-> Eff
     (ContractInstanceThreadEffs w s e effs) (Maybe EmulatorMessage)
forall (effs :: [* -> *]) systemEvent.
Member
  (Yield (AgentSystemCall systemEvent) (Maybe systemEvent)) effs =>
Priority -> MessageCall systemEvent -> Eff effs (Maybe systemEvent)
mkAgentSysCall Priority
Normal (ThreadId -> EmulatorMessage -> MessageCall EmulatorMessage
forall systemEvent.
ThreadId -> systemEvent -> MessageCall systemEvent
Message ThreadId
sender (EmulatorMessage -> MessageCall EmulatorMessage)
-> EmulatorMessage -> MessageCall EmulatorMessage
forall a b. (a -> b) -> a -> b
$ Value -> EmulatorMessage
ContractInstanceStateResponse Value
stateJSON)

-- | Wait for the next emulator message.
waitForNextMessage :: forall w s e effs.
    ( Monoid w
    )
    => Bool -- ^ Flag on whether to log 'NoRequestsHandled' messages
    -> Eff (ContractInstanceThreadEffs w s e effs) (Maybe EmulatorMessage)
waitForNextMessage :: Bool
-> Eff
     (ContractInstanceThreadEffs w s e effs) (Maybe EmulatorMessage)
waitForNextMessage Bool
isLogShowed = do
    Maybe (Response PABResp)
response <- Bool
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> Eff
     (ContractInstanceThreadEffs w s e effs) (Maybe (Response PABResp))
forall w (s :: Row *) e (effs :: [* -> *]).
(Member (State (ContractInstanceStateInternal w s e ())) effs,
 Member (Reader ContractInstanceId) effs,
 Member (LogMsg ContractInstanceMsg) effs,
 Members EmulatedWalletEffects effs, Monoid w) =>
Bool
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> Eff effs (Maybe (Response PABResp))
respondToRequest @w @s @e Bool
isLogShowed RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
handleBlockchainQueries
    let prio :: Priority
prio =
            Priority
-> (Response PABResp -> Priority)
-> Maybe (Response PABResp)
-> Priority
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                -- If no events could be handled we go to sleep
                -- with the lowest priority, waking only after
                -- some external event has happened, for example
                -- when a new block was added.
                Priority
Sleeping

                -- If an event was handled we go to sleep with
                -- the 'Normal' priority, trying again after all
                -- other active threads have had their turn
                (Priority -> Response PABResp -> Priority
forall a b. a -> b -> a
const Priority
Normal)
                Maybe (Response PABResp)
response
    Priority
-> MessageCall EmulatorMessage
-> Eff
     (ContractInstanceThreadEffs w s e effs) (Maybe EmulatorMessage)
forall (effs :: [* -> *]) systemEvent.
Member
  (Yield (AgentSystemCall systemEvent) (Maybe systemEvent)) effs =>
Priority -> MessageCall systemEvent -> Eff effs (Maybe systemEvent)
mkAgentSysCall Priority
prio MessageCall EmulatorMessage
forall systemEvent. MessageCall systemEvent
WaitForMessage

handleBlockchainQueries ::
    RequestHandler
        (Reader ContractInstanceId ': EmulatedWalletEffects)
        PABReq
        PABResp
handleBlockchainQueries :: RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
handleBlockchainQueries =
    RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall (effs :: [* -> *]).
(Member (LogObserve (LogMessage Text)) effs,
 Member (LogMsg RequestHandlerLogMsg) effs,
 Member WalletEffect effs) =>
RequestHandler effs PABReq PABResp
RequestHandler.handleUnbalancedTransactions
    RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall a. Semigroup a => a -> a -> a
<> RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall (effs :: [* -> *]).
(Member (LogObserve (LogMessage Text)) effs,
 Member (LogMsg RequestHandlerLogMsg) effs,
 Member WalletEffect effs) =>
RequestHandler effs PABReq PABResp
RequestHandler.handlePendingTransactions
    RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall a. Semigroup a => a -> a -> a
<> RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall (effs :: [* -> *]).
(Member (LogObserve (LogMessage Text)) effs,
 Member ChainIndexQueryEffect effs) =>
RequestHandler effs PABReq PABResp
RequestHandler.handleChainIndexQueries
    RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall a. Semigroup a => a -> a -> a
<> RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall (effs :: [* -> *]).
(Member (LogObserve (LogMessage Text)) effs,
 Member WalletEffect effs) =>
RequestHandler effs PABReq PABResp
RequestHandler.handleOwnAddressesQueries
    RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall a. Semigroup a => a -> a -> a
<> RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall (effs :: [* -> *]).
(Member (LogObserve (LogMessage Text)) effs,
 Member (Reader ContractInstanceId) effs) =>
RequestHandler effs PABReq PABResp
RequestHandler.handleOwnInstanceIdQueries
    RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall a. Semigroup a => a -> a -> a
<> RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall (effs :: [* -> *]).
(Member (LogObserve (LogMessage Text)) effs,
 Member (LogMsg RequestHandlerLogMsg) effs,
 Member NodeClientEffect effs) =>
RequestHandler effs PABReq PABResp
RequestHandler.handleSlotNotifications
    RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall a. Semigroup a => a -> a -> a
<> RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall (effs :: [* -> *]).
(Member (LogObserve (LogMessage Text)) effs,
 Member NodeClientEffect effs) =>
RequestHandler effs PABReq PABResp
RequestHandler.handleCurrentNodeClientSlotQueries
    RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall a. Semigroup a => a -> a -> a
<> RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall (effs :: [* -> *]).
(Member (LogObserve (LogMessage Text)) effs,
 Member ChainIndexQueryEffect effs) =>
RequestHandler effs PABReq PABResp
RequestHandler.handleCurrentChainIndexSlotQueries
    RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall a. Semigroup a => a -> a -> a
<> RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall (effs :: [* -> *]).
(Member (LogObserve (LogMessage Text)) effs,
 Member (LogMsg RequestHandlerLogMsg) effs,
 Member NodeClientEffect effs) =>
RequestHandler effs PABReq PABResp
RequestHandler.handleTimeNotifications
    RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall a. Semigroup a => a -> a -> a
<> RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall (effs :: [* -> *]).
(Member (LogObserve (LogMessage Text)) effs,
 Member NodeClientEffect effs) =>
RequestHandler effs PABReq PABResp
RequestHandler.handleCurrentTimeQueries
    RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall a. Semigroup a => a -> a -> a
<> RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall (effs :: [* -> *]).
(Member (LogObserve (LogMessage Text)) effs,
 Member NodeClientEffect effs) =>
RequestHandler effs PABReq PABResp
RequestHandler.handleCurrentNodeClientTimeRangeQueries
    RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall a. Semigroup a => a -> a -> a
<> RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall (effs :: [* -> *]).
(Member (LogObserve (LogMessage Text)) effs,
 Member NodeClientEffect effs) =>
RequestHandler effs PABReq PABResp
RequestHandler.handleTimeToSlotConversions
    RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall a. Semigroup a => a -> a -> a
<> RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall (effs :: [* -> *]).
(Member (LogObserve (LogMessage Text)) effs,
 Member WalletEffect effs) =>
RequestHandler effs PABReq PABResp
RequestHandler.handleYieldedUnbalancedTx
    RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall a. Semigroup a => a -> a -> a
<> RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall (effs :: [* -> *]).
(Member (LogObserve (LogMessage Text)) effs,
 Member (LogMsg RequestHandlerLogMsg) effs,
 Member NodeClientEffect effs) =>
RequestHandler effs PABReq PABResp
RequestHandler.handleAdjustUnbalancedTx
    RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall a. Semigroup a => a -> a -> a
<> RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall (effs :: [* -> *]).
(Member (LogObserve (LogMessage Text)) effs,
 Member NodeClientEffect effs) =>
RequestHandler effs PABReq PABResp
RequestHandler.handleGetParams

decodeEvent ::
    forall effs.
    ( Member (LogMsg ContractInstanceMsg) effs
    , Member (Error EmulatorRuntimeError) effs
    )
    => JSON.Value
    -> Eff effs PABResp
decodeEvent :: Value -> Eff effs PABResp
decodeEvent Value
vl =
    case Value -> Result PABResp
forall a. FromJSON a => Value -> Result a
JSON.fromJSON @PABResp Value
vl of
            JSON.Error String
e'       -> do
                let msg :: EmulatorRuntimeError
msg = String -> Value -> EmulatorRuntimeError
EmulatorJSONDecodingError String
e' Value
vl
                ContractInstanceMsg -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logError (ContractInstanceMsg -> Eff effs ())
-> ContractInstanceMsg -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ EmulatorRuntimeError -> ContractInstanceMsg
InstErr EmulatorRuntimeError
msg
                EmulatorRuntimeError -> Eff effs PABResp
forall e (effs :: [* -> *]) a.
Member (Error e) effs =>
e -> Eff effs a
throwError EmulatorRuntimeError
msg
            JSON.Success PABResp
event' -> PABResp -> Eff effs PABResp
forall (f :: * -> *) a. Applicative f => a -> f a
pure PABResp
event'

getHooks :: forall w s e effs. Member (State (ContractInstanceStateInternal w s e ())) effs => Eff effs [Request PABReq]
getHooks :: Eff effs [Request PABReq]
getHooks = (ContractInstanceStateInternal w s e () -> [Request PABReq])
-> Eff effs [Request PABReq]
forall s a (effs :: [* -> *]).
Member (State s) effs =>
(s -> a) -> Eff effs a
gets @(ContractInstanceStateInternal w s e ()) (Requests PABReq -> [Request PABReq]
forall o. Requests o -> [Request o]
State.unRequests (Requests PABReq -> [Request PABReq])
-> (ContractInstanceStateInternal w s e () -> Requests PABReq)
-> ContractInstanceStateInternal w s e ()
-> [Request PABReq]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (Requests PABReq)
  (ResumableResult w e PABResp PABReq ())
  (Requests PABReq)
-> ResumableResult w e PABResp PABReq () -> Requests PABReq
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (Requests PABReq)
  (ResumableResult w e PABResp PABReq ())
  (Requests PABReq)
forall w e i o1 a o2.
Lens
  (ResumableResult w e i o1 a)
  (ResumableResult w e i o2 a)
  (Requests o1)
  (Requests o2)
requests (ResumableResult w e PABResp PABReq () -> Requests PABReq)
-> (ContractInstanceStateInternal w s e ()
    -> ResumableResult w e PABResp PABReq ())
-> ContractInstanceStateInternal w s e ()
-> Requests PABReq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (ResumableResult w e PABResp PABReq ())
  (SuspendedContract w e PABResp PABReq ())
  (ResumableResult w e PABResp PABReq ())
-> SuspendedContract w e PABResp PABReq ()
-> ResumableResult w e PABResp PABReq ()
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (ResumableResult w e PABResp PABReq ())
  (SuspendedContract w e PABResp PABReq ())
  (ResumableResult w e PABResp PABReq ())
forall w e i o a.
Lens' (SuspendedContract w e i o a) (ResumableResult w e i o a)
resumableResult (SuspendedContract w e PABResp PABReq ()
 -> ResumableResult w e PABResp PABReq ())
-> (ContractInstanceStateInternal w s e ()
    -> SuspendedContract w e PABResp PABReq ())
-> ContractInstanceStateInternal w s e ()
-> ResumableResult w e PABResp PABReq ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContractInstanceStateInternal w s e ()
-> SuspendedContract w e PABResp PABReq ()
forall w (s :: Row *) e a.
ContractInstanceStateInternal w s e a
-> SuspendedContract w e PABResp PABReq a
cisiSuspState)

-- | Update the contract instance with information from the new block.
processNewTransactions ::
    forall w s e effs.
    ( Member (State (ContractInstanceStateInternal w s e ())) effs
    , Member (LogMsg ContractInstanceMsg) effs
    , Monoid w
    )
    => [OnChainTx]
    -> Eff effs ()
processNewTransactions :: Block -> Eff effs ()
processNewTransactions Block
txns = do
    Block -> Eff effs ()
forall w (s :: Row *) e (effs :: [* -> *]).
(Member (State (ContractInstanceStateInternal w s e ())) effs,
 Member (LogMsg ContractInstanceMsg) effs, Monoid w) =>
Block -> Eff effs ()
updateTxStatus @w @s @e Block
txns

    let ciTxns :: [ChainIndexTx]
ciTxns = (OnChainTx -> ChainIndexTx) -> Block -> [ChainIndexTx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OnChainTx -> ChainIndexTx
fromOnChainTx Block
txns
    [ChainIndexTx] -> Eff effs ()
forall w (s :: Row *) e (effs :: [* -> *]).
(Member (State (ContractInstanceStateInternal w s e ())) effs,
 Member (LogMsg ContractInstanceMsg) effs, Monoid w) =>
[ChainIndexTx] -> Eff effs ()
updateTxOutStatus @w @s @e [ChainIndexTx]
ciTxns

    let blck :: IndexedBlock
blck = [ChainIndexTx] -> IndexedBlock
indexBlock [ChainIndexTx]
ciTxns
    IndexedBlock -> Eff effs ()
forall w (s :: Row *) e (effs :: [* -> *]).
(Member (State (ContractInstanceStateInternal w s e ())) effs,
 Member (LogMsg ContractInstanceMsg) effs, Monoid w) =>
IndexedBlock -> Eff effs ()
updateTxOutSpent @w @s @e IndexedBlock
blck
    IndexedBlock -> Eff effs ()
forall w (s :: Row *) e (effs :: [* -> *]).
(Member (State (ContractInstanceStateInternal w s e ())) effs,
 Member (LogMsg ContractInstanceMsg) effs, Monoid w) =>
IndexedBlock -> Eff effs ()
updateTxOutProduced @w @s @e IndexedBlock
blck

-- | Update the contract instance with transaction status information from the
--   new block.
updateTxStatus ::
    forall w s e effs.
    ( Member (State (ContractInstanceStateInternal w s e ())) effs
    , Member (LogMsg ContractInstanceMsg) effs
    , Monoid w
    )
    => [OnChainTx]
    -> Eff effs ()
updateTxStatus :: Block -> Eff effs ()
updateTxStatus Block
txns = do
    -- Check whether the contract instance is waiting for a status change of any
    -- of the new transactions. If that is the case, call 'addResponse' to send the
    -- response.
    let txWithStatus :: OnChainTx -> (TxId, TxValidity)
txWithStatus OnChainTx
tx = (CardanoTx -> TxId
getCardanoTxId (CardanoTx -> TxId) -> CardanoTx -> TxId
forall a b. (a -> b) -> a -> b
$ OnChainTx -> CardanoTx
unOnChain OnChainTx
tx, if OnChainTx -> Bool
onChainTxIsValid OnChainTx
tx then TxValidity
TxValid else TxValidity
TxInvalid)
        statusMap :: Map TxId TxValidity
statusMap = [(TxId, TxValidity)] -> Map TxId TxValidity
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TxId, TxValidity)] -> Map TxId TxValidity)
-> [(TxId, TxValidity)] -> Map TxId TxValidity
forall a b. (a -> b) -> a -> b
$ (OnChainTx -> (TxId, TxValidity)) -> Block -> [(TxId, TxValidity)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OnChainTx -> (TxId, TxValidity)
txWithStatus Block
txns
    [Request TxId]
hks <- (Request PABReq -> Maybe (Request TxId))
-> [Request PABReq] -> [Request TxId]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((PABReq -> Maybe TxId) -> Request PABReq -> Maybe (Request TxId)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Getting (First TxId) PABReq TxId -> PABReq -> Maybe TxId
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First TxId) PABReq TxId
Prism' PABReq TxId
E._AwaitTxStatusChangeReq)) ([Request PABReq] -> [Request TxId])
-> Eff effs [Request PABReq] -> Eff effs [Request TxId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (effs :: [* -> *]).
Member (State (ContractInstanceStateInternal w s e ())) effs =>
Eff effs [Request PABReq]
forall w (s :: Row *) e (effs :: [* -> *]).
Member (State (ContractInstanceStateInternal w s e ())) effs =>
Eff effs [Request PABReq]
getHooks @w @s @e
    let mpReq :: Request TxId -> Maybe (Response PABResp)
mpReq Request{RequestID
rqID :: RequestID
rqID :: forall o. Request o -> RequestID
rqID, IterationID
itID :: IterationID
itID :: forall o. Request o -> IterationID
itID, rqRequest :: forall o. Request o -> o
rqRequest=TxId
txid} =
            case TxId -> Map TxId TxValidity -> Maybe TxValidity
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxId
txid Map TxId TxValidity
statusMap of
                Maybe TxValidity
Nothing -> Maybe (Response PABResp)
forall a. Maybe a
Nothing
                Just TxValidity
newStatus -> Response PABResp -> Maybe (Response PABResp)
forall a. a -> Maybe a
Just Response :: forall i. RequestID -> IterationID -> i -> Response i
Response{rspRqID :: RequestID
rspRqID=RequestID
rqID, rspItID :: IterationID
rspItID=IterationID
itID, rspResponse :: PABResp
rspResponse=TxId -> TxStatus -> PABResp
AwaitTxStatusChangeResp TxId
txid (TxValidity -> () -> TxStatus
forall a. TxValidity -> a -> RollbackState a
Committed TxValidity
newStatus ())}
        txStatusHk :: Maybe (Response PABResp)
txStatusHk = [Response PABResp] -> Maybe (Response PABResp)
forall a. [a] -> Maybe a
listToMaybe ([Response PABResp] -> Maybe (Response PABResp))
-> [Response PABResp] -> Maybe (Response PABResp)
forall a b. (a -> b) -> a -> b
$ (Request TxId -> Maybe (Response PABResp))
-> [Request TxId] -> [Response PABResp]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Request TxId -> Maybe (Response PABResp)
mpReq [Request TxId]
hks
    (Response PABResp -> Eff effs ())
-> Maybe (Response PABResp) -> Eff effs ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (effs :: [* -> *]).
(Member (State (ContractInstanceStateInternal w s e ())) effs,
 Member (LogMsg ContractInstanceMsg) effs, Monoid w) =>
Response PABResp -> Eff effs ()
forall w (s :: Row *) e (effs :: [* -> *]).
(Member (State (ContractInstanceStateInternal w s e ())) effs,
 Member (LogMsg ContractInstanceMsg) effs, Monoid w) =>
Response PABResp -> Eff effs ()
addResponse @w @s @e) Maybe (Response PABResp)
txStatusHk
    Bool -> Maybe (Response PABResp) -> Eff effs ()
forall w (s :: Row *) e (effs :: [* -> *]).
(Member (LogMsg ContractInstanceMsg) effs,
 Member (State (ContractInstanceStateInternal w s e ())) effs) =>
Bool -> Maybe (Response PABResp) -> Eff effs ()
logResponse @w @s @e Bool
False Maybe (Response PABResp)
txStatusHk

-- | Update the contract instance with transaction outputs status information
-- from the new block.
--
-- Currently, all tx outputs of a block will either go to the state
-- 'TxOutConfirmedUnspent' or 'TxOutConfirmedSpent' (we don't currently
-- represent the @TentativelyConfirmed@ state in the emulator.
updateTxOutStatus ::
    forall w s e effs.
    ( Member (State (ContractInstanceStateInternal w s e ())) effs
    , Member (LogMsg ContractInstanceMsg) effs
    , Monoid w
    )
    => [ChainIndexTx] -- ^ Block of transactions
    -> Eff effs ()
updateTxOutStatus :: [ChainIndexTx] -> Eff effs ()
updateTxOutStatus [ChainIndexTx]
txns = do
    -- Check whether the contract instance is waiting for a status change of a
    -- transaction output of any of the new transactions. If that is the case,
    -- call 'addResponse' to sent the response.
    let getSpentOutputs :: ChainIndexTx -> [TxOutRef]
getSpentOutputs = Getting [TxOutRef] ChainIndexTx [TxOutRef]
-> ChainIndexTx -> [TxOutRef]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [TxOutRef] ChainIndexTx [TxOutRef]
Lens' ChainIndexTx [TxOutRef]
citxInputs
        txWithTxOutStatus :: ChainIndexTx -> [(TxOutRef, RollbackState TxOutState)]
txWithTxOutStatus ChainIndexTx
tx = let validity :: TxValidity
validity = ChainIndexTx -> TxValidity
validityFromChainIndex ChainIndexTx
tx in
             (TxOutRef -> (TxOutRef, RollbackState TxOutState))
-> [TxOutRef] -> [(TxOutRef, RollbackState TxOutState)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, TxValidity -> TxOutState -> RollbackState TxOutState
forall a. TxValidity -> a -> RollbackState a
Committed TxValidity
validity (TxId -> TxOutState
Spent (ChainIndexTx -> TxId
_citxTxId ChainIndexTx
tx))) (ChainIndexTx -> [TxOutRef]
getSpentOutputs ChainIndexTx
tx)
          [(TxOutRef, RollbackState TxOutState)]
-> [(TxOutRef, RollbackState TxOutState)]
-> [(TxOutRef, RollbackState TxOutState)]
forall a. Semigroup a => a -> a -> a
<> (TxOutRef -> (TxOutRef, RollbackState TxOutState))
-> [TxOutRef] -> [(TxOutRef, RollbackState TxOutState)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, TxValidity -> TxOutState -> RollbackState TxOutState
forall a. TxValidity -> a -> RollbackState a
Committed TxValidity
validity TxOutState
Unspent) (ChainIndexTx -> [TxOutRef]
txOutRefs ChainIndexTx
tx)
        statusMap :: Map TxOutRef (RollbackState TxOutState)
statusMap = [(TxOutRef, RollbackState TxOutState)]
-> Map TxOutRef (RollbackState TxOutState)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TxOutRef, RollbackState TxOutState)]
 -> Map TxOutRef (RollbackState TxOutState))
-> [(TxOutRef, RollbackState TxOutState)]
-> Map TxOutRef (RollbackState TxOutState)
forall a b. (a -> b) -> a -> b
$ (ChainIndexTx -> [(TxOutRef, RollbackState TxOutState)])
-> [ChainIndexTx] -> [(TxOutRef, RollbackState TxOutState)]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ChainIndexTx -> [(TxOutRef, RollbackState TxOutState)]
txWithTxOutStatus [ChainIndexTx]
txns
    [Request TxIn]
hks <- (Request PABReq -> Maybe (Request TxIn))
-> [Request PABReq] -> [Request TxIn]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((PABReq -> Maybe TxIn) -> Request PABReq -> Maybe (Request TxIn)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Getting (First TxIn) PABReq TxIn -> PABReq -> Maybe TxIn
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First TxIn) PABReq TxIn
Prism' PABReq TxIn
E._AwaitTxOutStatusChangeReq)) ([Request PABReq] -> [Request TxIn])
-> Eff effs [Request PABReq] -> Eff effs [Request TxIn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (effs :: [* -> *]).
Member (State (ContractInstanceStateInternal w s e ())) effs =>
Eff effs [Request PABReq]
forall w (s :: Row *) e (effs :: [* -> *]).
Member (State (ContractInstanceStateInternal w s e ())) effs =>
Eff effs [Request PABReq]
getHooks @w @s @e
    let mpReq :: Request TxIn -> Maybe (Response PABResp)
mpReq Request{RequestID
rqID :: RequestID
rqID :: forall o. Request o -> RequestID
rqID, IterationID
itID :: IterationID
itID :: forall o. Request o -> IterationID
itID, rqRequest :: forall o. Request o -> o
rqRequest=TxIn
txOutRef} =
            case TxOutRef
-> Map TxOutRef (RollbackState TxOutState)
-> Maybe (RollbackState TxOutState)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (TxIn -> TxOutRef
fromCardanoTxIn TxIn
txOutRef) Map TxOutRef (RollbackState TxOutState)
statusMap of
                Maybe (RollbackState TxOutState)
Nothing        -> Maybe (Response PABResp)
forall a. Maybe a
Nothing
                Just RollbackState TxOutState
newStatus ->
                    Response PABResp -> Maybe (Response PABResp)
forall a. a -> Maybe a
Just Response :: forall i. RequestID -> IterationID -> i -> Response i
Response { rspRqID :: RequestID
rspRqID=RequestID
rqID
                                  , rspItID :: IterationID
rspItID=IterationID
itID
                                  , rspResponse :: PABResp
rspResponse=TxIn -> RollbackState TxOutState -> PABResp
E.AwaitTxOutStatusChangeResp TxIn
txOutRef RollbackState TxOutState
newStatus
                                  }
        utxoResp :: Maybe (Response PABResp)
utxoResp = [Response PABResp] -> Maybe (Response PABResp)
forall a. [a] -> Maybe a
listToMaybe ([Response PABResp] -> Maybe (Response PABResp))
-> [Response PABResp] -> Maybe (Response PABResp)
forall a b. (a -> b) -> a -> b
$ (Request TxIn -> Maybe (Response PABResp))
-> [Request TxIn] -> [Response PABResp]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Request TxIn -> Maybe (Response PABResp)
mpReq [Request TxIn]
hks
    (Response PABResp -> Eff effs ())
-> Maybe (Response PABResp) -> Eff effs ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (effs :: [* -> *]).
(Member (State (ContractInstanceStateInternal w s e ())) effs,
 Member (LogMsg ContractInstanceMsg) effs, Monoid w) =>
Response PABResp -> Eff effs ()
forall w (s :: Row *) e (effs :: [* -> *]).
(Member (State (ContractInstanceStateInternal w s e ())) effs,
 Member (LogMsg ContractInstanceMsg) effs, Monoid w) =>
Response PABResp -> Eff effs ()
addResponse @w @s @e) Maybe (Response PABResp)
utxoResp
    Bool -> Maybe (Response PABResp) -> Eff effs ()
forall w (s :: Row *) e (effs :: [* -> *]).
(Member (LogMsg ContractInstanceMsg) effs,
 Member (State (ContractInstanceStateInternal w s e ())) effs) =>
Bool -> Maybe (Response PABResp) -> Eff effs ()
logResponse @w @s @e Bool
False Maybe (Response PABResp)
utxoResp

-- | Update the contract instance with transaction output information from the
--   new block.
updateTxOutProduced ::
    forall w s e effs.
    ( Member (State (ContractInstanceStateInternal w s e ())) effs
    , Member (LogMsg ContractInstanceMsg) effs
    , Monoid w
    )
    => IndexedBlock
    -> Eff effs ()
updateTxOutProduced :: IndexedBlock -> Eff effs ()
updateTxOutProduced IndexedBlock{Map CardanoAddress (NonEmpty ChainIndexTx)
ibUtxoProduced :: IndexedBlock -> Map CardanoAddress (NonEmpty ChainIndexTx)
ibUtxoProduced :: Map CardanoAddress (NonEmpty ChainIndexTx)
ibUtxoProduced} = do
    -- Check whether the contract instance is waiting for address changes
    [Request CardanoAddress]
hks <- (Request PABReq -> Maybe (Request CardanoAddress))
-> [Request PABReq] -> [Request CardanoAddress]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((PABReq -> Maybe CardanoAddress)
-> Request PABReq -> Maybe (Request CardanoAddress)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Getting (First CardanoAddress) PABReq CardanoAddress
-> PABReq -> Maybe CardanoAddress
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First CardanoAddress) PABReq CardanoAddress
Prism' PABReq CardanoAddress
E._AwaitUtxoProducedReq)) ([Request PABReq] -> [Request CardanoAddress])
-> Eff effs [Request PABReq] -> Eff effs [Request CardanoAddress]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (effs :: [* -> *]).
Member (State (ContractInstanceStateInternal w s e ())) effs =>
Eff effs [Request PABReq]
forall w (s :: Row *) e (effs :: [* -> *]).
Member (State (ContractInstanceStateInternal w s e ())) effs =>
Eff effs [Request PABReq]
getHooks @w @s @e
    let mpReq :: Request CardanoAddress -> Maybe (Response PABResp)
mpReq Request{RequestID
rqID :: RequestID
rqID :: forall o. Request o -> RequestID
rqID, IterationID
itID :: IterationID
itID :: forall o. Request o -> IterationID
itID, rqRequest :: forall o. Request o -> o
rqRequest=CardanoAddress
addr} =
            case CardanoAddress
-> Map CardanoAddress (NonEmpty ChainIndexTx)
-> Maybe (NonEmpty ChainIndexTx)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CardanoAddress
addr Map CardanoAddress (NonEmpty ChainIndexTx)
ibUtxoProduced of
                Maybe (NonEmpty ChainIndexTx)
Nothing      -> Maybe (Response PABResp)
forall a. Maybe a
Nothing
                Just NonEmpty ChainIndexTx
newTxns -> Response PABResp -> Maybe (Response PABResp)
forall a. a -> Maybe a
Just Response :: forall i. RequestID -> IterationID -> i -> Response i
Response{rspRqID :: RequestID
rspRqID=RequestID
rqID, rspItID :: IterationID
rspItID=IterationID
itID, rspResponse :: PABResp
rspResponse=NonEmpty ChainIndexTx -> PABResp
E.AwaitUtxoProducedResp NonEmpty ChainIndexTx
newTxns}
        utxoResp :: Maybe (Response PABResp)
utxoResp = [Response PABResp] -> Maybe (Response PABResp)
forall a. [a] -> Maybe a
listToMaybe ([Response PABResp] -> Maybe (Response PABResp))
-> [Response PABResp] -> Maybe (Response PABResp)
forall a b. (a -> b) -> a -> b
$ (Request CardanoAddress -> Maybe (Response PABResp))
-> [Request CardanoAddress] -> [Response PABResp]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Request CardanoAddress -> Maybe (Response PABResp)
mpReq [Request CardanoAddress]
hks
    (Response PABResp -> Eff effs ())
-> Maybe (Response PABResp) -> Eff effs ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (effs :: [* -> *]).
(Member (State (ContractInstanceStateInternal w s e ())) effs,
 Member (LogMsg ContractInstanceMsg) effs, Monoid w) =>
Response PABResp -> Eff effs ()
forall w (s :: Row *) e (effs :: [* -> *]).
(Member (State (ContractInstanceStateInternal w s e ())) effs,
 Member (LogMsg ContractInstanceMsg) effs, Monoid w) =>
Response PABResp -> Eff effs ()
addResponse @w @s @e) Maybe (Response PABResp)
utxoResp
    Bool -> Maybe (Response PABResp) -> Eff effs ()
forall w (s :: Row *) e (effs :: [* -> *]).
(Member (LogMsg ContractInstanceMsg) effs,
 Member (State (ContractInstanceStateInternal w s e ())) effs) =>
Bool -> Maybe (Response PABResp) -> Eff effs ()
logResponse @w @s @e Bool
False Maybe (Response PABResp)
utxoResp

-- | Update the contract instance with transaction input information from the
--   new block.
updateTxOutSpent ::
    forall w s e effs.
    ( Member (State (ContractInstanceStateInternal w s e ())) effs
    , Member (LogMsg ContractInstanceMsg) effs
    , Monoid w
    )
    => IndexedBlock
    -> Eff effs ()
updateTxOutSpent :: IndexedBlock -> Eff effs ()
updateTxOutSpent IndexedBlock{Map TxIn ChainIndexTx
ibUtxoSpent :: IndexedBlock -> Map TxIn ChainIndexTx
ibUtxoSpent :: Map TxIn ChainIndexTx
ibUtxoSpent} = do
    -- Check whether the contract instance is waiting for address changes
    [Request TxIn]
hks <- (Request PABReq -> Maybe (Request TxIn))
-> [Request PABReq] -> [Request TxIn]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((PABReq -> Maybe TxIn) -> Request PABReq -> Maybe (Request TxIn)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Getting (First TxIn) PABReq TxIn -> PABReq -> Maybe TxIn
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First TxIn) PABReq TxIn
Prism' PABReq TxIn
E._AwaitUtxoSpentReq)) ([Request PABReq] -> [Request TxIn])
-> Eff effs [Request PABReq] -> Eff effs [Request TxIn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (effs :: [* -> *]).
Member (State (ContractInstanceStateInternal w s e ())) effs =>
Eff effs [Request PABReq]
forall w (s :: Row *) e (effs :: [* -> *]).
Member (State (ContractInstanceStateInternal w s e ())) effs =>
Eff effs [Request PABReq]
getHooks @w @s @e
    let mpReq :: Request TxIn -> Maybe (Response PABResp)
mpReq Request{RequestID
rqID :: RequestID
rqID :: forall o. Request o -> RequestID
rqID, IterationID
itID :: IterationID
itID :: forall o. Request o -> IterationID
itID, rqRequest :: forall o. Request o -> o
rqRequest=TxIn
addr} =
            case TxIn -> Map TxIn ChainIndexTx -> Maybe ChainIndexTx
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn
addr Map TxIn ChainIndexTx
ibUtxoSpent of
                Maybe ChainIndexTx
Nothing      -> Maybe (Response PABResp)
forall a. Maybe a
Nothing
                Just ChainIndexTx
newTxns -> Response PABResp -> Maybe (Response PABResp)
forall a. a -> Maybe a
Just Response :: forall i. RequestID -> IterationID -> i -> Response i
Response{rspRqID :: RequestID
rspRqID=RequestID
rqID, rspItID :: IterationID
rspItID=IterationID
itID, rspResponse :: PABResp
rspResponse=ChainIndexTx -> PABResp
E.AwaitUtxoSpentResp ChainIndexTx
newTxns}
        utxoResp :: Maybe (Response PABResp)
utxoResp = [Response PABResp] -> Maybe (Response PABResp)
forall a. [a] -> Maybe a
listToMaybe ([Response PABResp] -> Maybe (Response PABResp))
-> [Response PABResp] -> Maybe (Response PABResp)
forall a b. (a -> b) -> a -> b
$ (Request TxIn -> Maybe (Response PABResp))
-> [Request TxIn] -> [Response PABResp]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Request TxIn -> Maybe (Response PABResp)
mpReq [Request TxIn]
hks
    (Response PABResp -> Eff effs ())
-> Maybe (Response PABResp) -> Eff effs ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (effs :: [* -> *]).
(Member (State (ContractInstanceStateInternal w s e ())) effs,
 Member (LogMsg ContractInstanceMsg) effs, Monoid w) =>
Response PABResp -> Eff effs ()
forall w (s :: Row *) e (effs :: [* -> *]).
(Member (State (ContractInstanceStateInternal w s e ())) effs,
 Member (LogMsg ContractInstanceMsg) effs, Monoid w) =>
Response PABResp -> Eff effs ()
addResponse @w @s @e) Maybe (Response PABResp)
utxoResp
    Bool -> Maybe (Response PABResp) -> Eff effs ()
forall w (s :: Row *) e (effs :: [* -> *]).
(Member (LogMsg ContractInstanceMsg) effs,
 Member (State (ContractInstanceStateInternal w s e ())) effs) =>
Bool -> Maybe (Response PABResp) -> Eff effs ()
logResponse @w @s @e Bool
False Maybe (Response PABResp)
utxoResp

-- | Add a 'Response' to the contract instance state
addResponse
    :: forall w s e effs.
    ( Member (State (ContractInstanceStateInternal w s e ())) effs
    , Member (LogMsg ContractInstanceMsg) effs
    , Monoid w
    )
    => Response PABResp
    -> Eff effs ()
addResponse :: Response PABResp -> Eff effs ()
addResponse Response PABResp
e = do
    ContractInstanceStateInternal w s e ()
oldState <- forall (effs :: [* -> *]).
Member (State (ContractInstanceStateInternal w s e ())) effs =>
Eff effs (ContractInstanceStateInternal w s e ())
forall s (effs :: [* -> *]). Member (State s) effs => Eff effs s
get @(ContractInstanceStateInternal w s e ())
    let newState :: Maybe (ContractInstanceStateInternal w s e ())
newState = Response PABResp
-> ContractInstanceStateInternal w s e ()
-> Maybe (ContractInstanceStateInternal w s e ())
forall w (s :: Row *) e a.
Monoid w =>
Response PABResp
-> ContractInstanceStateInternal w s e a
-> Maybe (ContractInstanceStateInternal w s e a)
addEventInstanceState Response PABResp
e ContractInstanceStateInternal w s e ()
oldState
    (ContractInstanceStateInternal w s e () -> Eff effs ())
-> Maybe (ContractInstanceStateInternal w s e ()) -> Eff effs ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ContractInstanceStateInternal w s e () -> Eff effs ()
forall s (effs :: [* -> *]).
Member (State s) effs =>
s -> Eff effs ()
put Maybe (ContractInstanceStateInternal w s e ())
newState
    forall (effs :: [* -> *]).
(Member (LogMsg ContractInstanceMsg) effs,
 Member (State (ContractInstanceStateInternal w s e ())) effs) =>
Eff effs ()
forall w (s :: Row *) e (effs :: [* -> *]).
(Member (LogMsg ContractInstanceMsg) effs,
 Member (State (ContractInstanceStateInternal w s e ())) effs) =>
Eff effs ()
logNewMessages @w @s @e

type ContractInstanceRequests effs =
        Reader ContractInstanceId
         ': EmulatedWalletEffects' effs

-- | Respond to a specific event
respondToEvent ::
    forall w s e effs.
    ( Member (State (ContractInstanceStateInternal w s e ())) effs
    , Members EmulatedWalletEffects effs
    , Member (Reader ContractInstanceId) effs
    , Member (LogMsg ContractInstanceMsg) effs
    , Monoid w
    )
    => PABResp
    -> Eff effs (Maybe (Response PABResp))
respondToEvent :: PABResp -> Eff effs (Maybe (Response PABResp))
respondToEvent PABResp
e = Bool
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> Eff effs (Maybe (Response PABResp))
forall w (s :: Row *) e (effs :: [* -> *]).
(Member (State (ContractInstanceStateInternal w s e ())) effs,
 Member (Reader ContractInstanceId) effs,
 Member (LogMsg ContractInstanceMsg) effs,
 Members EmulatedWalletEffects effs, Monoid w) =>
Bool
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> Eff effs (Maybe (Response PABResp))
respondToRequest @w @s @e Bool
True (RequestHandler
   (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
 -> Eff effs (Maybe (Response PABResp)))
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> Eff effs (Maybe (Response PABResp))
forall a b. (a -> b) -> a -> b
$ (PABReq
 -> Eff
      (NonDet : Reader ContractInstanceId : EmulatedWalletEffects)
      PABResp)
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall (effs :: [* -> *]) req resp.
(req -> Eff (NonDet : effs) resp) -> RequestHandler effs req resp
RequestHandler ((PABReq
  -> Eff
       (NonDet : Reader ContractInstanceId : EmulatedWalletEffects)
       PABResp)
 -> RequestHandler
      (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp)
-> (PABReq
    -> Eff
         (NonDet : Reader ContractInstanceId : EmulatedWalletEffects)
         PABResp)
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
forall a b. (a -> b) -> a -> b
$ \PABReq
h -> do
    Bool
-> Eff
     (NonDet : Reader ContractInstanceId : EmulatedWalletEffects) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool
 -> Eff
      (NonDet : Reader ContractInstanceId : EmulatedWalletEffects) ())
-> Bool
-> Eff
     (NonDet : Reader ContractInstanceId : EmulatedWalletEffects) ()
forall a b. (a -> b) -> a -> b
$ PABReq
h PABReq -> PABResp -> Bool
`matches` PABResp
e
    PABResp
-> Eff
     (NonDet : Reader ContractInstanceId : EmulatedWalletEffects)
     PABResp
forall (f :: * -> *) a. Applicative f => a -> f a
pure PABResp
e

-- | Inspect the open requests of a contract instance,
--   and maybe respond to them. Returns the response that was provided to the
--   contract, if any.
respondToRequest :: forall w s e effs.
    ( Member (State (ContractInstanceStateInternal w s e ())) effs
    , Member (Reader ContractInstanceId) effs
    , Member (LogMsg ContractInstanceMsg) effs
    , Members EmulatedWalletEffects effs
    , Monoid w
    )
    => Bool -- ^ Flag on whether to log 'NoRequestsHandled' messages.
    -> RequestHandler (Reader ContractInstanceId ': EmulatedWalletEffects) PABReq PABResp
    -- ^ How to respond to the requests.
    -> Eff effs (Maybe (Response PABResp))
respondToRequest :: Bool
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> Eff effs (Maybe (Response PABResp))
respondToRequest Bool
isLogShowed RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
f = do
    [Request PABReq]
hks <- forall (effs :: [* -> *]).
Member (State (ContractInstanceStateInternal w s e ())) effs =>
Eff effs [Request PABReq]
forall w (s :: Row *) e (effs :: [* -> *]).
Member (State (ContractInstanceStateInternal w s e ())) effs =>
Eff effs [Request PABReq]
getHooks @w @s @e
    let Eff
  (Reader ContractInstanceId : EmulatedWalletEffects)
  (Maybe (Response PABResp))
hdl :: (Eff (Reader ContractInstanceId ': EmulatedWalletEffects) (Maybe (Response PABResp))) = RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects)
  (Request PABReq)
  (Response PABResp)
-> [Request PABReq]
-> Eff
     (Reader ContractInstanceId : EmulatedWalletEffects)
     (Maybe (Response PABResp))
forall (effs :: [* -> *]) req resp.
RequestHandler effs req resp -> [req] -> Eff effs (Maybe resp)
tryHandler (RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
-> RequestHandler
     (Reader ContractInstanceId : EmulatedWalletEffects)
     (Request PABReq)
     (Response PABResp)
forall (effs :: [* -> *]) req resp.
RequestHandler effs req resp
-> RequestHandler effs (Request req) (Response resp)
wrapHandler RequestHandler
  (Reader ContractInstanceId : EmulatedWalletEffects) PABReq PABResp
f) [Request PABReq]
hks
        Eff (ContractInstanceRequests effs) (Maybe (Response PABResp))
hdl' :: (Eff (ContractInstanceRequests effs) (Maybe (Response PABResp))) = Eff
  (Reader ContractInstanceId : EmulatedWalletEffects)
  (Maybe (Response PABResp))
-> Eff (ContractInstanceRequests effs) (Maybe (Response PABResp))
forall (effs :: [* -> *]) (as :: [* -> *]).
CanWeakenEnd as effs =>
Eff as ~> Eff effs
raiseEnd Eff
  (Reader ContractInstanceId : EmulatedWalletEffects)
  (Maybe (Response PABResp))
hdl

        Eff effs (Maybe (Response PABResp))
response_ :: Eff effs (Maybe (Response PABResp)) =
            forall (effs :: [* -> *]).
Member (LogMsg Text) effs =>
Eff (LogMsg Text : effs) ~> Eff effs
forall (eff :: * -> *) (effs :: [* -> *]).
Member eff effs =>
Eff (eff : effs) ~> Eff effs
subsume @(LogMsg T.Text)
                    (Eff (LogMsg Text : effs) (Maybe (Response PABResp))
 -> Eff effs (Maybe (Response PABResp)))
-> Eff (LogMsg Text : effs) (Maybe (Response PABResp))
-> Eff effs (Maybe (Response PABResp))
forall a b. (a -> b) -> a -> b
$ forall (effs :: [* -> *]).
Member (LogMsg TxBalanceMsg) effs =>
Eff (LogMsg TxBalanceMsg : effs) ~> Eff effs
forall (eff :: * -> *) (effs :: [* -> *]).
Member eff effs =>
Eff (eff : effs) ~> Eff effs
subsume @(LogMsg TxBalanceMsg)
                    (Eff
   (LogMsg TxBalanceMsg : LogMsg Text : effs)
   (Maybe (Response PABResp))
 -> Eff (LogMsg Text : effs) (Maybe (Response PABResp)))
-> Eff
     (LogMsg TxBalanceMsg : LogMsg Text : effs)
     (Maybe (Response PABResp))
-> Eff (LogMsg Text : effs) (Maybe (Response PABResp))
forall a b. (a -> b) -> a -> b
$ forall (effs :: [* -> *]).
Member (LogMsg RequestHandlerLogMsg) effs =>
Eff (LogMsg RequestHandlerLogMsg : effs) ~> Eff effs
forall (eff :: * -> *) (effs :: [* -> *]).
Member eff effs =>
Eff (eff : effs) ~> Eff effs
subsume @(LogMsg RequestHandlerLogMsg)
                    (Eff
   (LogMsg RequestHandlerLogMsg
      : LogMsg TxBalanceMsg : LogMsg Text : effs)
   (Maybe (Response PABResp))
 -> Eff
      (LogMsg TxBalanceMsg : LogMsg Text : effs)
      (Maybe (Response PABResp)))
-> Eff
     (LogMsg RequestHandlerLogMsg
        : LogMsg TxBalanceMsg : LogMsg Text : effs)
     (Maybe (Response PABResp))
-> Eff
     (LogMsg TxBalanceMsg : LogMsg Text : effs)
     (Maybe (Response PABResp))
forall a b. (a -> b) -> a -> b
$ forall (effs :: [* -> *]).
Member (LogObserve (LogMessage Text)) effs =>
Eff (LogObserve (LogMessage Text) : effs) ~> Eff effs
forall (eff :: * -> *) (effs :: [* -> *]).
Member eff effs =>
Eff (eff : effs) ~> Eff effs
subsume @(LogObserve (LogMessage T.Text))
                    (Eff
   (LogObserve (LogMessage Text)
      : LogMsg RequestHandlerLogMsg : LogMsg TxBalanceMsg : LogMsg Text
      : effs)
   (Maybe (Response PABResp))
 -> Eff
      (LogMsg RequestHandlerLogMsg
         : LogMsg TxBalanceMsg : LogMsg Text : effs)
      (Maybe (Response PABResp)))
-> Eff
     (LogObserve (LogMessage Text)
        : LogMsg RequestHandlerLogMsg : LogMsg TxBalanceMsg : LogMsg Text
        : effs)
     (Maybe (Response PABResp))
-> Eff
     (LogMsg RequestHandlerLogMsg
        : LogMsg TxBalanceMsg : LogMsg Text : effs)
     (Maybe (Response PABResp))
forall a b. (a -> b) -> a -> b
$ forall (effs :: [* -> *]).
Member ChainIndexQueryEffect effs =>
Eff (ChainIndexQueryEffect : effs) ~> Eff effs
forall (eff :: * -> *) (effs :: [* -> *]).
Member eff effs =>
Eff (eff : effs) ~> Eff effs
subsume @ChainIndexQueryEffect
                    (Eff
   (ChainIndexQueryEffect
      : LogObserve (LogMessage Text) : LogMsg RequestHandlerLogMsg
      : LogMsg TxBalanceMsg : LogMsg Text : effs)
   (Maybe (Response PABResp))
 -> Eff
      (LogObserve (LogMessage Text)
         : LogMsg RequestHandlerLogMsg : LogMsg TxBalanceMsg : LogMsg Text
         : effs)
      (Maybe (Response PABResp)))
-> Eff
     (ChainIndexQueryEffect
        : LogObserve (LogMessage Text) : LogMsg RequestHandlerLogMsg
        : LogMsg TxBalanceMsg : LogMsg Text : effs)
     (Maybe (Response PABResp))
-> Eff
     (LogObserve (LogMessage Text)
        : LogMsg RequestHandlerLogMsg : LogMsg TxBalanceMsg : LogMsg Text
        : effs)
     (Maybe (Response PABResp))
forall a b. (a -> b) -> a -> b
$ forall (effs :: [* -> *]).
Member NodeClientEffect effs =>
Eff (NodeClientEffect : effs) ~> Eff effs
forall (eff :: * -> *) (effs :: [* -> *]).
Member eff effs =>
Eff (eff : effs) ~> Eff effs
subsume @NodeClientEffect
                    (Eff
   (NodeClientEffect
      : ChainIndexQueryEffect : LogObserve (LogMessage Text)
      : LogMsg RequestHandlerLogMsg : LogMsg TxBalanceMsg : LogMsg Text
      : effs)
   (Maybe (Response PABResp))
 -> Eff
      (ChainIndexQueryEffect
         : LogObserve (LogMessage Text) : LogMsg RequestHandlerLogMsg
         : LogMsg TxBalanceMsg : LogMsg Text : effs)
      (Maybe (Response PABResp)))
-> Eff
     (NodeClientEffect
        : ChainIndexQueryEffect : LogObserve (LogMessage Text)
        : LogMsg RequestHandlerLogMsg : LogMsg TxBalanceMsg : LogMsg Text
        : effs)
     (Maybe (Response PABResp))
-> Eff
     (ChainIndexQueryEffect
        : LogObserve (LogMessage Text) : LogMsg RequestHandlerLogMsg
        : LogMsg TxBalanceMsg : LogMsg Text : effs)
     (Maybe (Response PABResp))
forall a b. (a -> b) -> a -> b
$ forall (effs :: [* -> *]).
Member (Error WalletAPIError) effs =>
Eff (Error WalletAPIError : effs) ~> Eff effs
forall (eff :: * -> *) (effs :: [* -> *]).
Member eff effs =>
Eff (eff : effs) ~> Eff effs
subsume @(Error WAPI.WalletAPIError)
                    (Eff
   (Error WalletAPIError
      : NodeClientEffect : ChainIndexQueryEffect
      : LogObserve (LogMessage Text) : LogMsg RequestHandlerLogMsg
      : LogMsg TxBalanceMsg : LogMsg Text : effs)
   (Maybe (Response PABResp))
 -> Eff
      (NodeClientEffect
         : ChainIndexQueryEffect : LogObserve (LogMessage Text)
         : LogMsg RequestHandlerLogMsg : LogMsg TxBalanceMsg : LogMsg Text
         : effs)
      (Maybe (Response PABResp)))
-> Eff
     (Error WalletAPIError
        : NodeClientEffect : ChainIndexQueryEffect
        : LogObserve (LogMessage Text) : LogMsg RequestHandlerLogMsg
        : LogMsg TxBalanceMsg : LogMsg Text : effs)
     (Maybe (Response PABResp))
-> Eff
     (NodeClientEffect
        : ChainIndexQueryEffect : LogObserve (LogMessage Text)
        : LogMsg RequestHandlerLogMsg : LogMsg TxBalanceMsg : LogMsg Text
        : effs)
     (Maybe (Response PABResp))
forall a b. (a -> b) -> a -> b
$ forall (effs :: [* -> *]).
Member WalletEffect effs =>
Eff (WalletEffect : effs) ~> Eff effs
forall (eff :: * -> *) (effs :: [* -> *]).
Member eff effs =>
Eff (eff : effs) ~> Eff effs
subsume @WalletEffect
                    (Eff
   (WalletEffect
      : Error WalletAPIError : NodeClientEffect : ChainIndexQueryEffect
      : LogObserve (LogMessage Text) : LogMsg RequestHandlerLogMsg
      : LogMsg TxBalanceMsg : LogMsg Text : effs)
   (Maybe (Response PABResp))
 -> Eff
      (Error WalletAPIError
         : NodeClientEffect : ChainIndexQueryEffect
         : LogObserve (LogMessage Text) : LogMsg RequestHandlerLogMsg
         : LogMsg TxBalanceMsg : LogMsg Text : effs)
      (Maybe (Response PABResp)))
-> Eff
     (WalletEffect
        : Error WalletAPIError : NodeClientEffect : ChainIndexQueryEffect
        : LogObserve (LogMessage Text) : LogMsg RequestHandlerLogMsg
        : LogMsg TxBalanceMsg : LogMsg Text : effs)
     (Maybe (Response PABResp))
-> Eff
     (Error WalletAPIError
        : NodeClientEffect : ChainIndexQueryEffect
        : LogObserve (LogMessage Text) : LogMsg RequestHandlerLogMsg
        : LogMsg TxBalanceMsg : LogMsg Text : effs)
     (Maybe (Response PABResp))
forall a b. (a -> b) -> a -> b
$ Eff (ContractInstanceRequests effs) (Maybe (Response PABResp))
-> Eff
     (WalletEffect
        : Error WalletAPIError : NodeClientEffect : ChainIndexQueryEffect
        : LogObserve (LogMessage Text) : LogMsg RequestHandlerLogMsg
        : LogMsg TxBalanceMsg : LogMsg Text : effs)
     (Maybe (Response PABResp))
forall (eff :: * -> *) (effs :: [* -> *]).
Member eff effs =>
Eff (eff : effs) ~> Eff effs
subsume @(Reader ContractInstanceId) Eff (ContractInstanceRequests effs) (Maybe (Response PABResp))
hdl'
    Maybe (Response PABResp)
response <- Eff effs (Maybe (Response PABResp))
response_
    (Response PABResp -> Eff effs ())
-> Maybe (Response PABResp) -> Eff effs ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (effs :: [* -> *]).
(Member (State (ContractInstanceStateInternal w s e ())) effs,
 Member (LogMsg ContractInstanceMsg) effs, Monoid w) =>
Response PABResp -> Eff effs ()
forall w (s :: Row *) e (effs :: [* -> *]).
(Member (State (ContractInstanceStateInternal w s e ())) effs,
 Member (LogMsg ContractInstanceMsg) effs, Monoid w) =>
Response PABResp -> Eff effs ()
addResponse @w @s @e) Maybe (Response PABResp)
response
    Bool -> Maybe (Response PABResp) -> Eff effs ()
forall w (s :: Row *) e (effs :: [* -> *]).
(Member (LogMsg ContractInstanceMsg) effs,
 Member (State (ContractInstanceStateInternal w s e ())) effs) =>
Bool -> Maybe (Response PABResp) -> Eff effs ()
logResponse @w @s @e Bool
isLogShowed Maybe (Response PABResp)
response
    Maybe (Response PABResp) -> Eff effs (Maybe (Response PABResp))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Response PABResp)
response

---
-- Logging
---

logResponse ::  forall w s e effs.
    ( Member (LogMsg ContractInstanceMsg) effs
    , Member (State (ContractInstanceStateInternal w s e ())) effs
    )
    => Bool -- ^ Flag on whether to log 'NoRequestsHandled' messages
    -> Maybe (Response PABResp)
    -> Eff effs ()
logResponse :: Bool -> Maybe (Response PABResp) -> Eff effs ()
logResponse Bool
isLogShowed = \case
    Maybe (Response PABResp)
Nothing -> Bool -> Eff effs () -> Eff effs ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isLogShowed (Eff effs () -> Eff effs ()) -> Eff effs () -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ ContractInstanceMsg -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logDebug ContractInstanceMsg
NoRequestsHandled
    Just Response PABResp
rsp -> do
        ContractInstanceMsg -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logDebug (ContractInstanceMsg -> Eff effs ())
-> ContractInstanceMsg -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ Response Value -> ContractInstanceMsg
HandledRequest (Response Value -> ContractInstanceMsg)
-> Response Value -> ContractInstanceMsg
forall a b. (a -> b) -> a -> b
$ (PABResp -> Value) -> Response PABResp -> Response Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PABResp -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON Response PABResp
rsp
        forall (effs :: [* -> *]).
(Member (State (ContractInstanceStateInternal w s e ())) effs,
 Member (LogMsg ContractInstanceMsg) effs) =>
Eff effs ()
forall w (s :: Row *) e (effs :: [* -> *]).
(Member (State (ContractInstanceStateInternal w s e ())) effs,
 Member (LogMsg ContractInstanceMsg) effs) =>
Eff effs ()
logCurrentRequests @w @s @e

logCurrentRequests :: forall w s e effs.
    ( Member (State (ContractInstanceStateInternal w s e ())) effs
    , Member (LogMsg ContractInstanceMsg) effs
    )
    => Eff effs ()
logCurrentRequests :: Eff effs ()
logCurrentRequests = do
    [Request PABReq]
hks <- forall (effs :: [* -> *]).
Member (State (ContractInstanceStateInternal w s e ())) effs =>
Eff effs [Request PABReq]
forall w (s :: Row *) e (effs :: [* -> *]).
Member (State (ContractInstanceStateInternal w s e ())) effs =>
Eff effs [Request PABReq]
getHooks @w @s @e
    ContractInstanceMsg -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logDebug (ContractInstanceMsg -> Eff effs ())
-> ContractInstanceMsg -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ [Request Value] -> ContractInstanceMsg
CurrentRequests ([Request Value] -> ContractInstanceMsg)
-> [Request Value] -> ContractInstanceMsg
forall a b. (a -> b) -> a -> b
$ (Request PABReq -> Request Value)
-> [Request PABReq] -> [Request Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PABReq -> Value) -> Request PABReq -> Request Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PABReq -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON) [Request PABReq]
hks

-- | Take the new log messages that were produced by the contract
--   instance and log them with the 'LogMsg' effect.
logNewMessages :: forall w s e effs.
    ( Member (LogMsg ContractInstanceMsg) effs
    , Member (State (ContractInstanceStateInternal w s e ())) effs
    )
    => Eff effs ()
logNewMessages :: Eff effs ()
logNewMessages = do
    Seq (LogMessage Value)
newContractLogs <- (ContractInstanceStateInternal w s e () -> Seq (LogMessage Value))
-> Eff effs (Seq (LogMessage Value))
forall s a (effs :: [* -> *]).
Member (State s) effs =>
(s -> a) -> Eff effs a
gets @(ContractInstanceStateInternal w s e ()) (Getting
  (Seq (LogMessage Value))
  (SuspendedContract w e PABResp PABReq ())
  (Seq (LogMessage Value))
-> SuspendedContract w e PABResp PABReq ()
-> Seq (LogMessage Value)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((ResumableResult w e PABResp PABReq ()
 -> Const
      (Seq (LogMessage Value)) (ResumableResult w e PABResp PABReq ()))
-> SuspendedContract w e PABResp PABReq ()
-> Const
     (Seq (LogMessage Value)) (SuspendedContract w e PABResp PABReq ())
forall w e i o a.
Lens' (SuspendedContract w e i o a) (ResumableResult w e i o a)
resumableResult ((ResumableResult w e PABResp PABReq ()
  -> Const
       (Seq (LogMessage Value)) (ResumableResult w e PABResp PABReq ()))
 -> SuspendedContract w e PABResp PABReq ()
 -> Const
      (Seq (LogMessage Value)) (SuspendedContract w e PABResp PABReq ()))
-> ((Seq (LogMessage Value)
     -> Const (Seq (LogMessage Value)) (Seq (LogMessage Value)))
    -> ResumableResult w e PABResp PABReq ()
    -> Const
         (Seq (LogMessage Value)) (ResumableResult w e PABResp PABReq ()))
-> Getting
     (Seq (LogMessage Value))
     (SuspendedContract w e PABResp PABReq ())
     (Seq (LogMessage Value))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Seq (LogMessage Value)
 -> Const (Seq (LogMessage Value)) (Seq (LogMessage Value)))
-> ResumableResult w e PABResp PABReq ()
-> Const
     (Seq (LogMessage Value)) (ResumableResult w e PABResp PABReq ())
forall w e i o1 a.
Lens' (ResumableResult w e i o1 a) (Seq (LogMessage Value))
lastLogs) (SuspendedContract w e PABResp PABReq () -> Seq (LogMessage Value))
-> (ContractInstanceStateInternal w s e ()
    -> SuspendedContract w e PABResp PABReq ())
-> ContractInstanceStateInternal w s e ()
-> Seq (LogMessage Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContractInstanceStateInternal w s e ()
-> SuspendedContract w e PABResp PABReq ()
forall w (s :: Row *) e a.
ContractInstanceStateInternal w s e a
-> SuspendedContract w e PABResp PABReq a
cisiSuspState)
    (LogMessage Value -> Eff effs ())
-> Seq (LogMessage Value) -> Eff effs ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (LogMsg ContractInstanceMsg () -> Eff effs ()
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send (LogMsg ContractInstanceMsg () -> Eff effs ())
-> (LogMessage Value -> LogMsg ContractInstanceMsg ())
-> LogMessage Value
-> Eff effs ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogMessage ContractInstanceMsg -> LogMsg ContractInstanceMsg ()
forall a. LogMessage a -> LogMsg a ()
LMessage (LogMessage ContractInstanceMsg -> LogMsg ContractInstanceMsg ())
-> (LogMessage Value -> LogMessage ContractInstanceMsg)
-> LogMessage Value
-> LogMsg ContractInstanceMsg ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> ContractInstanceMsg)
-> LogMessage Value -> LogMessage ContractInstanceMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> ContractInstanceMsg
ContractLog) Seq (LogMessage Value)
newContractLogs

-- | A block of transactions, indexed by tx outputs spent and by
--   addresses on which new outputs are produced
data IndexedBlock =
  IndexedBlock
    { IndexedBlock -> Map TxIn ChainIndexTx
ibUtxoSpent    :: Map C.TxIn ChainIndexTx
    , IndexedBlock -> Map CardanoAddress (NonEmpty ChainIndexTx)
ibUtxoProduced :: Map CardanoAddress (NonEmpty ChainIndexTx)
    }

instance Semigroup IndexedBlock where
  IndexedBlock
l <> :: IndexedBlock -> IndexedBlock -> IndexedBlock
<> IndexedBlock
r =
    IndexedBlock :: Map TxIn ChainIndexTx
-> Map CardanoAddress (NonEmpty ChainIndexTx) -> IndexedBlock
IndexedBlock
      { ibUtxoSpent :: Map TxIn ChainIndexTx
ibUtxoSpent = IndexedBlock -> Map TxIn ChainIndexTx
ibUtxoSpent IndexedBlock
l Map TxIn ChainIndexTx
-> Map TxIn ChainIndexTx -> Map TxIn ChainIndexTx
forall a. Semigroup a => a -> a -> a
<> IndexedBlock -> Map TxIn ChainIndexTx
ibUtxoSpent IndexedBlock
r
      , ibUtxoProduced :: Map CardanoAddress (NonEmpty ChainIndexTx)
ibUtxoProduced = (NonEmpty ChainIndexTx
 -> NonEmpty ChainIndexTx -> NonEmpty ChainIndexTx)
-> Map CardanoAddress (NonEmpty ChainIndexTx)
-> Map CardanoAddress (NonEmpty ChainIndexTx)
-> Map CardanoAddress (NonEmpty ChainIndexTx)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith NonEmpty ChainIndexTx
-> NonEmpty ChainIndexTx -> NonEmpty ChainIndexTx
forall a. Semigroup a => a -> a -> a
(<>) (IndexedBlock -> Map CardanoAddress (NonEmpty ChainIndexTx)
ibUtxoProduced IndexedBlock
l) (IndexedBlock -> Map CardanoAddress (NonEmpty ChainIndexTx)
ibUtxoProduced IndexedBlock
r)
      }

instance Monoid IndexedBlock where
  mempty :: IndexedBlock
mempty = Map TxIn ChainIndexTx
-> Map CardanoAddress (NonEmpty ChainIndexTx) -> IndexedBlock
IndexedBlock Map TxIn ChainIndexTx
forall a. Monoid a => a
mempty Map CardanoAddress (NonEmpty ChainIndexTx)
forall a. Monoid a => a
mempty

indexBlock :: [ChainIndexTx] -> IndexedBlock
indexBlock :: [ChainIndexTx] -> IndexedBlock
indexBlock = (ChainIndexTx -> IndexedBlock) -> [ChainIndexTx] -> IndexedBlock
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ChainIndexTx -> IndexedBlock
indexTx where
  indexTx :: ChainIndexTx -> IndexedBlock
indexTx ChainIndexTx
otx =
    IndexedBlock :: Map TxIn ChainIndexTx
-> Map CardanoAddress (NonEmpty ChainIndexTx) -> IndexedBlock
IndexedBlock
      { ibUtxoSpent :: Map TxIn ChainIndexTx
ibUtxoSpent = (TxIn -> ChainIndexTx) -> Set TxIn -> Map TxIn ChainIndexTx
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (ChainIndexTx -> TxIn -> ChainIndexTx
forall a b. a -> b -> a
const ChainIndexTx
otx) (Set TxIn -> Map TxIn ChainIndexTx)
-> Set TxIn -> Map TxIn ChainIndexTx
forall a b. (a -> b) -> a -> b
$ [TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList ([TxIn] -> Set TxIn) -> [TxIn] -> Set TxIn
forall a b. (a -> b) -> a -> b
$ (ToCardanoError -> [TxIn])
-> ([TxIn] -> [TxIn]) -> Either ToCardanoError [TxIn] -> [TxIn]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> [TxIn]
forall a. HasCallStack => String -> a
error (String -> [TxIn])
-> (ToCardanoError -> String) -> ToCardanoError -> [TxIn]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Plutus.Trace.Emulator.ContractInstance.indexBlock: " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (ToCardanoError -> String) -> ToCardanoError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ToCardanoError -> String
forall a. Show a => a -> String
show) [TxIn] -> [TxIn]
forall a. a -> a
id (Either ToCardanoError [TxIn] -> [TxIn])
-> Either ToCardanoError [TxIn] -> [TxIn]
forall a b. (a -> b) -> a -> b
$
            (TxOutRef -> Either ToCardanoError TxIn)
-> [TxOutRef] -> Either ToCardanoError [TxIn]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TxOutRef -> Either ToCardanoError TxIn
toCardanoTxIn ([TxOutRef] -> Either ToCardanoError [TxIn])
-> [TxOutRef] -> Either ToCardanoError [TxIn]
forall a b. (a -> b) -> a -> b
$ Getting [TxOutRef] ChainIndexTx [TxOutRef]
-> ChainIndexTx -> [TxOutRef]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [TxOutRef] ChainIndexTx [TxOutRef]
Lens' ChainIndexTx [TxOutRef]
citxInputs ChainIndexTx
otx
      , ibUtxoProduced :: Map CardanoAddress (NonEmpty ChainIndexTx)
ibUtxoProduced = (NonEmpty ChainIndexTx
 -> NonEmpty ChainIndexTx -> NonEmpty ChainIndexTx)
-> [(CardanoAddress, NonEmpty ChainIndexTx)]
-> Map CardanoAddress (NonEmpty ChainIndexTx)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith NonEmpty ChainIndexTx
-> NonEmpty ChainIndexTx -> NonEmpty ChainIndexTx
forall a. Semigroup a => a -> a -> a
(<>) ([(CardanoAddress, NonEmpty ChainIndexTx)]
 -> Map CardanoAddress (NonEmpty ChainIndexTx))
-> [(CardanoAddress, NonEmpty ChainIndexTx)]
-> Map CardanoAddress (NonEmpty ChainIndexTx)
forall a b. (a -> b) -> a -> b
$ ChainIndexTx -> [ChainIndexTxOut]
txOuts ChainIndexTx
otx [ChainIndexTxOut]
-> (ChainIndexTxOut -> [(CardanoAddress, NonEmpty ChainIndexTx)])
-> [(CardanoAddress, NonEmpty ChainIndexTx)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\ChainIndexTxOut{CardanoAddress
citoAddress :: CardanoAddress
citoAddress :: ChainIndexTxOut -> CardanoAddress
citoAddress} -> [(CardanoAddress
citoAddress, ChainIndexTx
otx ChainIndexTx -> [ChainIndexTx] -> NonEmpty ChainIndexTx
forall a. a -> [a] -> NonEmpty a
:| [])])
      }