Add script UTxOs to MarloweContext and MarloweScripts

marlowe-chain-sync/marlowe-chain-sync.cabal

@@ -97,6 +97,7 @@ library
     , plutus-ledger-api
     , profunctors
     , serialise
+    , split
     , stm
     , stm-delay
     , text

marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Api.hs

@@ -62,6 +62,7 @@ module Language.Marlowe.Runtime.ChainSync.Api
   , getUTCTime
   , isAfter
   , moveSchema
+  , parseTxOutRef
   , paymentCredential
   , putUTCTime
   , runtimeChainSeekCodec
@@ -103,8 +104,10 @@ import Data.ByteString (ByteString)
 import Data.ByteString.Base16 (decodeBase16, encodeBase16)
 import qualified Data.ByteString.Lazy as LBS
 import Data.Function (on)
+import Data.List.Split (splitOn)
 import Data.Map (Map)
 import qualified Data.Map as Map
+import Data.Maybe (fromJust)
 import Data.Set (Set)
 import Data.String (IsString(..))
 import Data.Text (Text)
@@ -136,6 +139,7 @@ import qualified Network.Protocol.Job.Types as Job
 import qualified Network.Protocol.Query.Types as Query
 import Network.TypedProtocol.Codec (Codec)
 import qualified Plutus.V1.Ledger.Api as Plutus
+import Text.Read (readMaybe)
 
 -- | Extends a type with a "Genesis" member.
 data WithGenesis a = Genesis | At a
@@ -310,6 +314,16 @@ data TxOutRef = TxOutRef
   deriving stock (Show, Eq, Ord, Generic)
   deriving anyclass (Binary)
 
+instance IsString TxOutRef where
+  fromString = fromJust . parseTxOutRef
+
+parseTxOutRef :: String -> Maybe TxOutRef
+parseTxOutRef val = case splitOn "#" val of
+  [txId, txIx] -> TxOutRef
+    <$> (TxId <$> either (const Nothing) Just (decodeBase16 $ encodeUtf8 $ T.pack txId))
+    <*> (TxIx <$> readMaybe txIx)
+  _ -> Nothing
+
 newtype SlotNo = SlotNo { unSlotNo :: Word64 }
   deriving stock (Show, Eq, Ord, Generic)
   deriving newtype (Num, Integral, Real, Enum, Bounded, Binary)

marlowe-runtime/marlowe-runtime.cabal

@@ -103,7 +103,6 @@ library
     , plutus-ledger-api
     , semialign
     , some
-    , split
     , stm
     , text
     , these

marlowe-runtime/marlowe-tx/Main.hs

@@ -19,6 +19,7 @@ import Language.Marlowe.Runtime.ChainSync.Api
   )
 import Language.Marlowe.Runtime.Transaction.Constraints (SolveConstraints)
 import qualified Language.Marlowe.Runtime.Transaction.Constraints as Constraints
+import Language.Marlowe.Runtime.Transaction.Query (LoadMarloweContext)
 import qualified Language.Marlowe.Runtime.Transaction.Query as Query
 import Language.Marlowe.Runtime.Transaction.Server
   (RunTransactionServer(..), TransactionServer(..), TransactionServerDependencies(..), mkTransactionServer)
@@ -120,14 +121,16 @@ run Options{..} = withSocketsDo do
     slotConfig <- queryChainSync GetSlotConfig
     networkId <- queryChainSync GetNetworkId
     let
-      solveConstraints :: forall era v. SolveConstraints era v
+      solveConstraints :: forall v. SolveConstraints v
       solveConstraints = Constraints.solveConstraints
         networkId
         systemStart
         eraHistory
         protocolParameters
     let loadWalletContext = Query.loadWalletContext
-    let loadMarloweContext = Query.loadMarloweContext runHistorySyncClient
+    let
+      loadMarloweContext :: LoadMarloweContext
+      loadMarloweContext = Query.loadMarloweContext networkId runHistorySyncClient
     TransactionServer{..} <- atomically do
       mkTransactionServer TransactionServerDependencies{..}
 

marlowe-runtime/src/Language/Marlowe/Runtime/Core/Api.hs

@@ -17,9 +17,9 @@ import Data.Binary (Binary(..), Get, Put)
 import Data.Binary.Get (getWord32be)
 import Data.Binary.Put (putWord32be)
 import Data.ByteString.Base16 (decodeBase16, encodeBase16)
-import Data.List.Split (splitOn)
 import Data.Map (Map)
 import Data.Maybe (fromMaybe)
+import Data.String (IsString)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
@@ -29,7 +29,7 @@ import GHC.Generics (Generic)
 import qualified Language.Marlowe.Core.V1.Semantics as V1
 import qualified Language.Marlowe.Core.V1.Semantics.Types as V1
 import Language.Marlowe.Runtime.ChainSync.Api
-  (BlockHeader, TokenName(..), TxId(..), TxIx(..), TxOutRef(..), getUTCTime, putUTCTime, unPolicyId)
+  (BlockHeader, TokenName(..), TxId(..), TxIx(..), TxOutRef(..), getUTCTime, parseTxOutRef, putUTCTime, unPolicyId)
 import qualified Language.Marlowe.Runtime.ChainSync.Api as Chain
 import qualified Plutus.V1.Ledger.Api as Plutus
 import qualified Plutus.V1.Ledger.Value as Plutus
@@ -39,15 +39,9 @@ import Text.Read (readMaybe)
 -- the contract.
 newtype ContractId = ContractId { unContractId :: TxOutRef }
   deriving stock (Show, Eq, Ord, Generic)
+  deriving newtype (IsString)
   deriving anyclass (Binary)
 
-parseTxOutRef :: String -> Maybe TxOutRef
-parseTxOutRef val = case splitOn "#" val of
-  [txId, txIx] -> TxOutRef
-    <$> (TxId <$> either (const Nothing) Just (decodeBase16 $ encodeUtf8 $ T.pack txId))
-    <*> (TxIx <$> readMaybe txIx)
-  _ -> Nothing
-
 renderTxOutRef :: TxOutRef -> Text
 renderTxOutRef TxOutRef{..} = mconcat
   [ encodeBase16 $ unTxId txId

marlowe-runtime/src/Language/Marlowe/Runtime/Core/ScriptRegistry.hs

@@ -3,20 +3,36 @@
 module Language.Marlowe.Runtime.Core.ScriptRegistry
   where
 
+import Cardano.Api (NetworkId(..), NetworkMagic(NetworkMagic))
+import Data.Bifunctor (Bifunctor(first))
 import Data.Foldable (asum)
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
-import Language.Marlowe.Runtime.ChainSync.Api (ScriptHash)
+import Language.Marlowe.Runtime.ChainSync.Api (ScriptHash, TxOutRef)
 import Language.Marlowe.Runtime.Core.Api
 
+newtype NetworkIdWithOrd = NetworkIdWithOrd NetworkId
+  deriving (Eq, Show)
+
+instance Ord NetworkIdWithOrd where
+  compare (NetworkIdWithOrd Mainnet) (NetworkIdWithOrd Mainnet) = EQ
+  compare (NetworkIdWithOrd Mainnet) (NetworkIdWithOrd _) = LT
+  compare (NetworkIdWithOrd _) (NetworkIdWithOrd Mainnet) = GT
+  compare (NetworkIdWithOrd (Testnet (NetworkMagic a))) (NetworkIdWithOrd (Testnet (NetworkMagic b))) =
+    compare a b
+
 -- | A set of script hashes for a marlowe version.
 data MarloweScripts = MarloweScripts
   { marloweScript :: ScriptHash
   , payoutScript :: ScriptHash
+  , marloweScriptUTxOs :: Map NetworkIdWithOrd TxOutRef
+  , payoutScriptUTxOs :: Map NetworkIdWithOrd TxOutRef
   } deriving (Show, Eq, Ord)
 
+previewNetworkId = NetworkIdWithOrd $ Testnet $ NetworkMagic 2
+
 -- | The current pair of static script hashes for Marlowe V1 as of the current git
 -- commit. Enforced in the test suite for the Marlowe Runtime.
 --
@@ -28,6 +44,14 @@ currentV1Scripts :: MarloweScripts
 currentV1Scripts = MarloweScripts
   "6a9391d6aa51af28dd876ebb5565b69d1e83e5ac7861506bd29b56b0"
   "49076eab20243dc9462511fb98a9cfb719f86e9692288139b7c91df3"
+  ( Map.fromList
+      [ (previewNetworkId, "087f21f109a997193421a81886ea8c6397d336d19e696457b9c5c7aefdc31873#1")
+      ]
+  )
+  ( Map.fromList
+      [ (previewNetworkId, "087f21f109a997193421a81886ea8c6397d336d19e696457b9c5c7aefdc31873#2")
+      ]
+  )
 
 -- | The set of known script hash sets for Marlowe V1.
 v1Scripts :: Set MarloweScripts