Add intersection scenario tests

input-output-hk · Feb 7, 2023 · 782603b · 782603b
1 parent 3d7a500
commit 782603b
Show file tree

Hide file tree

Showing 5 changed files with 289 additions and 98 deletions.
diff --git a/marlowe-integration-tests/marlowe-integration-tests.cabal b/marlowe-integration-tests/marlowe-integration-tests.cabal
@@ -57,13 +57,16 @@ executable marlowe-integration-tests
   type: exitcode-stdio-1.0
   main-is: Spec.hs
   other-modules:
-    Language.Marlowe.Runtime.IntegrationSpec
-    Language.Marlowe.Runtime.Integration.Common
     Language.Marlowe.Runtime.Integration.Basic
+    Language.Marlowe.Runtime.Integration.Intersections
+    Language.Marlowe.Runtime.Integration.Common
     Language.Marlowe.Runtime.Integration.StandardContract
+    Language.Marlowe.Runtime.IntegrationSpec
   build-depends:
       base >= 4.9 && < 5
     , aeson
+    , base16
+    , bytestring
     , containers
     , hspec
     , cardano-api
@@ -79,6 +82,7 @@ executable marlowe-integration-tests
     , mtl
     , plutus-ledger-api
     , unliftio
+    , text
     , time
     , transformers
   build-tool-depends: hspec-discover:hspec-discover
diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Basic.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Basic.hs
@@ -2,7 +2,6 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RankNTypes #-}
-{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-}
 
 module Language.Marlowe.Runtime.Integration.Basic
   where
@@ -26,104 +25,103 @@ import Language.Marlowe.Runtime.History.Api (ContractStep(..), RedeemStep(..))
 import Language.Marlowe.Runtime.Integration.Common
 import Language.Marlowe.Runtime.Integration.StandardContract
 import Language.Marlowe.Runtime.Transaction.Api (ContractCreated(..), InputsApplied(..))
-import Test.Hspec (Spec, describe, it, shouldBe)
+import Test.Hspec (Spec, it, shouldBe)
 import Test.Integration.Marlowe.Local (withLocalMarloweRuntime)
 
 spec :: Spec
-spec = describe "Marlowe runtime API" do
-  it "Basic e2e scenario" $ withLocalMarloweRuntime $ runIntegrationTest do
-    partyAWallet <- getGenesisWallet 0
-    partyBWallet <- getGenesisWallet 1
-    let
-      -- 1. Start MarloweHeaderSyncClient (request next)
-      startDiscoveryClient :: Integration TxOutRef
-      startDiscoveryClient = runMarloweHeaderSyncClient
-          $ HeaderSync.MarloweHeaderSyncClient
-          $ pure
-          -- 2. Expect wait
-          $ headerSyncRequestNextExpectWait do
-            -- 3. Create standard contract
-            contract@StandardContractInit{..} <- createStandardContract partyAWallet partyBWallet
-            -- 4. Poll
-            -- 5. Expect new headers
-            headerSyncPollExpectNewHeaders createdBlock [contractCreatedToContractHeader createdBlock contractCreated]
-              $ continueWithNewHeaders contract
+spec = it "Basic e2e scenario" $ withLocalMarloweRuntime $ runIntegrationTest do
+  partyAWallet <- getGenesisWallet 0
+  partyBWallet <- getGenesisWallet 1
+  let
+    -- 1. Start MarloweHeaderSyncClient (request next)
+    startDiscoveryClient :: Integration TxOutRef
+    startDiscoveryClient = runMarloweHeaderSyncClient
+        $ HeaderSync.MarloweHeaderSyncClient
+        $ pure
+        -- 2. Expect wait
+        $ headerSyncRequestNextExpectWait do
+          -- 3. Create standard contract
+          contract@StandardContractInit{..} <- createStandardContract partyAWallet partyBWallet
+          -- 4. Poll
+          -- 5. Expect new headers
+          headerSyncPollExpectNewHeaders createdBlock [contractCreatedToContractHeader createdBlock contractCreated]
+            $ continueWithNewHeaders contract
 
-        -- 6. RequestNext (header sync)
-        -- 7. Expect Wait
-      continueWithNewHeaders contract = pure $ HeaderSync.SendMsgRequestNext $ headerSyncExpectWait do
-        -- 8. Deposit funds
-        fundsDeposited <- makeInitialDeposit contract
-        txOutRef <- runMarloweSyncClient $ marloweSyncClient contract fundsDeposited
-        -- 33. Poll
-        -- 34. Expect wait
-        -- 35. Cancel
-        -- 36. Done
-        pure $ HeaderSync.SendMsgPoll $ headerSyncExpectWait $ pure $ HeaderSync.SendMsgCancel $ HeaderSync.SendMsgDone txOutRef
+      -- 6. RequestNext (header sync)
+      -- 7. Expect Wait
+    continueWithNewHeaders contract = pure $ HeaderSync.SendMsgRequestNext $ headerSyncExpectWait do
+      -- 8. Deposit funds
+      fundsDeposited <- makeInitialDeposit contract
+      txOutRef <- runMarloweSyncClient $ marloweSyncClient contract fundsDeposited
+      -- 33. Poll
+      -- 34. Expect wait
+      -- 35. Cancel
+      -- 36. Done
+      pure $ HeaderSync.SendMsgPoll $ headerSyncExpectWait $ pure $ HeaderSync.SendMsgCancel $ HeaderSync.SendMsgDone txOutRef
 
-      -- 9. Start MarloweSyncClient (follow contract)
-      marloweSyncClient
-        :: StandardContractInit 'V1
-        -> StandardContractFundsDeposited 'V1
-        -> MarloweSync.MarloweSyncClient Integration TxOutRef
-      marloweSyncClient StandardContractInit{..} StandardContractFundsDeposited{..} = MarloweSync.MarloweSyncClient do
-        let ContractCreated{contractId, rolesCurrency} = contractCreated
-        pure
-          $ MarloweSync.SendMsgFollowContract contractId
-          -- 10. Expect contract found
-          $ marloweSyncExpectContractFound \actualBlock MarloweV1 createStep -> do
-            liftIO $ actualBlock `shouldBe` createdBlock
-            liftIO $ createStep `shouldBe` contractCreatedToCreateStep contractCreated
-            -- 11. Request next
-            -- 12. Expect roll forward with deposit
-            marloweSyncRequestNextExpectRollForward initialDepositBlock [ApplyTransaction $ inputsAppliedToTransaction initialDepositBlock initialFundsDeposited] do
-              -- 13. Request next
-              -- 14. Expect wait, poll, expect wait
-              pure $ marloweSyncRequestNextExpectWait $ pure $ marloweSyncPollExpectWait do
-                -- 15. Make choice as party B
-                StandardContractChoiceMade{..} <- chooseGimmeTheMoney
-                -- 16. Poll
-                -- 17. Expect roll forward with choice
-                marloweSyncPollExpectRollForward choiceBlock [ApplyTransaction $ inputsAppliedToTransaction choiceBlock gimmeTheMoneyChosen] do
-                  -- 18. Request next
-                  -- 19. Expect wait
-                  pure $ marloweSyncRequestNextExpectWait do
-                    -- 20. Notify
-                    StandardContractNotified{..} <- sendNotify
+    -- 9. Start MarloweSyncClient (follow contract)
+    marloweSyncClient
+      :: StandardContractInit 'V1
+      -> StandardContractFundsDeposited 'V1
+      -> MarloweSync.MarloweSyncClient Integration TxOutRef
+    marloweSyncClient StandardContractInit{..} StandardContractFundsDeposited{..} = MarloweSync.MarloweSyncClient do
+      let ContractCreated{contractId, rolesCurrency} = contractCreated
+      pure
+        $ MarloweSync.SendMsgFollowContract contractId
+        -- 10. Expect contract found
+        $ marloweSyncExpectContractFound \actualBlock MarloweV1 createStep -> do
+          liftIO $ actualBlock `shouldBe` createdBlock
+          liftIO $ createStep `shouldBe` contractCreatedToCreateStep contractCreated
+          -- 11. Request next
+          -- 12. Expect roll forward with deposit
+          marloweSyncRequestNextExpectRollForward initialDepositBlock [ApplyTransaction $ inputsAppliedToTransaction initialDepositBlock initialFundsDeposited] do
+            -- 13. Request next
+            -- 14. Expect wait, poll, expect wait
+            pure $ marloweSyncRequestNextExpectWait $ pure $ marloweSyncPollExpectWait do
+              -- 15. Make choice as party B
+              StandardContractChoiceMade{..} <- chooseGimmeTheMoney
+              -- 16. Poll
+              -- 17. Expect roll forward with choice
+              marloweSyncPollExpectRollForward choiceBlock [ApplyTransaction $ inputsAppliedToTransaction choiceBlock gimmeTheMoneyChosen] do
+                -- 18. Request next
+                -- 19. Expect wait
+                pure $ marloweSyncRequestNextExpectWait do
+                  -- 20. Notify
+                  StandardContractNotified{..} <- sendNotify
 
-                    -- 21. Deposit as party B
-                    StandardContractClosed{..} <- makeReturnDeposit
+                  -- 21. Deposit as party B
+                  StandardContractClosed{..} <- makeReturnDeposit
 
-                    -- 22. Withdraw as party A
-                    (withdrawTxBody, withdrawBlock) <- withdrawPartyAFunds
+                  -- 22. Withdraw as party A
+                  (withdrawTxBody, withdrawBlock) <- withdrawPartyAFunds
 
-                    -- 23. Poll
-                    -- 24. Expect roll forward with notify
-                    marloweSyncPollExpectRollForward notifiedBlock [ApplyTransaction $ inputsAppliedToTransaction notifiedBlock notified] do
-                      let depositTransaction@Transaction{output = TransactionOutput{payouts}} = inputsAppliedToTransaction returnDepositBlock returnDeposited
-                      -- 25. Request next
-                      -- 26. Expect roll forward with deposit
-                      marloweSyncRequestNextExpectRollForward returnDepositBlock [ApplyTransaction depositTransaction] do
-                        -- 27. Request next
-                        -- 28. Expect roll forward with withdraw
-                        payoutTxOutRef <- expectJust "Failed to extract payout from deposit" case Map.toList payouts of
-                          [(txOutRef, _)] -> Just txOutRef
-                          _ -> Nothing
-                        let withdrawTxId = fromCardanoTxId $ getTxId withdrawTxBody
-                        marloweSyncRequestNextExpectRollForward withdrawBlock [RedeemPayout $ RedeemStep payoutTxOutRef withdrawTxId $ AssetId rolesCurrency "Party A"] do
-                          -- 29. Request next (marlowe sync)
-                          -- 30. Expect wait
-                          -- 31. Cancel
-                          -- 32. Done
-                          let InputsApplied{output} = notified
-                          TransactionScriptOutput{utxo = notifyTxOutRef} <- expectJust "Failed to obtain deposit output" output
-                          pure $ marloweSyncRequestNextExpectWait $ pure $ MarloweSync.SendMsgCancel $ MarloweSync.SendMsgDone notifyTxOutRef
+                  -- 23. Poll
+                  -- 24. Expect roll forward with notify
+                  marloweSyncPollExpectRollForward notifiedBlock [ApplyTransaction $ inputsAppliedToTransaction notifiedBlock notified] do
+                    let depositTransaction@Transaction{output = TransactionOutput{payouts}} = inputsAppliedToTransaction returnDepositBlock returnDeposited
+                    -- 25. Request next
+                    -- 26. Expect roll forward with deposit
+                    marloweSyncRequestNextExpectRollForward returnDepositBlock [ApplyTransaction depositTransaction] do
+                      -- 27. Request next
+                      -- 28. Expect roll forward with withdraw
+                      payoutTxOutRef <- expectJust "Failed to extract payout from deposit" case Map.toList payouts of
+                        [(txOutRef, _)] -> Just txOutRef
+                        _ -> Nothing
+                      let withdrawTxId = fromCardanoTxId $ getTxId withdrawTxBody
+                      marloweSyncRequestNextExpectRollForward withdrawBlock [RedeemPayout $ RedeemStep payoutTxOutRef withdrawTxId $ AssetId rolesCurrency "Party A"] do
+                        -- 29. Request next (marlowe sync)
+                        -- 30. Expect wait
+                        -- 31. Cancel
+                        -- 32. Done
+                        let InputsApplied{output} = notified
+                        TransactionScriptOutput{utxo = notifyTxOutRef} <- expectJust "Failed to obtain deposit output" output
+                        pure $ marloweSyncRequestNextExpectWait $ pure $ MarloweSync.SendMsgCancel $ MarloweSync.SendMsgDone notifyTxOutRef
 
 
-    txOutRef <- startDiscoveryClient
-    -- 37. Start MarloweSyncClient (follow a tx in the contract)
-    -- 38. Expect contract not found
-    runMarloweSyncClient $ MarloweSync.MarloweSyncClient $ pure $ MarloweSync.SendMsgFollowContract (ContractId txOutRef) $ MarloweSync.ClientStFollow
-      { recvMsgContractFound = \_ _ _ -> fail "Expected contract not found, got contract found"
-      , recvMsgContractNotFound = pure ()
-      }
+  txOutRef <- startDiscoveryClient
+  -- 37. Start MarloweSyncClient (follow a tx in the contract)
+  -- 38. Expect contract not found
+  runMarloweSyncClient $ MarloweSync.MarloweSyncClient $ pure $ MarloweSync.SendMsgFollowContract (ContractId txOutRef) $ MarloweSync.ClientStFollow
+    { recvMsgContractFound = \_ _ _ -> fail "Expected contract not found, got contract found"
+    , recvMsgContractNotFound = pure ()
+    }
diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Common.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Common.hs
@@ -21,12 +21,20 @@ import Control.Concurrent (threadDelay)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Control.Monad.Reader (ReaderT, runReaderT)
 import Control.Monad.Reader.Class (asks)
-import Data.Aeson (decodeFileStrict)
+import Data.Aeson (FromJSON(..), Value(..), decodeFileStrict, eitherDecodeStrict)
+import Data.Aeson.Types (parseFail)
 import Data.Bifunctor (first)
+import Data.ByteString (ByteString)
+import Data.ByteString.Base16 (decodeBase16)
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.String (fromString)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import qualified Data.Text.Encoding as T
 import Data.Time (NominalDiffTime, diffUTCTime, getCurrentTime, secondsToNominalDiffTime)
+import Data.Word (Word64)
+import GHC.Generics (Generic)
 import Language.Marlowe (ChoiceId(..), Input(..), InputContent(..), Party, Token)
 import Language.Marlowe.Protocol.HeaderSync.Client (MarloweHeaderSyncClient, hoistMarloweHeaderSyncClient)
 import qualified Language.Marlowe.Protocol.HeaderSync.Client as HeaderSync
@@ -35,7 +43,18 @@ import qualified Language.Marlowe.Protocol.Sync.Client as MarloweSync
 import Language.Marlowe.Runtime.Cardano.Api
   (fromCardanoAddressInEra, fromCardanoTxId, fromCardanoTxOutDatum, fromCardanoTxOutValue)
 import Language.Marlowe.Runtime.ChainSync.Api
-  (Assets(..), BlockHeader, TokenName, TransactionMetadata(..), TxId, TxIx, TxOutRef(..), fromBech32)
+  ( Assets(..)
+  , BlockHeader(..)
+  , BlockHeaderHash(..)
+  , BlockNo(..)
+  , SlotNo(..)
+  , TokenName
+  , TransactionMetadata(..)
+  , TxId
+  , TxIx
+  , TxOutRef(..)
+  , fromBech32
+  )
 import Language.Marlowe.Runtime.Core.Api
   ( ContractId(..)
   , MarloweVersion(..)
@@ -54,9 +73,10 @@ import Language.Marlowe.Runtime.Transaction.Api
 import Network.Protocol.Job.Client (JobClient, hoistJobClient, liftCommand, liftCommandWait)
 import qualified Plutus.V2.Ledger.Api as PV2
 import Test.Hspec (shouldBe)
-import Test.Integration.Marlowe (LocalTestnet(..), MarloweRuntime, PaymentKeyPair(..), execCli)
+import Test.Integration.Marlowe (LocalTestnet(..), MarloweRuntime, PaymentKeyPair(..), SpoNode(..), execCli)
 import qualified Test.Integration.Marlowe.Local as MarloweRuntime
-import UnliftIO (MonadUnliftIO(withRunInIO))
+import UnliftIO (MonadUnliftIO(withRunInIO), bracket_)
+import UnliftIO.Environment (setEnv, unsetEnv)
 
 type Integration = ReaderT MarloweRuntime IO
 
@@ -115,6 +135,31 @@ getGenesisWallet walletIx = do
     , signingKeys = [WitnessGenesisUTxOKey genesisUTxOKey]
     }
 
+newtype CliHash = CliHash { unCliHash :: ByteString }
+
+instance FromJSON CliHash where
+  parseJSON = \case
+    String s -> either (parseFail . T.unpack) (pure . CliHash) $ decodeBase16 $ encodeUtf8 s
+    _ -> parseFail "Expected a string"
+
+data CliBlockHeader = CliBlockHeader
+  { block :: Word64
+  , hash :: CliHash
+  , slot :: Word64
+  }
+  deriving (Generic, FromJSON)
+
+getTip :: Integration BlockHeader
+getTip = do
+  LocalTestnet{..} <- testnet
+  let SpoNode{..} = head spoNodes
+  output <- bracket_ (setEnv "CARDANO_NODE_SOCKET_PATH" socket) (unsetEnv "CARDANO_NODE_SOCKET_PATH") $ liftIO $ execCli
+    [ "query", "tip"
+    , "--testnet-magic", show testnetMagic
+    ]
+  CliBlockHeader{..} <- expectRight "Failed to decode tip" $ eitherDecodeStrict $ T.encodeUtf8 $ T.pack output
+  pure $ BlockHeader (SlotNo slot) (BlockHeaderHash $ unCliHash hash) (BlockNo block)
+
 submit
   :: Wallet
   -> TxBody BabbageEra
@@ -336,6 +381,71 @@ marloweSyncExpectRollForward recvMsgRollForward = do
       }
   pure next
 
+headerSyncIntersectExpectNotFound :: [BlockHeader] -> Integration ()
+headerSyncIntersectExpectNotFound points = runMarloweHeaderSyncClient
+  $ HeaderSync.MarloweHeaderSyncClient
+  $ pure
+  $ HeaderSync.SendMsgIntersect points HeaderSync.ClientStIntersect
+    { recvMsgIntersectNotFound = pure $ HeaderSync.SendMsgDone ()
+    , recvMsgIntersectFound = \_ -> fail "Expected intersect not found, got intersect found"
+    }
+
+headerSyncIntersectExpectFound_ :: [BlockHeader] -> BlockHeader -> Integration ()
+headerSyncIntersectExpectFound_ points expectedPoint =
+  headerSyncIntersectExpectFound points expectedPoint
+    $ pure
+    $ HeaderSync.SendMsgDone ()
+
+headerSyncIntersectExpectFound
+  :: [BlockHeader]
+  -> BlockHeader
+  -> Integration (HeaderSync.ClientStIdle Integration a)
+  -> Integration a
+headerSyncIntersectExpectFound points expectedPoint next = runMarloweHeaderSyncClient
+  $ HeaderSync.MarloweHeaderSyncClient
+  $ pure
+  $ HeaderSync.SendMsgIntersect points HeaderSync.ClientStIntersect
+    { recvMsgIntersectNotFound = fail "Expected intersect found, got intersect not found"
+    , recvMsgIntersectFound = \actualPoint -> do
+        liftIO $ actualPoint `shouldBe` expectedPoint
+        next
+    }
+
+marloweSyncIntersectExpectNotFound :: ContractId -> [BlockHeader] -> Integration ()
+marloweSyncIntersectExpectNotFound contractId points = runMarloweSyncClient
+  $ MarloweSync.MarloweSyncClient
+  $ pure
+  $ MarloweSync.SendMsgIntersect contractId MarloweV1 points MarloweSync.ClientStIntersect
+    { recvMsgIntersectNotFound = pure ()
+    , recvMsgIntersectFound = \_ -> fail "Expected intersect not found, got intersect found"
+    }
+
+marloweSyncIntersectExpectFound_
+  :: ContractId
+  -> [BlockHeader]
+  -> BlockHeader
+  -> Integration ()
+marloweSyncIntersectExpectFound_ contractId points expectedPoint =
+  marloweSyncIntersectExpectFound contractId points expectedPoint
+    $ pure
+    $ MarloweSync.SendMsgDone ()
+
+marloweSyncIntersectExpectFound
+  :: ContractId
+  -> [BlockHeader]
+  -> BlockHeader
+  -> Integration (MarloweSync.ClientStIdle 'V1 Integration a)
+  -> Integration a
+marloweSyncIntersectExpectFound contractId points expectedPoint next = runMarloweSyncClient
+  $ MarloweSync.MarloweSyncClient
+  $ pure
+  $ MarloweSync.SendMsgIntersect contractId MarloweV1 points MarloweSync.ClientStIntersect
+    { recvMsgIntersectNotFound = fail "Expected intersect found, got intersect not found"
+    , recvMsgIntersectFound = \actualPoint -> do
+        liftIO $ actualPoint `shouldBe` expectedPoint
+        next
+    }
+
 marloweSyncPollExpectWait
   :: MonadFail m => m (MarloweSync.ClientStWait v m a)
   -> MarloweSync.ClientStWait v m a