{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-

Types and functions for contract instances that communicate with the outside
world via STM. See note [Contract instance thread model].

-}
module Plutus.PAB.Core.ContractInstance.STM(
    BlockchainEnv(..)
    , emptyBlockchainEnv
    , awaitSlot
    , awaitTime
    , awaitEndpointResponse
    , waitForTxStatusChange
    , updateTxChangesR
    , waitForTxOutStatusChange
    , currentSlot
    , lastSyncedBlockSlot
    , InstanceState(..)
    , emptyInstanceState
    , OpenEndpoint(..)
    , OpenTxOutProducedRequest(..)
    , OpenTxOutSpentRequest(..)
    , clearEndpoints
    , addEndpoint
    , addUtxoSpentReq
    , waitForUtxoSpent
    , addUtxoProducedReq
    , waitForUtxoProduced
    , setActivity
    , setObservableState
    , openEndpoints
    , callEndpoint
    , finalResult
    , Activity(..)
    -- * State of all running contract instances
    , InstancesState
    , emptyInstancesState
    , insertInstance
    , removeInstance
    , callEndpointOnInstance
    , callEndpointOnInstanceTimeout
    , observableContractState
    , yieldedExportTxs
    , instanceState
    , instanceIDs
    , instancesWithStatuses
    , instancesClientEnv
    , InstanceClientEnv(..)
    ) where

import Cardano.Node.Emulator.Params (Params (pSlotConfig))
import Cardano.Node.Emulator.TimeSlot qualified as TimeSlot
import Cardano.Wallet.LocalClient.ExportTx (ExportTx)
import Control.Applicative (Alternative (empty))
import Control.Concurrent.STM (STM, TMVar, TVar)
import Control.Concurrent.STM qualified as STM
import Control.Monad (guard)
import Data.Aeson (Value)
import Data.Foldable (fold)
import Data.IORef (IORef)
import Data.IORef qualified as IORef
import Data.List.NonEmpty (NonEmpty)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Set (Set)
import Ledger (CardanoAddress, Slot, TxId, TxOutRef)
import Ledger.Time (POSIXTime)
import Plutus.ChainIndex (BlockNumber (BlockNumber), ChainIndexTx, TxIdState, TxOutBalance, TxOutStatus, TxStatus,
                          transactionStatus)
import Plutus.ChainIndex.TxOutBalance (transactionOutputStatus)
import Plutus.ChainIndex.UtxoState (UtxoIndex, UtxoState (_usTxUtxoData), utxoState)
import Plutus.Contract.Effects (ActiveEndpoint (ActiveEndpoint, aeDescription))
import Plutus.Contract.Resumable (IterationID, Request (Request, itID, rqID, rqRequest), RequestID)
import Plutus.PAB.Core.Indexer.TxConfirmationStatus (TCSIndex)
import Wallet.Types (ContractInstanceId, EndpointDescription, EndpointValue (EndpointValue),
                     NotificationError (EndpointNotAvailable, InstanceDoesNotExist, MoreThanOneEndpointAvailable))
import Wallet.Types qualified as Wallet (ContractActivityStatus (Active, Done, Stopped))

{- Note [Contract instance thread model]

In the PAB we run each contract instance in its own thread, following the
design principles for concurrency described in [1].

As a result
* We use STM for concurrency
* We try to avoid queues and use TVars where possible

Contract instances can make requests to services that are managed by the PAB,
such as the wallet backend, the chain index and the node. From the contract's
POV we assume that these requests are responded to instantaneously. To handle
these requests the PAB uses the
'Wallet.Emulator.MultiAgent.EmulatedWalletEffects' list of effects.

In addition to making requests to PAB services, contract instances can wait for
events to happen. The events that can be waited upon are produced by the
blockchain (transactions added to the ledger, new slots starting) and by
external clients of the PAB including end-users (calling contract endpoints).
To handle this kind of waiting the PAB uses STM and the types defined in this
module.

# QoS

One of the main goals of the queueless STM design is to avoid a degradation
of the quality of service (QoS) when the system is operating at capacity. This
comes at a price: When the system is under pressure, some updates may be
dropped. In practice this a result of the behaviour of STM's 'retry' primitive,
which only guarantees to retry at some point (not immediately) after a variable
has changed. So if the variable changes again before the retry happens, the
intermediate state is not visible.

# Event types

What does this imply for the PAB? Rather than being notified of changes, we want
to be notified of new states. Therefore we choose the following types for the
events that we want to know about.

* Time: TVar with current time
* Modifications to an address: TVar with current UTXO set of that address
* Transactions & rollbacks: TVar with current status of transactions
* Endpoints: For each endpoint a TMVar that changes from empty to full if & when
  the endpoint gets called.

All other requests of the contract are handled using the wallet effects (chain index,
tx construction and signing).

[1] Keynote by Duncan Coutts at the Haskell Symposium 2020. https://vimeo.com/452222780.

-}

-- | An open endpoint that can be responded to.
data OpenEndpoint =
        OpenEndpoint
            { OpenEndpoint -> ActiveEndpoint
oepName     :: ActiveEndpoint -- ^ Name of the endpoint
            , OpenEndpoint -> TMVar (EndpointValue Value)
oepResponse :: TMVar (EndpointValue Value) -- ^ A place to write the response to.
            }

-- | A TxOutRef that a contract instance is watching
data OpenTxOutSpentRequest =
    OpenTxOutSpentRequest
        { OpenTxOutSpentRequest -> TxOutRef
osrOutRef     :: TxOutRef -- ^ The 'TxOutRef' that the instance is watching
        , OpenTxOutSpentRequest -> TMVar ChainIndexTx
osrSpendingTx :: TMVar ChainIndexTx -- ^ A place to write the spending transaction to
        }

data OpenTxOutProducedRequest =
    OpenTxOutProducedRequest
        { OpenTxOutProducedRequest -> CardanoAddress
otxAddress       :: CardanoAddress -- ^ 'Address' that the contract instance is watching (TODO: Should be ViewAddress -- SCP-2628)
        , OpenTxOutProducedRequest -> TMVar (NonEmpty ChainIndexTx)
otxProducingTxns :: TMVar (NonEmpty ChainIndexTx) -- ^ A place to write the producing transactions to
        }

-- | Data about the blockchain that contract instances
--   may be interested in.
data BlockchainEnv =
    BlockchainEnv
        { BlockchainEnv -> Maybe Int
beRollbackHistory     :: Maybe Int -- ^ How much history do we retain in the environment. Zero signifies no trimming is done.
        , BlockchainEnv -> TVar Slot
beCurrentSlot         :: TVar Slot -- ^ Actual current slot
        , BlockchainEnv -> TVar Slot
beLastSyncedBlockSlot :: TVar Slot -- ^ Slot of the last synced block from 'startNodeClient'
        , BlockchainEnv -> TVar BlockNumber
beLastSyncedBlockNo   :: TVar BlockNumber -- ^ Last synced block number from 'startNodeClient'.
        , BlockchainEnv
-> Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges           :: Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)-- ^ Map holding metadata which determines the status of transactions.
        , BlockchainEnv -> TVar (UtxoIndex TxOutBalance)
beTxOutChanges        :: TVar (UtxoIndex TxOutBalance) -- ^ Map holding metadata which determines the status of transaction outputs.
        , BlockchainEnv -> Params
beParams              :: Params -- ^ The set of parameters, like protocol parameters and slot configuration.
        }

updateTxChangesR
  :: Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
  -> (TCSIndex -> IO TCSIndex)
  -> IO ()
updateTxChangesR :: Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
-> (TCSIndex -> IO TCSIndex) -> IO ()
updateTxChangesR Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
env TCSIndex -> IO TCSIndex
f =
    case Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
env of
      Left  TVar (UtxoIndex TxIdState)
_     -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Right IORef TCSIndex
ixRef -> IORef TCSIndex -> IO TCSIndex
forall a. IORef a -> IO a
IORef.readIORef IORef TCSIndex
ixRef IO TCSIndex -> (TCSIndex -> IO TCSIndex) -> IO TCSIndex
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TCSIndex -> IO TCSIndex
f IO TCSIndex -> (TCSIndex -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IORef TCSIndex -> TCSIndex -> IO ()
forall a. IORef a -> a -> IO ()
IORef.writeIORef IORef TCSIndex
ixRef

-- | Initialise an empty 'BlockchainEnv' value
emptyBlockchainEnv :: Maybe Int -> Params -> STM BlockchainEnv
emptyBlockchainEnv :: Maybe Int -> Params -> STM BlockchainEnv
emptyBlockchainEnv Maybe Int
rollbackHistory Params
params =
    Maybe Int
-> TVar Slot
-> TVar Slot
-> TVar BlockNumber
-> Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
-> TVar (UtxoIndex TxOutBalance)
-> Params
-> BlockchainEnv
BlockchainEnv Maybe Int
rollbackHistory
        (TVar Slot
 -> TVar Slot
 -> TVar BlockNumber
 -> Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
 -> TVar (UtxoIndex TxOutBalance)
 -> Params
 -> BlockchainEnv)
-> STM (TVar Slot)
-> STM
     (TVar Slot
      -> TVar BlockNumber
      -> Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
      -> TVar (UtxoIndex TxOutBalance)
      -> Params
      -> BlockchainEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Slot -> STM (TVar Slot)
forall a. a -> STM (TVar a)
STM.newTVar Slot
0
        STM
  (TVar Slot
   -> TVar BlockNumber
   -> Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
   -> TVar (UtxoIndex TxOutBalance)
   -> Params
   -> BlockchainEnv)
-> STM (TVar Slot)
-> STM
     (TVar BlockNumber
      -> Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
      -> TVar (UtxoIndex TxOutBalance)
      -> Params
      -> BlockchainEnv)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Slot -> STM (TVar Slot)
forall a. a -> STM (TVar a)
STM.newTVar Slot
0
        STM
  (TVar BlockNumber
   -> Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
   -> TVar (UtxoIndex TxOutBalance)
   -> Params
   -> BlockchainEnv)
-> STM (TVar BlockNumber)
-> STM
     (Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
      -> TVar (UtxoIndex TxOutBalance) -> Params -> BlockchainEnv)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlockNumber -> STM (TVar BlockNumber)
forall a. a -> STM (TVar a)
STM.newTVar (Word64 -> BlockNumber
BlockNumber Word64
0)
        STM
  (Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
   -> TVar (UtxoIndex TxOutBalance) -> Params -> BlockchainEnv)
-> STM (Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex))
-> STM (TVar (UtxoIndex TxOutBalance) -> Params -> BlockchainEnv)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TVar (UtxoIndex TxIdState)
-> Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
forall a b. a -> Either a b
Left (TVar (UtxoIndex TxIdState)
 -> Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex))
-> STM (TVar (UtxoIndex TxIdState))
-> STM (Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UtxoIndex TxIdState -> STM (TVar (UtxoIndex TxIdState))
forall a. a -> STM (TVar a)
STM.newTVar UtxoIndex TxIdState
forall a. Monoid a => a
mempty)
        STM (TVar (UtxoIndex TxOutBalance) -> Params -> BlockchainEnv)
-> STM (TVar (UtxoIndex TxOutBalance))
-> STM (Params -> BlockchainEnv)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UtxoIndex TxOutBalance -> STM (TVar (UtxoIndex TxOutBalance))
forall a. a -> STM (TVar a)
STM.newTVar UtxoIndex TxOutBalance
forall a. Monoid a => a
mempty
        STM (Params -> BlockchainEnv) -> STM Params -> STM BlockchainEnv
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Params -> STM Params
forall (f :: * -> *) a. Applicative f => a -> f a
pure Params
params

-- | Wait until the current slot is greater than or equal to the
--   target slot, then return the current slot.
awaitSlot :: Slot -> BlockchainEnv -> STM Slot
awaitSlot :: Slot -> BlockchainEnv -> STM Slot
awaitSlot Slot
targetSlot BlockchainEnv{TVar Slot
beCurrentSlot :: TVar Slot
beCurrentSlot :: BlockchainEnv -> TVar Slot
beCurrentSlot} = do
    Slot
current <- TVar Slot -> STM Slot
forall a. TVar a -> STM a
STM.readTVar TVar Slot
beCurrentSlot
    Bool -> STM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Slot
current Slot -> Slot -> Bool
forall a. Ord a => a -> a -> Bool
>= Slot
targetSlot)
    Slot -> STM Slot
forall (f :: * -> *) a. Applicative f => a -> f a
pure Slot
current

-- | Wait until the current time is greater than or equal to the
-- target time, then return the current time.
awaitTime :: POSIXTime -> BlockchainEnv -> STM POSIXTime
awaitTime :: POSIXTime -> BlockchainEnv -> STM POSIXTime
awaitTime POSIXTime
targetTime be :: BlockchainEnv
be@BlockchainEnv{Params
beParams :: Params
beParams :: BlockchainEnv -> Params
beParams} = do
    let slotConfig :: SlotConfig
slotConfig = Params -> SlotConfig
pSlotConfig Params
beParams
    let targetSlot :: Slot
targetSlot = SlotConfig -> POSIXTime -> Slot
TimeSlot.posixTimeToEnclosingSlot SlotConfig
slotConfig POSIXTime
targetTime
    SlotConfig -> Slot -> POSIXTime
TimeSlot.slotToEndPOSIXTime SlotConfig
slotConfig (Slot -> POSIXTime) -> STM Slot -> STM POSIXTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Slot -> BlockchainEnv -> STM Slot
awaitSlot Slot
targetSlot BlockchainEnv
be

-- | Wait for an endpoint response.
awaitEndpointResponse :: Request ActiveEndpoint -> InstanceState -> STM (EndpointValue Value)
awaitEndpointResponse :: Request ActiveEndpoint
-> InstanceState -> STM (EndpointValue Value)
awaitEndpointResponse Request{RequestID
rqID :: RequestID
rqID :: forall o. Request o -> RequestID
rqID, IterationID
itID :: IterationID
itID :: forall o. Request o -> IterationID
itID} InstanceState{TVar (Map (RequestID, IterationID) OpenEndpoint)
issEndpoints :: InstanceState -> TVar (Map (RequestID, IterationID) OpenEndpoint)
issEndpoints :: TVar (Map (RequestID, IterationID) OpenEndpoint)
issEndpoints} = do
    Map (RequestID, IterationID) OpenEndpoint
currentEndpoints <- TVar (Map (RequestID, IterationID) OpenEndpoint)
-> STM (Map (RequestID, IterationID) OpenEndpoint)
forall a. TVar a -> STM a
STM.readTVar TVar (Map (RequestID, IterationID) OpenEndpoint)
issEndpoints
    let openEndpoint :: Maybe OpenEndpoint
openEndpoint = (RequestID, IterationID)
-> Map (RequestID, IterationID) OpenEndpoint -> Maybe OpenEndpoint
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (RequestID
rqID, IterationID
itID) Map (RequestID, IterationID) OpenEndpoint
currentEndpoints
    case Maybe OpenEndpoint
openEndpoint of
        Maybe OpenEndpoint
Nothing                        -> STM (EndpointValue Value)
forall (f :: * -> *) a. Alternative f => f a
empty
        Just OpenEndpoint{TMVar (EndpointValue Value)
oepResponse :: TMVar (EndpointValue Value)
oepResponse :: OpenEndpoint -> TMVar (EndpointValue Value)
oepResponse} -> TMVar (EndpointValue Value) -> STM (EndpointValue Value)
forall a. TMVar a -> STM a
STM.readTMVar TMVar (EndpointValue Value)
oepResponse

-- | Whether the contract instance is still waiting for an event.
data Activity =
        Active
        | Stopped -- ^ Instance was stopped before all requests were handled
        | Done (Maybe Value) -- ^ Instance finished, possibly with an error
        deriving (Activity -> Activity -> Bool
(Activity -> Activity -> Bool)
-> (Activity -> Activity -> Bool) -> Eq Activity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Activity -> Activity -> Bool
$c/= :: Activity -> Activity -> Bool
== :: Activity -> Activity -> Bool
$c== :: Activity -> Activity -> Bool
Eq, Int -> Activity -> ShowS
[Activity] -> ShowS
Activity -> String
(Int -> Activity -> ShowS)
-> (Activity -> String) -> ([Activity] -> ShowS) -> Show Activity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Activity] -> ShowS
$cshowList :: [Activity] -> ShowS
show :: Activity -> String
$cshow :: Activity -> String
showsPrec :: Int -> Activity -> ShowS
$cshowsPrec :: Int -> Activity -> ShowS
Show)

-- | The state of an active contract instance.
data InstanceState =
    InstanceState
        { InstanceState -> TVar (Map (RequestID, IterationID) OpenEndpoint)
issEndpoints        :: TVar (Map (RequestID, IterationID) OpenEndpoint) -- ^ Open endpoints that can be responded to.
        , InstanceState -> TVar Activity
issStatus           :: TVar Activity -- ^ Whether the instance is still running.
        , InstanceState -> TVar (Maybe Value)
issObservableState  :: TVar (Maybe Value) -- ^ Serialised observable state of the contract instance (if available)
        , InstanceState -> TMVar ()
issStop             :: TMVar () -- ^ Stop the instance if a value is written into the TMVar.
        , InstanceState
-> TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
issTxOutRefs        :: TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
        , InstanceState
-> TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
issAddressRefs      :: TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
        , InstanceState -> TVar [ExportTx]
issYieldedExportTxs :: TVar [ExportTx] -- ^ Partial tx that needs to be balanced, signed and submitted by an external agent.
        }

-- | An 'InstanceState' value with empty fields
emptyInstanceState :: STM InstanceState
emptyInstanceState :: STM InstanceState
emptyInstanceState =
    TVar (Map (RequestID, IterationID) OpenEndpoint)
-> TVar Activity
-> TVar (Maybe Value)
-> TMVar ()
-> TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
-> TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
-> TVar [ExportTx]
-> InstanceState
InstanceState
        (TVar (Map (RequestID, IterationID) OpenEndpoint)
 -> TVar Activity
 -> TVar (Maybe Value)
 -> TMVar ()
 -> TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
 -> TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
 -> TVar [ExportTx]
 -> InstanceState)
-> STM (TVar (Map (RequestID, IterationID) OpenEndpoint))
-> STM
     (TVar Activity
      -> TVar (Maybe Value)
      -> TMVar ()
      -> TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
      -> TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
      -> TVar [ExportTx]
      -> InstanceState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (RequestID, IterationID) OpenEndpoint
-> STM (TVar (Map (RequestID, IterationID) OpenEndpoint))
forall a. a -> STM (TVar a)
STM.newTVar Map (RequestID, IterationID) OpenEndpoint
forall a. Monoid a => a
mempty
        STM
  (TVar Activity
   -> TVar (Maybe Value)
   -> TMVar ()
   -> TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
   -> TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
   -> TVar [ExportTx]
   -> InstanceState)
-> STM (TVar Activity)
-> STM
     (TVar (Maybe Value)
      -> TMVar ()
      -> TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
      -> TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
      -> TVar [ExportTx]
      -> InstanceState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Activity -> STM (TVar Activity)
forall a. a -> STM (TVar a)
STM.newTVar Activity
Active
        STM
  (TVar (Maybe Value)
   -> TMVar ()
   -> TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
   -> TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
   -> TVar [ExportTx]
   -> InstanceState)
-> STM (TVar (Maybe Value))
-> STM
     (TMVar ()
      -> TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
      -> TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
      -> TVar [ExportTx]
      -> InstanceState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Value -> STM (TVar (Maybe Value))
forall a. a -> STM (TVar a)
STM.newTVar Maybe Value
forall a. Maybe a
Nothing
        STM
  (TMVar ()
   -> TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
   -> TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
   -> TVar [ExportTx]
   -> InstanceState)
-> STM (TMVar ())
-> STM
     (TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
      -> TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
      -> TVar [ExportTx]
      -> InstanceState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> STM (TMVar ())
forall a. STM (TMVar a)
STM.newEmptyTMVar
        STM
  (TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
   -> TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
   -> TVar [ExportTx]
   -> InstanceState)
-> STM (TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest))
-> STM
     (TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
      -> TVar [ExportTx] -> InstanceState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map (RequestID, IterationID) OpenTxOutSpentRequest
-> STM (TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest))
forall a. a -> STM (TVar a)
STM.newTVar Map (RequestID, IterationID) OpenTxOutSpentRequest
forall a. Monoid a => a
mempty
        STM
  (TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
   -> TVar [ExportTx] -> InstanceState)
-> STM
     (TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest))
-> STM (TVar [ExportTx] -> InstanceState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map (RequestID, IterationID) OpenTxOutProducedRequest
-> STM
     (TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest))
forall a. a -> STM (TVar a)
STM.newTVar Map (RequestID, IterationID) OpenTxOutProducedRequest
forall a. Monoid a => a
mempty
        STM (TVar [ExportTx] -> InstanceState)
-> STM (TVar [ExportTx]) -> STM InstanceState
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [ExportTx] -> STM (TVar [ExportTx])
forall a. a -> STM (TVar a)
STM.newTVar [ExportTx]
forall a. Monoid a => a
mempty

-- | Events that the contract instances are waiting for, indexed by keys that are
--   readily available in the node client (ie. that can be produced from just a
--   block without any additional information)
data InstanceClientEnv = InstanceClientEnv
  { InstanceClientEnv -> Map TxOutRef [OpenTxOutSpentRequest]
ceUtxoSpentRequests    :: Map TxOutRef [OpenTxOutSpentRequest]
  , InstanceClientEnv -> Map CardanoAddress [OpenTxOutProducedRequest]
ceUtxoProducedRequests :: Map CardanoAddress [OpenTxOutProducedRequest] -- TODO: ViewAddress
  }

instance Semigroup InstanceClientEnv where
    InstanceClientEnv
l <> :: InstanceClientEnv -> InstanceClientEnv -> InstanceClientEnv
<> InstanceClientEnv
r =
        InstanceClientEnv :: Map TxOutRef [OpenTxOutSpentRequest]
-> Map CardanoAddress [OpenTxOutProducedRequest]
-> InstanceClientEnv
InstanceClientEnv
            { ceUtxoProducedRequests :: Map CardanoAddress [OpenTxOutProducedRequest]
ceUtxoProducedRequests = ([OpenTxOutProducedRequest]
 -> [OpenTxOutProducedRequest] -> [OpenTxOutProducedRequest])
-> Map CardanoAddress [OpenTxOutProducedRequest]
-> Map CardanoAddress [OpenTxOutProducedRequest]
-> Map CardanoAddress [OpenTxOutProducedRequest]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith [OpenTxOutProducedRequest]
-> [OpenTxOutProducedRequest] -> [OpenTxOutProducedRequest]
forall a. Semigroup a => a -> a -> a
(<>) (InstanceClientEnv -> Map CardanoAddress [OpenTxOutProducedRequest]
ceUtxoProducedRequests InstanceClientEnv
l) (InstanceClientEnv -> Map CardanoAddress [OpenTxOutProducedRequest]
ceUtxoProducedRequests InstanceClientEnv
r)
            , ceUtxoSpentRequests :: Map TxOutRef [OpenTxOutSpentRequest]
ceUtxoSpentRequests = ([OpenTxOutSpentRequest]
 -> [OpenTxOutSpentRequest] -> [OpenTxOutSpentRequest])
-> Map TxOutRef [OpenTxOutSpentRequest]
-> Map TxOutRef [OpenTxOutSpentRequest]
-> Map TxOutRef [OpenTxOutSpentRequest]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith [OpenTxOutSpentRequest]
-> [OpenTxOutSpentRequest] -> [OpenTxOutSpentRequest]
forall a. Semigroup a => a -> a -> a
(<>) (InstanceClientEnv -> Map TxOutRef [OpenTxOutSpentRequest]
ceUtxoSpentRequests InstanceClientEnv
l) (InstanceClientEnv -> Map TxOutRef [OpenTxOutSpentRequest]
ceUtxoSpentRequests InstanceClientEnv
r)
            }

instance Monoid InstanceClientEnv where
    mappend :: InstanceClientEnv -> InstanceClientEnv -> InstanceClientEnv
mappend = InstanceClientEnv -> InstanceClientEnv -> InstanceClientEnv
forall a. Semigroup a => a -> a -> a
(<>)
    mempty :: InstanceClientEnv
mempty = Map TxOutRef [OpenTxOutSpentRequest]
-> Map CardanoAddress [OpenTxOutProducedRequest]
-> InstanceClientEnv
InstanceClientEnv Map TxOutRef [OpenTxOutSpentRequest]
forall a. Monoid a => a
mempty Map CardanoAddress [OpenTxOutProducedRequest]
forall a. Monoid a => a
mempty

instancesClientEnv :: InstancesState -> IO (STM InstanceClientEnv)
instancesClientEnv :: InstancesState -> IO (STM InstanceClientEnv)
instancesClientEnv = (Map ContractInstanceId InstanceState -> STM InstanceClientEnv)
-> IO (Map ContractInstanceId InstanceState)
-> IO (STM InstanceClientEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Map ContractInstanceId InstanceClientEnv -> InstanceClientEnv)
-> STM (Map ContractInstanceId InstanceClientEnv)
-> STM InstanceClientEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map ContractInstanceId InstanceClientEnv -> InstanceClientEnv
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (STM (Map ContractInstanceId InstanceClientEnv)
 -> STM InstanceClientEnv)
-> (Map ContractInstanceId InstanceState
    -> STM (Map ContractInstanceId InstanceClientEnv))
-> Map ContractInstanceId InstanceState
-> STM InstanceClientEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InstanceState -> STM InstanceClientEnv)
-> Map ContractInstanceId InstanceState
-> STM (Map ContractInstanceId InstanceClientEnv)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse InstanceState -> STM InstanceClientEnv
instanceClientEnv) (IO (Map ContractInstanceId InstanceState)
 -> IO (STM InstanceClientEnv))
-> (InstancesState -> IO (Map ContractInstanceId InstanceState))
-> InstancesState
-> IO (STM InstanceClientEnv)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (Map ContractInstanceId InstanceState)
-> IO (Map ContractInstanceId InstanceState)
forall a. IORef a -> IO a
IORef.readIORef (IORef (Map ContractInstanceId InstanceState)
 -> IO (Map ContractInstanceId InstanceState))
-> (InstancesState -> IORef (Map ContractInstanceId InstanceState))
-> InstancesState
-> IO (Map ContractInstanceId InstanceState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstancesState -> IORef (Map ContractInstanceId InstanceState)
getInstancesState

instanceClientEnv :: InstanceState -> STM InstanceClientEnv
instanceClientEnv :: InstanceState -> STM InstanceClientEnv
instanceClientEnv InstanceState{TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
issTxOutRefs :: TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
issTxOutRefs :: InstanceState
-> TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
issTxOutRefs, TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
issAddressRefs :: TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
issAddressRefs :: InstanceState
-> TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
issAddressRefs} =
  Map TxOutRef [OpenTxOutSpentRequest]
-> Map CardanoAddress [OpenTxOutProducedRequest]
-> InstanceClientEnv
InstanceClientEnv
    (Map TxOutRef [OpenTxOutSpentRequest]
 -> Map CardanoAddress [OpenTxOutProducedRequest]
 -> InstanceClientEnv)
-> STM (Map TxOutRef [OpenTxOutSpentRequest])
-> STM
     (Map CardanoAddress [OpenTxOutProducedRequest]
      -> InstanceClientEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(TxOutRef, [OpenTxOutSpentRequest])]
-> Map TxOutRef [OpenTxOutSpentRequest]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TxOutRef, [OpenTxOutSpentRequest])]
 -> Map TxOutRef [OpenTxOutSpentRequest])
-> (Map (RequestID, IterationID) OpenTxOutSpentRequest
    -> [(TxOutRef, [OpenTxOutSpentRequest])])
-> Map (RequestID, IterationID) OpenTxOutSpentRequest
-> Map TxOutRef [OpenTxOutSpentRequest]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((RequestID, IterationID), OpenTxOutSpentRequest)
 -> (TxOutRef, [OpenTxOutSpentRequest]))
-> [((RequestID, IterationID), OpenTxOutSpentRequest)]
-> [(TxOutRef, [OpenTxOutSpentRequest])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((\r :: OpenTxOutSpentRequest
r@OpenTxOutSpentRequest{TxOutRef
osrOutRef :: TxOutRef
osrOutRef :: OpenTxOutSpentRequest -> TxOutRef
osrOutRef} -> (TxOutRef
osrOutRef, [OpenTxOutSpentRequest
r])) (OpenTxOutSpentRequest -> (TxOutRef, [OpenTxOutSpentRequest]))
-> (((RequestID, IterationID), OpenTxOutSpentRequest)
    -> OpenTxOutSpentRequest)
-> ((RequestID, IterationID), OpenTxOutSpentRequest)
-> (TxOutRef, [OpenTxOutSpentRequest])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((RequestID, IterationID), OpenTxOutSpentRequest)
-> OpenTxOutSpentRequest
forall a b. (a, b) -> b
snd) ([((RequestID, IterationID), OpenTxOutSpentRequest)]
 -> [(TxOutRef, [OpenTxOutSpentRequest])])
-> (Map (RequestID, IterationID) OpenTxOutSpentRequest
    -> [((RequestID, IterationID), OpenTxOutSpentRequest)])
-> Map (RequestID, IterationID) OpenTxOutSpentRequest
-> [(TxOutRef, [OpenTxOutSpentRequest])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (RequestID, IterationID) OpenTxOutSpentRequest
-> [((RequestID, IterationID), OpenTxOutSpentRequest)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map (RequestID, IterationID) OpenTxOutSpentRequest
 -> Map TxOutRef [OpenTxOutSpentRequest])
-> STM (Map (RequestID, IterationID) OpenTxOutSpentRequest)
-> STM (Map TxOutRef [OpenTxOutSpentRequest])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
-> STM (Map (RequestID, IterationID) OpenTxOutSpentRequest)
forall a. TVar a -> STM a
STM.readTVar TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
issTxOutRefs)
    STM
  (Map CardanoAddress [OpenTxOutProducedRequest]
   -> InstanceClientEnv)
-> STM (Map CardanoAddress [OpenTxOutProducedRequest])
-> STM InstanceClientEnv
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([(CardanoAddress, [OpenTxOutProducedRequest])]
-> Map CardanoAddress [OpenTxOutProducedRequest]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(CardanoAddress, [OpenTxOutProducedRequest])]
 -> Map CardanoAddress [OpenTxOutProducedRequest])
-> (Map (RequestID, IterationID) OpenTxOutProducedRequest
    -> [(CardanoAddress, [OpenTxOutProducedRequest])])
-> Map (RequestID, IterationID) OpenTxOutProducedRequest
-> Map CardanoAddress [OpenTxOutProducedRequest]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((RequestID, IterationID), OpenTxOutProducedRequest)
 -> (CardanoAddress, [OpenTxOutProducedRequest]))
-> [((RequestID, IterationID), OpenTxOutProducedRequest)]
-> [(CardanoAddress, [OpenTxOutProducedRequest])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((\r :: OpenTxOutProducedRequest
r@OpenTxOutProducedRequest{CardanoAddress
otxAddress :: CardanoAddress
otxAddress :: OpenTxOutProducedRequest -> CardanoAddress
otxAddress} -> (CardanoAddress
otxAddress, [OpenTxOutProducedRequest
r])) (OpenTxOutProducedRequest
 -> (CardanoAddress, [OpenTxOutProducedRequest]))
-> (((RequestID, IterationID), OpenTxOutProducedRequest)
    -> OpenTxOutProducedRequest)
-> ((RequestID, IterationID), OpenTxOutProducedRequest)
-> (CardanoAddress, [OpenTxOutProducedRequest])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((RequestID, IterationID), OpenTxOutProducedRequest)
-> OpenTxOutProducedRequest
forall a b. (a, b) -> b
snd) ([((RequestID, IterationID), OpenTxOutProducedRequest)]
 -> [(CardanoAddress, [OpenTxOutProducedRequest])])
-> (Map (RequestID, IterationID) OpenTxOutProducedRequest
    -> [((RequestID, IterationID), OpenTxOutProducedRequest)])
-> Map (RequestID, IterationID) OpenTxOutProducedRequest
-> [(CardanoAddress, [OpenTxOutProducedRequest])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (RequestID, IterationID) OpenTxOutProducedRequest
-> [((RequestID, IterationID), OpenTxOutProducedRequest)]
forall k a. Map k a -> [(k, a)]
Map.toList  (Map (RequestID, IterationID) OpenTxOutProducedRequest
 -> Map CardanoAddress [OpenTxOutProducedRequest])
-> STM (Map (RequestID, IterationID) OpenTxOutProducedRequest)
-> STM (Map CardanoAddress [OpenTxOutProducedRequest])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
-> STM (Map (RequestID, IterationID) OpenTxOutProducedRequest)
forall a. TVar a -> STM a
STM.readTVar TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
issAddressRefs)

-- | Set the 'Activity' of the instance
setActivity :: Activity -> InstanceState -> STM ()
setActivity :: Activity -> InstanceState -> STM ()
setActivity Activity
a InstanceState{TVar Activity
issStatus :: TVar Activity
issStatus :: InstanceState -> TVar Activity
issStatus} = TVar Activity -> Activity -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar Activity
issStatus Activity
a

-- | Empty the list of open enpoints that can be called on the instance
clearEndpoints :: InstanceState -> STM ()
clearEndpoints :: InstanceState -> STM ()
clearEndpoints InstanceState{TVar (Map (RequestID, IterationID) OpenEndpoint)
issEndpoints :: TVar (Map (RequestID, IterationID) OpenEndpoint)
issEndpoints :: InstanceState -> TVar (Map (RequestID, IterationID) OpenEndpoint)
issEndpoints, TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
issTxOutRefs :: TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
issTxOutRefs :: InstanceState
-> TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
issTxOutRefs, TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
issAddressRefs :: TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
issAddressRefs :: InstanceState
-> TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
issAddressRefs} = do
    TVar (Map (RequestID, IterationID) OpenEndpoint)
-> Map (RequestID, IterationID) OpenEndpoint -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar (Map (RequestID, IterationID) OpenEndpoint)
issEndpoints Map (RequestID, IterationID) OpenEndpoint
forall k a. Map k a
Map.empty
    TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
-> Map (RequestID, IterationID) OpenTxOutSpentRequest -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
issTxOutRefs Map (RequestID, IterationID) OpenTxOutSpentRequest
forall k a. Map k a
Map.empty
    TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
-> Map (RequestID, IterationID) OpenTxOutProducedRequest -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
issAddressRefs Map (RequestID, IterationID) OpenTxOutProducedRequest
forall k a. Map k a
Map.empty

-- | Add an active endpoint to the instance's list of active endpoints.
addEndpoint :: Request ActiveEndpoint -> InstanceState -> STM ()
addEndpoint :: Request ActiveEndpoint -> InstanceState -> STM ()
addEndpoint Request{RequestID
rqID :: RequestID
rqID :: forall o. Request o -> RequestID
rqID, IterationID
itID :: IterationID
itID :: forall o. Request o -> IterationID
itID, ActiveEndpoint
rqRequest :: ActiveEndpoint
rqRequest :: forall o. Request o -> o
rqRequest} InstanceState{TVar (Map (RequestID, IterationID) OpenEndpoint)
issEndpoints :: TVar (Map (RequestID, IterationID) OpenEndpoint)
issEndpoints :: InstanceState -> TVar (Map (RequestID, IterationID) OpenEndpoint)
issEndpoints} = do
    OpenEndpoint
endpoint <- ActiveEndpoint -> TMVar (EndpointValue Value) -> OpenEndpoint
OpenEndpoint ActiveEndpoint
rqRequest (TMVar (EndpointValue Value) -> OpenEndpoint)
-> STM (TMVar (EndpointValue Value)) -> STM OpenEndpoint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (TMVar (EndpointValue Value))
forall a. STM (TMVar a)
STM.newEmptyTMVar
    TVar (Map (RequestID, IterationID) OpenEndpoint)
-> (Map (RequestID, IterationID) OpenEndpoint
    -> Map (RequestID, IterationID) OpenEndpoint)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
STM.modifyTVar TVar (Map (RequestID, IterationID) OpenEndpoint)
issEndpoints ((RequestID, IterationID)
-> OpenEndpoint
-> Map (RequestID, IterationID) OpenEndpoint
-> Map (RequestID, IterationID) OpenEndpoint
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (RequestID
rqID, IterationID
itID) OpenEndpoint
endpoint)

-- | Add a new 'OpenTxOutSpentRequest' to the instance's list of
--   utxo spent requests
addUtxoSpentReq :: Request TxOutRef -> InstanceState -> STM ()
addUtxoSpentReq :: Request TxOutRef -> InstanceState -> STM ()
addUtxoSpentReq Request{RequestID
rqID :: RequestID
rqID :: forall o. Request o -> RequestID
rqID, IterationID
itID :: IterationID
itID :: forall o. Request o -> IterationID
itID, TxOutRef
rqRequest :: TxOutRef
rqRequest :: forall o. Request o -> o
rqRequest} InstanceState{TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
issTxOutRefs :: TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
issTxOutRefs :: InstanceState
-> TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
issTxOutRefs} = do
    OpenTxOutSpentRequest
request <- TxOutRef -> TMVar ChainIndexTx -> OpenTxOutSpentRequest
OpenTxOutSpentRequest TxOutRef
rqRequest (TMVar ChainIndexTx -> OpenTxOutSpentRequest)
-> STM (TMVar ChainIndexTx) -> STM OpenTxOutSpentRequest
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (TMVar ChainIndexTx)
forall a. STM (TMVar a)
STM.newEmptyTMVar
    TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
-> (Map (RequestID, IterationID) OpenTxOutSpentRequest
    -> Map (RequestID, IterationID) OpenTxOutSpentRequest)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
STM.modifyTVar TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
issTxOutRefs ((RequestID, IterationID)
-> OpenTxOutSpentRequest
-> Map (RequestID, IterationID) OpenTxOutSpentRequest
-> Map (RequestID, IterationID) OpenTxOutSpentRequest
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (RequestID
rqID, IterationID
itID) OpenTxOutSpentRequest
request)

waitForUtxoSpent :: Request TxOutRef -> InstanceState -> STM ChainIndexTx
waitForUtxoSpent :: Request TxOutRef -> InstanceState -> STM ChainIndexTx
waitForUtxoSpent Request{RequestID
rqID :: RequestID
rqID :: forall o. Request o -> RequestID
rqID, IterationID
itID :: IterationID
itID :: forall o. Request o -> IterationID
itID} InstanceState{TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
issTxOutRefs :: TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
issTxOutRefs :: InstanceState
-> TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
issTxOutRefs} = do
    Map (RequestID, IterationID) OpenTxOutSpentRequest
theMap <- TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
-> STM (Map (RequestID, IterationID) OpenTxOutSpentRequest)
forall a. TVar a -> STM a
STM.readTVar TVar (Map (RequestID, IterationID) OpenTxOutSpentRequest)
issTxOutRefs
    case (RequestID, IterationID)
-> Map (RequestID, IterationID) OpenTxOutSpentRequest
-> Maybe OpenTxOutSpentRequest
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (RequestID
rqID, IterationID
itID) Map (RequestID, IterationID) OpenTxOutSpentRequest
theMap of
        Maybe OpenTxOutSpentRequest
Nothing                                   -> STM ChainIndexTx
forall (f :: * -> *) a. Alternative f => f a
empty
        Just OpenTxOutSpentRequest{TMVar ChainIndexTx
osrSpendingTx :: TMVar ChainIndexTx
osrSpendingTx :: OpenTxOutSpentRequest -> TMVar ChainIndexTx
osrSpendingTx} -> TMVar ChainIndexTx -> STM ChainIndexTx
forall a. TMVar a -> STM a
STM.readTMVar TMVar ChainIndexTx
osrSpendingTx

-- | Add a new 'OpenTxOutProducedRequest' to the instance's list of
--   utxo produced requests
addUtxoProducedReq :: Request CardanoAddress -> InstanceState -> STM ()
addUtxoProducedReq :: Request CardanoAddress -> InstanceState -> STM ()
addUtxoProducedReq Request{RequestID
rqID :: RequestID
rqID :: forall o. Request o -> RequestID
rqID, IterationID
itID :: IterationID
itID :: forall o. Request o -> IterationID
itID, CardanoAddress
rqRequest :: CardanoAddress
rqRequest :: forall o. Request o -> o
rqRequest} InstanceState{TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
issAddressRefs :: TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
issAddressRefs :: InstanceState
-> TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
issAddressRefs} = do
    OpenTxOutProducedRequest
request <- CardanoAddress
-> TMVar (NonEmpty ChainIndexTx) -> OpenTxOutProducedRequest
OpenTxOutProducedRequest CardanoAddress
rqRequest (TMVar (NonEmpty ChainIndexTx) -> OpenTxOutProducedRequest)
-> STM (TMVar (NonEmpty ChainIndexTx))
-> STM OpenTxOutProducedRequest
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (TMVar (NonEmpty ChainIndexTx))
forall a. STM (TMVar a)
STM.newEmptyTMVar
    TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
-> (Map (RequestID, IterationID) OpenTxOutProducedRequest
    -> Map (RequestID, IterationID) OpenTxOutProducedRequest)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
STM.modifyTVar TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
issAddressRefs ((RequestID, IterationID)
-> OpenTxOutProducedRequest
-> Map (RequestID, IterationID) OpenTxOutProducedRequest
-> Map (RequestID, IterationID) OpenTxOutProducedRequest
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (RequestID
rqID, IterationID
itID) OpenTxOutProducedRequest
request)

waitForUtxoProduced :: Request CardanoAddress -> InstanceState -> STM (NonEmpty ChainIndexTx)
waitForUtxoProduced :: Request CardanoAddress
-> InstanceState -> STM (NonEmpty ChainIndexTx)
waitForUtxoProduced Request{RequestID
rqID :: RequestID
rqID :: forall o. Request o -> RequestID
rqID, IterationID
itID :: IterationID
itID :: forall o. Request o -> IterationID
itID} InstanceState{TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
issAddressRefs :: TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
issAddressRefs :: InstanceState
-> TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
issAddressRefs} = do
    Map (RequestID, IterationID) OpenTxOutProducedRequest
theMap <- TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
-> STM (Map (RequestID, IterationID) OpenTxOutProducedRequest)
forall a. TVar a -> STM a
STM.readTVar TVar (Map (RequestID, IterationID) OpenTxOutProducedRequest)
issAddressRefs
    case (RequestID, IterationID)
-> Map (RequestID, IterationID) OpenTxOutProducedRequest
-> Maybe OpenTxOutProducedRequest
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (RequestID
rqID, IterationID
itID) Map (RequestID, IterationID) OpenTxOutProducedRequest
theMap of
        Maybe OpenTxOutProducedRequest
Nothing                                         -> STM (NonEmpty ChainIndexTx)
forall (f :: * -> *) a. Alternative f => f a
empty
        Just OpenTxOutProducedRequest{TMVar (NonEmpty ChainIndexTx)
otxProducingTxns :: TMVar (NonEmpty ChainIndexTx)
otxProducingTxns :: OpenTxOutProducedRequest -> TMVar (NonEmpty ChainIndexTx)
otxProducingTxns} -> TMVar (NonEmpty ChainIndexTx) -> STM (NonEmpty ChainIndexTx)
forall a. TMVar a -> STM a
STM.readTMVar TMVar (NonEmpty ChainIndexTx)
otxProducingTxns

-- | Write a new value into the contract instance's observable state.
setObservableState :: Value -> InstanceState -> STM ()
setObservableState :: Value -> InstanceState -> STM ()
setObservableState Value
vl InstanceState{TVar (Maybe Value)
issObservableState :: TVar (Maybe Value)
issObservableState :: InstanceState -> TVar (Maybe Value)
issObservableState} =
    TVar (Maybe Value) -> Maybe Value -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar (Maybe Value)
issObservableState (Value -> Maybe Value
forall a. a -> Maybe a
Just Value
vl)

-- | The list of all endpoints that can be called on the instance
openEndpoints :: InstanceState -> STM (Map (RequestID, IterationID) OpenEndpoint)
openEndpoints :: InstanceState -> STM (Map (RequestID, IterationID) OpenEndpoint)
openEndpoints = TVar (Map (RequestID, IterationID) OpenEndpoint)
-> STM (Map (RequestID, IterationID) OpenEndpoint)
forall a. TVar a -> STM a
STM.readTVar (TVar (Map (RequestID, IterationID) OpenEndpoint)
 -> STM (Map (RequestID, IterationID) OpenEndpoint))
-> (InstanceState
    -> TVar (Map (RequestID, IterationID) OpenEndpoint))
-> InstanceState
-> STM (Map (RequestID, IterationID) OpenEndpoint)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstanceState -> TVar (Map (RequestID, IterationID) OpenEndpoint)
issEndpoints

-- | Call an endpoint with a JSON value.
callEndpoint :: OpenEndpoint -> EndpointValue Value -> STM ()
callEndpoint :: OpenEndpoint -> EndpointValue Value -> STM ()
callEndpoint OpenEndpoint{TMVar (EndpointValue Value)
oepResponse :: TMVar (EndpointValue Value)
oepResponse :: OpenEndpoint -> TMVar (EndpointValue Value)
oepResponse} = TMVar (EndpointValue Value) -> EndpointValue Value -> STM ()
forall a. TMVar a -> a -> STM ()
STM.putTMVar TMVar (EndpointValue Value)
oepResponse

-- | Call an endpoint on a contract instance. Fail immediately if the endpoint is not active.
callEndpointOnInstance :: InstancesState -> EndpointDescription -> Value -> ContractInstanceId -> IO (STM (Maybe NotificationError))
callEndpointOnInstance :: InstancesState
-> EndpointDescription
-> Value
-> ContractInstanceId
-> IO (STM (Maybe NotificationError))
callEndpointOnInstance InstancesState
s EndpointDescription
endpointDescription Value
value ContractInstanceId
instanceID =
    let err :: STM (Maybe NotificationError)
err = Maybe NotificationError -> STM (Maybe NotificationError)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe NotificationError -> STM (Maybe NotificationError))
-> Maybe NotificationError -> STM (Maybe NotificationError)
forall a b. (a -> b) -> a -> b
$ NotificationError -> Maybe NotificationError
forall a. a -> Maybe a
Just (NotificationError -> Maybe NotificationError)
-> NotificationError -> Maybe NotificationError
forall a b. (a -> b) -> a -> b
$ ContractInstanceId -> EndpointDescription -> NotificationError
EndpointNotAvailable ContractInstanceId
instanceID EndpointDescription
endpointDescription
    in STM (Maybe NotificationError)
-> InstancesState
-> EndpointDescription
-> Value
-> ContractInstanceId
-> IO (STM (Maybe NotificationError))
callEndpointOnInstance' STM (Maybe NotificationError)
err InstancesState
s EndpointDescription
endpointDescription Value
value ContractInstanceId
instanceID

-- | Call an endpoint on a contract instance. If the endpoint is not active, wait until the
--   TMVar is filled, then fail. (if the endpoint becomes active in the meantime it will be
--   called)
callEndpointOnInstanceTimeout :: STM.TMVar () -> InstancesState -> EndpointDescription -> Value -> ContractInstanceId -> IO (STM (Maybe NotificationError))
callEndpointOnInstanceTimeout :: TMVar ()
-> InstancesState
-> EndpointDescription
-> Value
-> ContractInstanceId
-> IO (STM (Maybe NotificationError))
callEndpointOnInstanceTimeout TMVar ()
tmv InstancesState
s EndpointDescription
endpointDescription Value
value ContractInstanceId
instanceID =
    let err :: STM (Maybe NotificationError)
err = do
            ()
_ <- TMVar () -> STM ()
forall a. TMVar a -> STM a
STM.takeTMVar TMVar ()
tmv
            Maybe NotificationError -> STM (Maybe NotificationError)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe NotificationError -> STM (Maybe NotificationError))
-> Maybe NotificationError -> STM (Maybe NotificationError)
forall a b. (a -> b) -> a -> b
$ NotificationError -> Maybe NotificationError
forall a. a -> Maybe a
Just (NotificationError -> Maybe NotificationError)
-> NotificationError -> Maybe NotificationError
forall a b. (a -> b) -> a -> b
$ ContractInstanceId -> EndpointDescription -> NotificationError
EndpointNotAvailable ContractInstanceId
instanceID EndpointDescription
endpointDescription
    in STM (Maybe NotificationError)
-> InstancesState
-> EndpointDescription
-> Value
-> ContractInstanceId
-> IO (STM (Maybe NotificationError))
callEndpointOnInstance' STM (Maybe NotificationError)
err InstancesState
s EndpointDescription
endpointDescription Value
value ContractInstanceId
instanceID

-- | Call an endpoint on a contract instance. The caller can define what to do if the endpoint
--   is not available.
callEndpointOnInstance' ::
    STM (Maybe NotificationError) -- ^ What to do when the endpoint is not available
    -> InstancesState
    -> EndpointDescription
    -> Value
    -> ContractInstanceId
    -> IO (STM (Maybe NotificationError))
callEndpointOnInstance' :: STM (Maybe NotificationError)
-> InstancesState
-> EndpointDescription
-> Value
-> ContractInstanceId
-> IO (STM (Maybe NotificationError))
callEndpointOnInstance' STM (Maybe NotificationError)
notAvailable (InstancesState IORef (Map ContractInstanceId InstanceState)
m) EndpointDescription
endpointDescription Value
value ContractInstanceId
instanceID = do
    Map ContractInstanceId InstanceState
instances <- IORef (Map ContractInstanceId InstanceState)
-> IO (Map ContractInstanceId InstanceState)
forall a. IORef a -> IO a
IORef.readIORef IORef (Map ContractInstanceId InstanceState)
m
    case ContractInstanceId
-> Map ContractInstanceId InstanceState -> Maybe InstanceState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ContractInstanceId
instanceID Map ContractInstanceId InstanceState
instances of
        Maybe InstanceState
Nothing -> STM (Maybe NotificationError) -> IO (STM (Maybe NotificationError))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (STM (Maybe NotificationError)
 -> IO (STM (Maybe NotificationError)))
-> STM (Maybe NotificationError)
-> IO (STM (Maybe NotificationError))
forall a b. (a -> b) -> a -> b
$ Maybe NotificationError -> STM (Maybe NotificationError)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NotificationError -> Maybe NotificationError
forall a. a -> Maybe a
Just (NotificationError -> Maybe NotificationError)
-> NotificationError -> Maybe NotificationError
forall a b. (a -> b) -> a -> b
$ ContractInstanceId -> NotificationError
InstanceDoesNotExist ContractInstanceId
instanceID)
        Just InstanceState
is -> STM (Maybe NotificationError) -> IO (STM (Maybe NotificationError))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (STM (Maybe NotificationError)
 -> IO (STM (Maybe NotificationError)))
-> STM (Maybe NotificationError)
-> IO (STM (Maybe NotificationError))
forall a b. (a -> b) -> a -> b
$ do
            Map (RequestID, IterationID) OpenEndpoint
mp <- InstanceState -> STM (Map (RequestID, IterationID) OpenEndpoint)
openEndpoints InstanceState
is
            let match :: OpenEndpoint -> Bool
match OpenEndpoint{oepName :: OpenEndpoint -> ActiveEndpoint
oepName=ActiveEndpoint{aeDescription :: ActiveEndpoint -> EndpointDescription
aeDescription=EndpointDescription
d}} = EndpointDescription
endpointDescription EndpointDescription -> EndpointDescription -> Bool
forall a. Eq a => a -> a -> Bool
== EndpointDescription
d
            case (OpenEndpoint -> Bool) -> [OpenEndpoint] -> [OpenEndpoint]
forall a. (a -> Bool) -> [a] -> [a]
filter OpenEndpoint -> Bool
match ([OpenEndpoint] -> [OpenEndpoint])
-> [OpenEndpoint] -> [OpenEndpoint]
forall a b. (a -> b) -> a -> b
$ (((RequestID, IterationID), OpenEndpoint) -> OpenEndpoint)
-> [((RequestID, IterationID), OpenEndpoint)] -> [OpenEndpoint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RequestID, IterationID), OpenEndpoint) -> OpenEndpoint
forall a b. (a, b) -> b
snd ([((RequestID, IterationID), OpenEndpoint)] -> [OpenEndpoint])
-> [((RequestID, IterationID), OpenEndpoint)] -> [OpenEndpoint]
forall a b. (a -> b) -> a -> b
$ Map (RequestID, IterationID) OpenEndpoint
-> [((RequestID, IterationID), OpenEndpoint)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (RequestID, IterationID) OpenEndpoint
mp of
                []   -> STM (Maybe NotificationError)
notAvailable
                [OpenEndpoint
ep] -> OpenEndpoint -> EndpointValue Value -> STM ()
callEndpoint OpenEndpoint
ep (Value -> EndpointValue Value
forall a. a -> EndpointValue a
EndpointValue Value
value) STM ()
-> STM (Maybe NotificationError) -> STM (Maybe NotificationError)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe NotificationError -> STM (Maybe NotificationError)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe NotificationError
forall a. Maybe a
Nothing
                [OpenEndpoint]
_    -> Maybe NotificationError -> STM (Maybe NotificationError)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe NotificationError -> STM (Maybe NotificationError))
-> Maybe NotificationError -> STM (Maybe NotificationError)
forall a b. (a -> b) -> a -> b
$ NotificationError -> Maybe NotificationError
forall a. a -> Maybe a
Just (NotificationError -> Maybe NotificationError)
-> NotificationError -> Maybe NotificationError
forall a b. (a -> b) -> a -> b
$ ContractInstanceId -> EndpointDescription -> NotificationError
MoreThanOneEndpointAvailable ContractInstanceId
instanceID EndpointDescription
endpointDescription

-- | The list of all partial txs that need to be balanced on the instance.
yieldedExportTxs :: InstanceState -> STM [ExportTx]
yieldedExportTxs :: InstanceState -> STM [ExportTx]
yieldedExportTxs = TVar [ExportTx] -> STM [ExportTx]
forall a. TVar a -> STM a
STM.readTVar (TVar [ExportTx] -> STM [ExportTx])
-> (InstanceState -> TVar [ExportTx])
-> InstanceState
-> STM [ExportTx]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstanceState -> TVar [ExportTx]
issYieldedExportTxs

-- | State of all contract instances that are currently running
newtype InstancesState = InstancesState { InstancesState -> IORef (Map ContractInstanceId InstanceState)
getInstancesState :: IORef (Map ContractInstanceId InstanceState) }

-- | Initialise the 'InstancesState' with an empty value
emptyInstancesState :: IO InstancesState
emptyInstancesState :: IO InstancesState
emptyInstancesState = IORef (Map ContractInstanceId InstanceState) -> InstancesState
InstancesState (IORef (Map ContractInstanceId InstanceState) -> InstancesState)
-> IO (IORef (Map ContractInstanceId InstanceState))
-> IO InstancesState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map ContractInstanceId InstanceState
-> IO (IORef (Map ContractInstanceId InstanceState))
forall a. a -> IO (IORef a)
IORef.newIORef Map ContractInstanceId InstanceState
forall a. Monoid a => a
mempty

-- | The IDs of all contract instances
instanceIDs :: InstancesState -> IO (Set ContractInstanceId)
instanceIDs :: InstancesState -> IO (Set ContractInstanceId)
instanceIDs (InstancesState IORef (Map ContractInstanceId InstanceState)
m) = Map ContractInstanceId InstanceState -> Set ContractInstanceId
forall k a. Map k a -> Set k
Map.keysSet (Map ContractInstanceId InstanceState -> Set ContractInstanceId)
-> IO (Map ContractInstanceId InstanceState)
-> IO (Set ContractInstanceId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map ContractInstanceId InstanceState)
-> IO (Map ContractInstanceId InstanceState)
forall a. IORef a -> IO a
IORef.readIORef IORef (Map ContractInstanceId InstanceState)
m

-- | The 'InstanceState' of the contract instance. Retries if the state can't
--   be found in the map.
instanceState :: ContractInstanceId -> InstancesState -> IO (Maybe InstanceState)
instanceState :: ContractInstanceId -> InstancesState -> IO (Maybe InstanceState)
instanceState ContractInstanceId
instanceId (InstancesState IORef (Map ContractInstanceId InstanceState)
m) = do
    Map ContractInstanceId InstanceState
mp <- IORef (Map ContractInstanceId InstanceState)
-> IO (Map ContractInstanceId InstanceState)
forall a. IORef a -> IO a
IORef.readIORef IORef (Map ContractInstanceId InstanceState)
m
    Maybe InstanceState -> IO (Maybe InstanceState)
forall (m :: * -> *) a. Monad m => a -> m a
return (ContractInstanceId
-> Map ContractInstanceId InstanceState -> Maybe InstanceState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ContractInstanceId
instanceId Map ContractInstanceId InstanceState
mp)

-- | Get the observable state of the contract instance. Blocks if the
--   state is not available yet.
observableContractState :: InstanceState -> STM Value
observableContractState :: InstanceState -> STM Value
observableContractState InstanceState{TVar (Maybe Value)
issObservableState :: TVar (Maybe Value)
issObservableState :: InstanceState -> TVar (Maybe Value)
issObservableState} = do
    Maybe Value
v <- TVar (Maybe Value) -> STM (Maybe Value)
forall a. TVar a -> STM a
STM.readTVar TVar (Maybe Value)
issObservableState
    STM Value -> (Value -> STM Value) -> Maybe Value -> STM Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe STM Value
forall (f :: * -> *) a. Alternative f => f a
empty Value -> STM Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Value
v

-- | Return the final state of the contract when it is finished (possibly an
--   error)
finalResult :: InstanceState -> STM (Maybe Value)
finalResult :: InstanceState -> STM (Maybe Value)
finalResult InstanceState{TVar Activity
issStatus :: TVar Activity
issStatus :: InstanceState -> TVar Activity
issStatus} = do
    Activity
v <- TVar Activity -> STM Activity
forall a. TVar a -> STM a
STM.readTVar TVar Activity
issStatus
    case Activity
v of
        Done Maybe Value
r  -> Maybe Value -> STM (Maybe Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Value
r
        Activity
Stopped -> Maybe Value -> STM (Maybe Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Value
forall a. Maybe a
Nothing
        Activity
_       -> STM (Maybe Value)
forall (f :: * -> *) a. Alternative f => f a
empty

-- | Insert an 'InstanceState' value into the 'InstancesState'
insertInstance :: ContractInstanceId -> InstanceState -> InstancesState -> IO ()
insertInstance :: ContractInstanceId -> InstanceState -> InstancesState -> IO ()
insertInstance ContractInstanceId
instanceID InstanceState
state (InstancesState IORef (Map ContractInstanceId InstanceState)
m) = IORef (Map ContractInstanceId InstanceState)
-> (Map ContractInstanceId InstanceState
    -> Map ContractInstanceId InstanceState)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
IORef.modifyIORef' IORef (Map ContractInstanceId InstanceState)
m (ContractInstanceId
-> InstanceState
-> Map ContractInstanceId InstanceState
-> Map ContractInstanceId InstanceState
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ContractInstanceId
instanceID InstanceState
state)

-- | Delete an instance from the 'InstancesState'
removeInstance :: ContractInstanceId -> InstancesState -> IO ()
removeInstance :: ContractInstanceId -> InstancesState -> IO ()
removeInstance ContractInstanceId
instanceID (InstancesState IORef (Map ContractInstanceId InstanceState)
m) = IORef (Map ContractInstanceId InstanceState)
-> (Map ContractInstanceId InstanceState
    -> Map ContractInstanceId InstanceState)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
IORef.modifyIORef' IORef (Map ContractInstanceId InstanceState)
m (ContractInstanceId
-> Map ContractInstanceId InstanceState
-> Map ContractInstanceId InstanceState
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete ContractInstanceId
instanceID)

-- | Wait for the status of a transaction to change.
waitForTxStatusChange
  :: TxStatus -> TxId -> BlockchainEnv -> STM TxStatus
waitForTxStatusChange :: TxStatus -> TxId -> BlockchainEnv -> STM TxStatus
waitForTxStatusChange TxStatus
oldStatus TxId
tx BlockchainEnv{Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges :: Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges :: BlockchainEnv
-> Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges, TVar BlockNumber
beLastSyncedBlockNo :: TVar BlockNumber
beLastSyncedBlockNo :: BlockchainEnv -> TVar BlockNumber
beLastSyncedBlockNo} = do
    case Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges of
      Left TVar (UtxoIndex TxIdState)
ix -> do
        BlockNumber
blockNumber <- TVar BlockNumber -> STM BlockNumber
forall a. TVar a -> STM a
STM.readTVar TVar BlockNumber
beLastSyncedBlockNo
        TxIdState
txIdState <- UtxoState TxIdState -> TxIdState
forall a. UtxoState a -> a
_usTxUtxoData (UtxoState TxIdState -> TxIdState)
-> (UtxoIndex TxIdState -> UtxoState TxIdState)
-> UtxoIndex TxIdState
-> TxIdState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UtxoIndex TxIdState -> UtxoState TxIdState
forall a. Monoid a => UtxoIndex a -> UtxoState a
utxoState (UtxoIndex TxIdState -> TxIdState)
-> STM (UtxoIndex TxIdState) -> STM TxIdState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (UtxoIndex TxIdState) -> STM (UtxoIndex TxIdState)
forall a. TVar a -> STM a
STM.readTVar TVar (UtxoIndex TxIdState)
ix
        let txStatus :: Either TxStatusFailure TxStatus
txStatus  = BlockNumber -> TxIdState -> TxId -> Either TxStatusFailure TxStatus
transactionStatus BlockNumber
blockNumber TxIdState
txIdState TxId
tx
        -- Succeed only if we _found_ a status and it was different; if
        -- the status hasn't changed, _or_ there was an error computing
        -- the status, keep retrying.
        case Either TxStatusFailure TxStatus
txStatus of
          Right TxStatus
s | TxStatus
s TxStatus -> TxStatus -> Bool
forall a. Eq a => a -> a -> Bool
/= TxStatus
oldStatus -> TxStatus -> STM TxStatus
forall (f :: * -> *) a. Applicative f => a -> f a
pure TxStatus
s
          Either TxStatusFailure TxStatus
_                        -> STM TxStatus
forall (f :: * -> *) a. Alternative f => f a
empty
      -- This branch gets intercepted in `processTxStatusChangeRequestIO` and
      -- handled separateley, so we should never reach this place.
      Right IORef TCSIndex
_ ->
          String -> STM TxStatus
forall a. HasCallStack => String -> a
error String
"waitForTxStatusChange called without the STM index available"

-- | Wait for the status of a transaction output to change.
waitForTxOutStatusChange :: TxOutStatus -> TxOutRef -> BlockchainEnv -> STM TxOutStatus
waitForTxOutStatusChange :: TxOutStatus -> TxOutRef -> BlockchainEnv -> STM TxOutStatus
waitForTxOutStatusChange TxOutStatus
oldStatus TxOutRef
txOutRef BlockchainEnv{Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges :: Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges :: BlockchainEnv
-> Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges, TVar (UtxoIndex TxOutBalance)
beTxOutChanges :: TVar (UtxoIndex TxOutBalance)
beTxOutChanges :: BlockchainEnv -> TVar (UtxoIndex TxOutBalance)
beTxOutChanges, TVar BlockNumber
beLastSyncedBlockNo :: TVar BlockNumber
beLastSyncedBlockNo :: BlockchainEnv -> TVar BlockNumber
beLastSyncedBlockNo} = do
    case Either (TVar (UtxoIndex TxIdState)) (IORef TCSIndex)
beTxChanges of
      Left TVar (UtxoIndex TxIdState)
txChanges -> do
        TxIdState
txIdState    <- UtxoState TxIdState -> TxIdState
forall a. UtxoState a -> a
_usTxUtxoData (UtxoState TxIdState -> TxIdState)
-> (UtxoIndex TxIdState -> UtxoState TxIdState)
-> UtxoIndex TxIdState
-> TxIdState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UtxoIndex TxIdState -> UtxoState TxIdState
forall a. Monoid a => UtxoIndex a -> UtxoState a
utxoState (UtxoIndex TxIdState -> TxIdState)
-> STM (UtxoIndex TxIdState) -> STM TxIdState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (UtxoIndex TxIdState) -> STM (UtxoIndex TxIdState)
forall a. TVar a -> STM a
STM.readTVar TVar (UtxoIndex TxIdState)
txChanges
        TxOutBalance
txOutBalance <- UtxoState TxOutBalance -> TxOutBalance
forall a. UtxoState a -> a
_usTxUtxoData (UtxoState TxOutBalance -> TxOutBalance)
-> (UtxoIndex TxOutBalance -> UtxoState TxOutBalance)
-> UtxoIndex TxOutBalance
-> TxOutBalance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UtxoIndex TxOutBalance -> UtxoState TxOutBalance
forall a. Monoid a => UtxoIndex a -> UtxoState a
utxoState (UtxoIndex TxOutBalance -> TxOutBalance)
-> STM (UtxoIndex TxOutBalance) -> STM TxOutBalance
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (UtxoIndex TxOutBalance) -> STM (UtxoIndex TxOutBalance)
forall a. TVar a -> STM a
STM.readTVar TVar (UtxoIndex TxOutBalance)
beTxOutChanges
        BlockNumber
blockNumber  <- TVar BlockNumber -> STM BlockNumber
forall a. TVar a -> STM a
STM.readTVar TVar BlockNumber
beLastSyncedBlockNo
        let txOutStatus :: Either TxStatusFailure TxOutStatus
txOutStatus = BlockNumber
-> TxIdState
-> TxOutBalance
-> TxOutRef
-> Either TxStatusFailure TxOutStatus
transactionOutputStatus BlockNumber
blockNumber TxIdState
txIdState TxOutBalance
txOutBalance TxOutRef
txOutRef
        -- Succeed only if we _found_ a status and it was different; if
        -- the status hasn't changed, _or_ there was an error computing
        -- the status, keep retrying.
        case Either TxStatusFailure TxOutStatus
txOutStatus of
          Right TxOutStatus
s | TxOutStatus
s TxOutStatus -> TxOutStatus -> Bool
forall a. Eq a => a -> a -> Bool
/= TxOutStatus
oldStatus -> TxOutStatus -> STM TxOutStatus
forall (f :: * -> *) a. Applicative f => a -> f a
pure TxOutStatus
s
          Either TxStatusFailure TxOutStatus
_                        -> STM TxOutStatus
forall (f :: * -> *) a. Alternative f => f a
empty
      -- This branch gets intercepted in `processTxOutStatusChangeRequestIO` and
      -- handled separateley, so we should never reach this place.
      Right IORef TCSIndex
_ ->
          String -> STM TxOutStatus
forall a. HasCallStack => String -> a
error String
"waitForTxOutStatusChange called without the STM index available"

-- | The current slot number
currentSlot :: BlockchainEnv -> STM Slot
currentSlot :: BlockchainEnv -> STM Slot
currentSlot BlockchainEnv{TVar Slot
beCurrentSlot :: TVar Slot
beCurrentSlot :: BlockchainEnv -> TVar Slot
beCurrentSlot} = TVar Slot -> STM Slot
forall a. TVar a -> STM a
STM.readTVar TVar Slot
beCurrentSlot

lastSyncedBlockSlot :: BlockchainEnv -> STM Slot
lastSyncedBlockSlot :: BlockchainEnv -> STM Slot
lastSyncedBlockSlot BlockchainEnv{TVar Slot
beLastSyncedBlockSlot :: TVar Slot
beLastSyncedBlockSlot :: BlockchainEnv -> TVar Slot
beLastSyncedBlockSlot} = TVar Slot -> STM Slot
forall a. TVar a -> STM a
STM.readTVar TVar Slot
beLastSyncedBlockSlot

-- | The IDs of contract instances with their statuses
instancesWithStatuses :: InstancesState -> IO (STM (Map ContractInstanceId Wallet.ContractActivityStatus))
instancesWithStatuses :: InstancesState
-> IO (STM (Map ContractInstanceId ContractActivityStatus))
instancesWithStatuses (InstancesState IORef (Map ContractInstanceId InstanceState)
m) = do
    let parseStatus :: Activity -> Wallet.ContractActivityStatus
        parseStatus :: Activity -> ContractActivityStatus
parseStatus = \case
            Activity
Active  -> ContractActivityStatus
Wallet.Active
            Activity
Stopped -> ContractActivityStatus
Wallet.Stopped
            Done Maybe Value
_  -> ContractActivityStatus
Wallet.Done
    let flt :: InstanceState -> STM Wallet.ContractActivityStatus
        flt :: InstanceState -> STM ContractActivityStatus
flt InstanceState{TVar Activity
issStatus :: TVar Activity
issStatus :: InstanceState -> TVar Activity
issStatus} = do
            Activity
status <- TVar Activity -> STM Activity
forall a. TVar a -> STM a
STM.readTVar TVar Activity
issStatus
            ContractActivityStatus -> STM ContractActivityStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (ContractActivityStatus -> STM ContractActivityStatus)
-> ContractActivityStatus -> STM ContractActivityStatus
forall a b. (a -> b) -> a -> b
$ Activity -> ContractActivityStatus
parseStatus Activity
status
    Map ContractInstanceId InstanceState
mp <- IORef (Map ContractInstanceId InstanceState)
-> IO (Map ContractInstanceId InstanceState)
forall a. IORef a -> IO a
IORef.readIORef IORef (Map ContractInstanceId InstanceState)
m
    STM (Map ContractInstanceId ContractActivityStatus)
-> IO (STM (Map ContractInstanceId ContractActivityStatus))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((InstanceState -> STM ContractActivityStatus)
-> Map ContractInstanceId InstanceState
-> STM (Map ContractInstanceId ContractActivityStatus)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse InstanceState -> STM ContractActivityStatus
flt Map ContractInstanceId InstanceState
mp)