Fixed cardano-integration node misconfiguration

cardano-integration/cardano-integration.cabal

@@ -58,6 +58,7 @@ library
     , bytestring
     , directory
     , filepath
+    , HUnit
     , lifted-base
     , monad-control
     , process

cardano-integration/src/Test/Integration/Cardano/Local.hs

@@ -34,14 +34,16 @@ import Data.List (isInfixOf)
 import Data.Maybe (fromJust)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
-import Data.Time (UTCTime, addUTCTime, getCurrentTime, nominalDiffTimeToSeconds, secondsToNominalDiffTime)
-import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
+import Data.Time (UTCTime, getCurrentTime, nominalDiffTimeToSeconds, secondsToNominalDiffTime)
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
+import Data.Time.Format.ISO8601 (iso8601Show)
 import qualified Data.Yaml.Aeson as YAML
 import GHC.Generics (Generic)
 import System.FilePath ((</>))
 import System.IO (Handle, IOMode(..), hClose, openFile)
 import System.Process (CreateProcess(..), ProcessHandle, StdStream(..), cleanupProcess, createProcess, proc)
 import System.Random (randomRIO)
+import Test.HUnit.Lang (HUnitFailure(..))
 import Test.Integration.Cardano.Process (execCli_)
 import Test.Integration.Workspace
   ( Workspace(..)
@@ -153,7 +155,10 @@ withLocalTestnet'
   -> m a
 withLocalTestnet' options test = runResourceT do
   testnet <- startLocalTestnet options
-  lift $ test testnet `catch` rethrowAsTestnetException testnet
+  result <- lift $ (Right <$> test testnet)
+    `catch` (\ex@HUnitFailure{} -> pure $ Left ex)
+    `catch` rethrowAsTestnetException testnet
+  either throw pure result
 
 data TestnetException = TestnetException
   { workspace :: FilePath
@@ -185,12 +190,12 @@ startLocalTestnet options@LocalTestnetOptions{..} = do
       socketDir <- createWorkspaceDir workspace "socket"
       logsDir <- createWorkspaceDir workspace "logs"
 
-      currentTime <- liftIO getCurrentTime
+      currentTime <- round . utcTimeToPOSIXSeconds <$> liftIO getCurrentTime
       -- Add time to execute the CLI commands to set everything up
-      let startTime = addUTCTime (secondsToNominalDiffTime 15) currentTime
+      let startTime = posixSecondsToUTCTime $ secondsToNominalDiffTime $ fromInteger currentTime + 15
 
       byronGenesisDir <- createByronGenesis workspace startTime testnetMagic options
-      shelleyGenesisDir <- createShelleyGenesisStaked workspace testnetMagic options
+      shelleyGenesisDir <- createShelleyGenesisStaked workspace startTime testnetMagic options
 
       let
         wallets = [1..numWallets] <&> \n -> PaymentKeyPair
@@ -262,8 +267,8 @@ createByronGenesis workspace startTime testnetMagic LocalTestnetOptions{..} = do
     ]
   pure byronGenesisDir
 
-createShelleyGenesisStaked :: MonadIO m => Workspace -> Int -> LocalTestnetOptions -> m FilePath
-createShelleyGenesisStaked workspace testnetMagic LocalTestnetOptions{..} = do
+createShelleyGenesisStaked :: MonadIO m => Workspace -> UTCTime -> Int -> LocalTestnetOptions -> m FilePath
+createShelleyGenesisStaked workspace startTime testnetMagic LocalTestnetOptions{..} = do
   let shelleyGenesisDir = "shelley-genesis"
   let shelleyGenesisDirInWorkspace = resolveWorkspacePath workspace shelleyGenesisDir
 
@@ -303,6 +308,7 @@ createShelleyGenesisStaked workspace testnetMagic LocalTestnetOptions{..} = do
     , "--gen-pools", show numSpoNodes
     , "--supply", "1000000000000"
     , "--supply-delegated", "1000000000000"
+    , "--start-time", iso8601Show startTime
     , "--gen-stake-delegs", show numDelegators
     , "--gen-utxo-keys", show numWallets
     ]

marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/BasicSpec.hs

@@ -69,25 +69,14 @@ spec = describe "Marlowe runtime API" do
           -- 2. Expect wait
           $ headerSyncExpectWait do
             -- 3. Create standard contract
-            contract@ContractCreated{..} <- createStandardContract runtime partyAWalletAddresses partyAAddress partyBAddress
+            contract@ContractCreated{txBody} <- createStandardContract runtime partyAWalletAddresses partyAAddress partyBAddress
             blockHeader <- submit runtime partyASigningWitnesses txBody
-            let
-              expectedContractHeader = ContractHeader
-                { contractId
-                , rolesCurrency
-                , metadata = TransactionMetadata metadata
-                , marloweScriptHash
-                , marloweScriptAddress
-                , payoutScriptHash
-                , marloweVersion = SomeMarloweVersion MarloweV1
-                , blockHeader
-                }
               -- 4. Poll
             HeaderSync.SendMsgPoll
               -- 5. Expect new headers
               <$> headerSyncExpectNewHeaders \actualBlock actualHeaders -> do
                   actualBlock `shouldBe` blockHeader
-                  actualHeaders `shouldBe` [expectedContractHeader]
+                  actualHeaders `shouldBe` [contractCreatedToContractHeader blockHeader contract]
                   continueWithNewHeaders blockHeader contract
 
       continueWithNewHeaders createBlock contract@ContractCreated{contractId} = pure
@@ -108,44 +97,20 @@ spec = describe "Marlowe runtime API" do
         -> BlockHeader
         -> BlockHeader
         -> MarloweSync.MarloweSyncClient IO ()
-      marloweSyncClient ContractCreated{..} inputsApplied createBlock depositBlock = MarloweSync.MarloweSyncClient
+      marloweSyncClient contractCreated@ContractCreated{contractId} inputsApplied createBlock depositBlock = MarloweSync.MarloweSyncClient
           $ pure
           $ MarloweSync.SendMsgFollowContract contractId
           -- 10. Expect contract found
           $ marloweSyncExpectContractFound \actualBlock MarloweV1 createStep -> do
             actualBlock `shouldBe` createBlock
-            createStep `shouldBe` CreateStep
-              { createOutput = TransactionScriptOutput
-                  { address = marloweScriptAddress
-                  , assets = Assets 2_000_000 mempty
-                  , utxo = unContractId contractId
-                  , datum
-                  }
-              , metadata = mempty
-              , payoutValidatorHash = payoutScriptHash
-              }
+            createStep `shouldBe` contractCreatedToCreateStep contractCreated
             pure
               -- 11. Request next
               $ MarloweSync.SendMsgRequestNext
               -- 12. Expect roll forward with deposit
               $ marloweSyncExpectRollForward \block steps -> do
                   block `shouldBe` depositBlock
-                  let
-                    InputsApplied{ txBody = body, invalidBefore, invalidHereafter, inputs, output } = inputsApplied
-                    expectedStep = ApplyTransaction Transaction
-                      { transactionId = fromCardanoTxId $ getTxId body
-                      , contractId
-                      , metadata = mempty
-                      , blockHeader = depositBlock
-                      , validityLowerBound = invalidBefore
-                      , validityUpperBound = invalidHereafter
-                      , inputs
-                      , output = TransactionOutput
-                          { payouts = mempty
-                          , scriptOutput = output
-                          }
-                      }
-                  steps `shouldBe` [expectedStep]
+                  steps `shouldBe` [ApplyTransaction $ inputsAppliedToTransaction depositBlock inputsApplied]
                   fail "TODO implement the rest of the test"
 
         {-
@@ -221,6 +186,45 @@ spec = describe "Marlowe runtime API" do
       , recvMsgRollForward
       }
 
+contractCreatedToCreateStep :: ContractCreated BabbageEra v -> CreateStep v
+contractCreatedToCreateStep ContractCreated{..} = CreateStep
+  { createOutput = TransactionScriptOutput
+      { address = marloweScriptAddress
+      , assets = Assets 2_000_000 mempty
+      , utxo = unContractId contractId
+      , datum
+      }
+  , metadata = mempty
+  , payoutValidatorHash = payoutScriptHash
+  }
+
+inputsAppliedToTransaction :: BlockHeader -> InputsApplied BabbageEra v -> Transaction v
+inputsAppliedToTransaction blockHeader InputsApplied{..} = Transaction
+  { transactionId = fromCardanoTxId $ getTxId txBody
+  , contractId
+  , metadata = mempty
+  , blockHeader
+  , validityLowerBound = invalidBefore
+  , validityUpperBound = invalidHereafter
+  , inputs
+  , output = TransactionOutput
+      { payouts = mempty
+      , scriptOutput = output
+      }
+  }
+
+contractCreatedToContractHeader :: BlockHeader -> ContractCreated BabbageEra v -> ContractHeader
+contractCreatedToContractHeader blockHeader ContractCreated{..} = ContractHeader
+  { contractId
+  , rolesCurrency
+  , metadata = TransactionMetadata metadata
+  , marloweScriptHash
+  , marloweScriptAddress
+  , payoutScriptHash
+  , marloweVersion = SomeMarloweVersion version
+  , blockHeader
+  }
+
 timeout :: NominalDiffTime
 timeout = secondsToNominalDiffTime 2
 

marlowe-protocols/src/Network/Protocol/Driver.hs

@@ -246,12 +246,6 @@ data ClientServerPair m server client = ClientServerPair
   , runClient :: RunClient m client
   }
 
-newtype ServerException e = ServerException e deriving (Show)
-newtype ClientException e = ClientException e deriving (Show)
-
-instance Exception e => Exception (ServerException e)
-instance Exception e => Exception (ClientException e)
-
 clientServerPair
   :: forall protocol ex server client serverPeer clientPeer m st r
    . (MonadBaseControl IO m, MonadCleanup m, Exception ex)
@@ -279,7 +273,7 @@ clientServerPair serverEventBackend clientEventBackend throwImpl codec serverToP
         withEvent serverEventBackend Disconnected \ev -> do
           addParent ev ref
           liftBase $ atomically closeAction
-          either (throwImpl . ServerException) pure result
+          either throwImpl pure result
     runClient :: RunClient m client
     runClient client = mask \restore -> do
       (ref, (channel, closeAction)) <- withEvent clientEventBackend Connect \ev -> liftBase $ atomically do
@@ -299,7 +293,7 @@ clientServerPair serverEventBackend clientEventBackend throwImpl codec serverToP
       withEvent clientEventBackend Disconnect \ev -> do
         addParent ev ref
         liftBase $ atomically closeAction
-        either (throwImpl . ClientException) pure result
+        either throwImpl pure result
   pure ClientServerPair{..}
 
 

marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/BuildConstraints.hs

@@ -383,7 +383,11 @@ buildApplyInputsConstraintsV1 systemStart eraHistory marloweOutput tipSlot metad
         tell $ mustPayToRole assets $ roleAssetId role
       V1.Account _ -> pure ()
 
-  pure (posixTimeToUTCTime $ fst txInterval, posixTimeToUTCTime $ snd txInterval, output)
+  pure
+    ( posixTimeToUTCTime $ fst txInterval
+    , posixTimeToUTCTime $ snd txInterval + 1 -- Add the millisecond back to convert the upper bound back to an exclusive bound (ledger semantics)
+    , output
+    )
 
   where
     marloweInputContent (V1.NormalInput c) = c