Add an endpoint to check for TxConfirmationStatus

plutus-chain-index/src/Plutus/ChainIndex/Types.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveAnyClass    #-}
 {-# LANGUAGE DerivingVia       #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
@@ -45,6 +46,7 @@ import qualified Data.ByteString.Lazy             as BSL
 import           Data.Map                         (Map)
 import qualified Data.Map                         as Map
 import           Data.Monoid                      (Last (..), Sum (..))
+import           Data.OpenApi.Schema              (ToSchema)
 import           Data.Semigroup.Generic           (GenericSemigroupMonoid (..))
 import           Data.Set                         (Set)
 import qualified Data.Set                         as Set
@@ -143,7 +145,7 @@ instance Pretty Tip where
 -- | Validity of a transaction that has been added to the ledger
 data TxValidity = TxValid | TxInvalid | UnknownValidity
   deriving stock (Eq, Ord, Show, Generic)
-  deriving anyclass (ToJSON, FromJSON)
+  deriving anyclass (ToJSON, FromJSON, ToSchema)
   deriving Pretty via (PrettyShow TxValidity)
 
 instance MeetSemiLattice TxValidity where
@@ -237,7 +239,7 @@ liftTxOutStatus = void
 
 newtype BlockNumber = BlockNumber { unBlockNumber :: Word64 }
     deriving stock (Eq, Ord, Show, Generic)
-    deriving newtype (Num, Real, Enum, Integral, Pretty, ToJSON, FromJSON)
+    deriving newtype (Num, Real, Enum, Integral, Pretty, ToJSON, FromJSON, ToSchema)
 
 data Diagnostics =
     Diagnostics
@@ -285,13 +287,17 @@ instance Monoid TxIdState where
     mappend = (<>)
     mempty  = TxIdState { txnsConfirmed=mempty, txnsDeleted=mempty }
 
+deriving newtype instance ToJSON (Sum Int)
+deriving newtype instance FromJSON (Sum Int)
+
 data TxConfirmedState =
   TxConfirmedState
     { timesConfirmed :: Sum Int
     , blockAdded     :: Last BlockNumber
     , validity       :: Last TxValidity
     }
     deriving stock (Eq, Generic, Show)
+    deriving anyclass (FromJSON, ToJSON, ToSchema)
     deriving (Semigroup, Monoid) via (GenericSemigroupMonoid TxConfirmedState)
 
 -- | The effect of a transaction (or a number of them) on the tx output set.

plutus-chain-index/src/Plutus/ChainIndex/UtxoState.hs

@@ -49,6 +49,8 @@ import           Plutus.ChainIndex.ChainIndexLog   (InsertUtxoPosition (..))
 import           Plutus.ChainIndex.Types           (Depth (..), Point (..), Tip (..), pointsToTip)
 import           Prettyprinter                     (Pretty (..))
 
+import qualified Debug.Trace                       as Debug
+
 -- | UTXO / ledger state, kept in memory. We are only interested in the UTXO set, everything else is stored
 --   on disk. This is OK because we don't need to validate transactions when they come in.
 data UtxoState a =
@@ -93,6 +95,23 @@ instance Pretty (InsertUtxoSuccess a) where
   pretty = \case
     InsertUtxoSuccess _ insertPosition -> pretty insertPosition
 
+gcIndex ::
+   ( Monoid a )
+  => Int
+  -> UtxoIndex a
+  -> UtxoIndex a
+gcIndex kParameter ix
+  | FT.null ix = ix
+  | otherwise  =
+      let (l FT.:< _) = FT.viewl ix
+          (_ FT.:> r) = FT.viewr ix
+          (BlockCount lb) = fst $ FT.measure l
+          (BlockCount rb) = fst $ FT.measure r
+      in  if (rb - lb) > kParameter * 2
+             then Debug.trace "Doing GC" $ FT.dropUntil
+                   (\(BlockCount cnt, _) -> rb - cnt <= kParameter) ix
+             else ix
+
 -- | Insert a 'UtxoState' into the index
 insert ::
        ( Monoid a
@@ -103,8 +122,9 @@ insert ::
        -> Either InsertUtxoFailed (InsertUtxoSuccess a)
 insert   UtxoState{_usTip=TipAtGenesis} _ = Left InsertUtxoNoTip
 insert s@UtxoState{_usTip=thisTip} ix =
-    let (before, after) = FT.split ((s <=) . snd) ix
-    in case tip (utxoState after) of
+    let ix'             = gcIndex 100 ix
+        (before, after) = FT.split ((s <=) . snd) ix'
+    in case Debug.trace ("Processing " <> show thisTip) $ tip (utxoState after) of
         TipAtGenesis -> Right $ InsertUtxoSuccess{newIndex = before FT.|> s, insertPosition = InsertAtEnd}
         t | t > thisTip -> Right $ InsertUtxoSuccess{newIndex = (before FT.|> s) <> after, insertPosition = InsertBeforeEnd}
           | otherwise   -> Left  $ DuplicateBlock t

plutus-pab/src/Plutus/PAB/Run/PSGenerator.hs

@@ -31,6 +31,7 @@ import           Language.PureScript.Bridge.CodeGenSwitches (ForeignOptions (For
                                                              unwrapSingleConstructors)
 import           Language.PureScript.Bridge.TypeParameters  (A, B)
 import qualified PSGenerator.Common
+import           Plutus.ChainIndex.Types                    (TxConfirmedState)
 import           Plutus.Contract.Checkpoint                 (CheckpointKey, CheckpointStore, CheckpointStoreItem)
 import           Plutus.Contract.Resumable                  (Responses)
 import           Plutus.Contract.StateMachine               (InvalidTransition, SMContractError)
@@ -107,6 +108,7 @@ pabTypes =
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @(ContractActivationArgs A))
     , (genericShow <*> mkSumType) (Proxy @(ContractInstanceClientState A))
     , (genericShow <*> mkSumType) (Proxy @InstanceStatusToClient)
+    , (genericShow <*> mkSumType) (Proxy @TxConfirmedState)
     , (genericShow <*> mkSumType) (Proxy @CombinedWSStreamToClient)
     , (genericShow <*> mkSumType) (Proxy @CombinedWSStreamToServer)
     , (genericShow <*> mkSumType) (Proxy @WalletInfo)

plutus-pab/src/Plutus/PAB/Webserver/API.hs

@@ -14,6 +14,8 @@ module Plutus.PAB.Webserver.API
 import qualified Cardano.Wallet.Mock.API    as Wallet
 import qualified Data.Aeson                 as JSON
 import           Data.Text                  (Text)
+import           Ledger.TxId                (TxId)
+import           Plutus.ChainIndex.Types    (TxConfirmedState)
 import           Plutus.PAB.Webserver.Types (ContractActivationArgs, ContractInstanceClientState,
                                              ContractSignatureResponse, FullReport)
 import           Servant.API                (Capture, Description, Get, JSON, Post, Put, QueryParam, ReqBody, (:<|>),
@@ -34,6 +36,7 @@ type WSAPI =
 --   * "Builtin" contracts that run in the same process as the PAB (ie. the PAB is compiled & distributed with these contracts)
 type API t walletId -- see note [WalletID type in wallet API]
     = "api" :> ("healthcheck" :> Description "Is the server alive?" :> Get '[JSON] ()
+    :<|> "tx-status" :> ReqBody '[JSON] TxId :> Post '[JSON] (Maybe TxConfirmedState)
     :<|> ("fullreport" :> Description "Details of the contracts: the signatures and their states." :> Get '[JSON] (FullReport t))
     :<|> "contract" :> ("activate" :> ReqBody '[JSON] (ContractActivationArgs t) :> Description "Start a new instance." :> Post '[JSON] ContractInstanceId
             :<|> "instance" :>

plutus-pab/src/Plutus/PAB/Webserver/Client.hs

@@ -12,6 +12,8 @@ import           Data.Aeson                 (FromJSON, ToJSON (..))
 import qualified Data.Aeson                 as JSON
 import           Data.Proxy
 import           Data.Text                  (Text)
+import           Ledger                     (TxId)
+import           Plutus.ChainIndex.Types    (TxConfirmedState)
 import           Plutus.PAB.Events.Contract
 import           Plutus.PAB.Instances       ()
 import           Plutus.PAB.Webserver.API
@@ -21,19 +23,21 @@ import           Servant.Client
 
 -- | Client for PAB. The first type-argument is contract type that is used for PAB-simulator.
 data PabClient t walletId = PabClient
-  { healthcheck      :: ClientM ()
+  { healthcheck         :: ClientM ()
       -- ^ call healthcheck method
-  , fullreport       :: ClientM (FullReport t)
+  , getTxConfirmedState :: TxId -> ClientM (Maybe TxConfirmedState)
+      -- ^ Inspect the cofirmation status of a transaction
+  , fullreport          :: ClientM (FullReport t)
       -- ^ call fullreport method
-  , activateContract :: ContractActivationArgs t -> ClientM ContractInstanceId
+  , activateContract    :: ContractActivationArgs t -> ClientM ContractInstanceId
       -- ^ call activate contract method
-  , instanceClient   :: ContractInstanceId -> InstanceClient t
+  , instanceClient      :: ContractInstanceId -> InstanceClient t
       -- ^ call methods for instance client. We should turn @ContractInstanceId@ to @Text@ for the first argument.
-  , getWallet        :: walletId -> Maybe Text -> ClientM [ContractInstanceClientState t]
+  , getWallet           :: walletId -> Maybe Text -> ClientM [ContractInstanceClientState t]
       -- ^ get wallet instances
-  , getInstances     :: Maybe Text -> ClientM [ContractInstanceClientState t]
+  , getInstances        :: Maybe Text -> ClientM [ContractInstanceClientState t]
       -- ^ get instances
-  , getDefinitions   :: ClientM [ContractSignatureResponse t]
+  , getDefinitions      :: ClientM [ContractSignatureResponse t]
       -- ^ get definitions
   }
 
@@ -54,6 +58,7 @@ pabClient :: forall t walletId. (ToJSON t, FromJSON t, ToHttpApiData walletId) =
 pabClient = PabClient{..}
   where
     (healthcheck
+      :<|> getTxConfirmedState
       :<|> fullreport
       :<|> activateContract
       :<|> toInstanceClient

plutus-pab/src/Plutus/PAB/Webserver/Handler.hs

@@ -26,7 +26,9 @@ module Plutus.PAB.Webserver.Handler
 
 import qualified Cardano.Wallet.Mock.Client              as Wallet.Client
 import           Cardano.Wallet.Mock.Types               (WalletInfo (..))
-import           Control.Lens                            (preview)
+import           Control.Concurrent.STM                  (atomically)
+import           Control.Concurrent.STM.TVar             (readTVar)
+import           Control.Lens                            (at, preview, view)
 import           Control.Monad                           (join)
 import           Control.Monad.Freer                     (sendM)
 import           Control.Monad.Freer.Error               (throwError)
@@ -39,12 +41,15 @@ import           Data.Maybe                              (fromMaybe, mapMaybe)
 import           Data.OpenApi.Schema                     (ToSchema)
 import           Data.Proxy                              (Proxy (..))
 import           Data.Text                               (Text)
-import           Ledger                                  (Value)
+import           Ledger                                  (TxId, Value)
 import           Ledger.Constraints.OffChain             (UnbalancedTx)
 import           Ledger.Tx                               (Tx)
+import           Plutus.ChainIndex.Types                 (TxConfirmedState, TxIdState (..))
+import           Plutus.ChainIndex.UtxoState             (usTxUtxoData, utxoState)
 import           Plutus.Contract.Effects                 (PABReq, _ExposeEndpointReq)
 import           Plutus.PAB.Core                         (PABAction)
 import qualified Plutus.PAB.Core                         as Core
+import           Plutus.PAB.Core.ContractInstance.STM    (BlockchainEnv (..))
 import qualified Plutus.PAB.Effects.Contract             as Contract
 import           Plutus.PAB.Events.ContractInstanceState (PartiallyDecodedResponse (..), fromResp)
 import           Plutus.PAB.Types
@@ -92,6 +97,7 @@ apiHandler ::
        forall t env.
        Contract.PABContract t =>
        PABAction t env ()
+       :<|> (TxId -> PABAction t env (Maybe TxConfirmedState))
        :<|> PABAction t env (FullReport (Contract.ContractDef t))
        :<|> (ContractActivationArgs (Contract.ContractDef t) -> PABAction t env ContractInstanceId)
               :<|> (ContractInstanceId -> PABAction t env (ContractInstanceClientState (Contract.ContractDef t))
@@ -105,6 +111,7 @@ apiHandler ::
 
 apiHandler =
         healthcheck
+        :<|> getTxConfirmedState
         :<|> getFullReport
         :<|> activateContract
               :<|> (\cid -> contractInstanceState cid :<|> contractSchema cid :<|> (\y z -> callEndpoint cid y z) :<|> shutdown cid)
@@ -173,6 +180,16 @@ availableContracts = do
 shutdown :: forall t env. ContractInstanceId -> PABAction t env ()
 shutdown = Core.stopInstance
 
+getTxConfirmedState :: forall t env. TxId -> PABAction t env (Maybe TxConfirmedState)
+getTxConfirmedState txId = do
+    txs <- beTxChanges <$> Core.askBlockchainEnv @t @env
+    liftIO $ atomically $ do
+             view (at txId)
+             . txnsConfirmed
+             . view usTxUtxoData
+             . utxoState
+           <$> readTVar txs
+
 -- | Proxy for the wallet API
 walletProxyClientEnv ::
     forall t env.

plutus-pab/tx-inject/config.yaml

@@ -16,7 +16,8 @@ nodeServerConfig:
   mscBaseUrl: http://localhost:9082
   mscSocketPath: /tmp/node-server.sock
   mscKeptBlocks: 100000
-  mscNetworkId: "1097911063"
+  mscNetworkId: "8"
+  # mscNetworkId: "1097911063"
   mscSlotConfig:
     scSlotZeroTime: 1591566291000 # Wednesday, July 29, 2020 21:44:51 - shelley launch time in milliseconds
     scSlotLength: 1000 # In milliseconds