fix bug

input-output-hk · Jul 26, 2023 · 98620f8 · 98620f8
1 parent 045fab4
commit 98620f8
Show file tree

Hide file tree

Showing 2 changed files with 22 additions and 22 deletions.
diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/CliSpec.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/CliSpec.hs
@@ -15,11 +15,13 @@ import Cardano.Api (
  )
 import qualified Cardano.Api.Shelley
 import qualified Control.Monad.Reader as Reader
+import qualified Data.Aeson as Aeson
 import Data.Foldable (for_)
 import Data.Map (Map)
 import qualified Data.Map as Map
 import qualified Data.Maybe as Maybe
 import qualified Data.Set as Set
+import Data.String (fromString)
 import qualified Data.Text as Text
 import qualified Data.Time as Time
 import qualified Data.Time.Clock.POSIX as POSIX
@@ -578,31 +580,31 @@ bugPLT6773 = focus $
   describe "[BUG] PLT-6773: Marlowe runtime cannot load any contracts" $
     it "Marlowe runtime can load any contracts" \CLISpecTestData{..} -> flip runIntegrationTest runtime do
       workspace <- Reader.asks $ workspace . testnet
-      let contractHashRelation :: [(V1.Contract, String, String)]
+      let contractHashRelation :: [(String, V1.Contract, Aeson.Value)]
           contractHashRelation =
-            [ (V1.Close, "923918e403bf43c34b4ef6b48eb2ee04babed17320d8d1b9ff9ad086e86f44ec", "\"close\"\n")
+            [ ("923918e403bf43c34b4ef6b48eb2ee04babed17320d8d1b9ff9ad086e86f44ec", V1.Close, Aeson.String "close")
             ,
-              ( V1.Assert V1.TrueObs V1.Close
-              , "ee5ab3bfda75834c3c1503ec7cd0b7fccbce7ceb3909e5404910bfd9e09b1be4"
-              , "{\"assert\":true,\"then\":\"close\"}"
+              ( "ee5ab3bfda75834c3c1503ec7cd0b7fccbce7ceb3909e5404910bfd9e09b1be4"
+              , V1.Assert V1.TrueObs V1.Close
+              , Aeson.object [("assert", Aeson.Bool True), ("then", Aeson.String "close")]
               )
             ]
 
-      for_ contractHashRelation \(contract :: V1.Contract, expectedHash :: String, expectedContract :: String) -> do
+      for_ contractHashRelation \(expectedHash :: String, contract :: V1.Contract, expectedContract :: Aeson.Value) -> do
         contractFilePath <- writeWorkspaceFileJSON workspace "contract.json" contract
 
         do
           (code, stdout, stderr) <- Runtime.Integration.Common.execMarlowe' ["load", "--read-json", contractFilePath]
 
           liftIO do
             putStrLn stderr
-            code `shouldBe` ExitSuccess
-            stdout `shouldBe` expectedHash ++ "\n"
+            (code, stdout) `shouldBe` (ExitSuccess, expectedHash ++ "\n")
 
         do
           (code, stdout, stderr) <- Runtime.Integration.Common.execMarlowe' ["query", "store", "contract", expectedHash]
 
+          let actualContractJSON :: Maybe Aeson.Value = Aeson.decode $ fromString stdout
+
           liftIO do
             putStrLn stderr
-            code `shouldBe` ExitSuccess
-            stdout `shouldBe` expectedContract
+            (code, actualContractJSON) `shouldBe` (ExitSuccess, Just expectedContract)
diff --git a/marlowe-runtime-cli/app/Language/Marlowe/Runtime/CLI/Command/Load.hs b/marlowe-runtime-cli/app/Language/Marlowe/Runtime/CLI/Command/Load.hs
@@ -30,7 +30,7 @@ import Language.Marlowe.Object.Types (
 import Language.Marlowe.Protocol.Transfer.Types (ImportError)
 import Language.Marlowe.Runtime.CLI.Monad (CLI)
 import Language.Marlowe.Runtime.ChainSync.Api (DatumHash (..))
-import Language.Marlowe.Runtime.Client (importIncremental)
+import Language.Marlowe.Runtime.Client (importBundle, importIncremental)
 import Options.Applicative (ParserInfo, flag, help, info, long, metavar, progDesc, short, strArgument)
 import Pipes (Pipe, Producer, await, yield, (>->))
 import qualified Pipes.Prelude as P
@@ -70,12 +70,12 @@ runLoadCommand LoadCommand{..} = do
   liftIO $ unless exists $ die "Bundle archive file does not exist"
   result <-
     if readJSON
-      then
-        fmap pure $
-          P.head $
-            readJSONFile archivePath
-              >-> (lift . handleError =<< runMarloweTransferClient importIncremental)
-              >-> collectMain "main"
+      then do
+        bundle <- readJSONFile archivePath
+        result <- runMarloweTransferClient $ importBundle bundle
+        case result of
+          Left err -> liftIO $ die $ "Failed to import bundle: " <> show err
+          Right hashes -> pure $ pure $ Map.lookup "main" hashes
       else unpackArchive archivePath \mainIs readObject ->
         P.head $
           bundles readObject
@@ -86,15 +86,13 @@ runLoadCommand LoadCommand{..} = do
     Right Nothing -> die "Error: main not linked. This is a bug, please report it with the archive you were trying to load attached."
     Right (Just mainHash) -> putStrLn $ T.unpack $ encodeBase16 $ unDatumHash mainHash
 
-readJSONFile :: FilePath -> Producer ObjectBundle CLI ()
+readJSONFile :: FilePath -> CLI ObjectBundle
 readJSONFile path = do
   result <- liftIO $ eitherDecodeFileStrict path
   case result of
-    Left err -> liftIO $ die $ "Error: back contract file: " <> err
+    Left err -> liftIO $ die $ "Error: bad contract file: " <> err
     Right contract -> do
-      yield $ ObjectBundle $ pure $ LabelledObject "main" ContractType $ fromCoreContract contract
-      -- Yield an empty bundle to indicate the stream is done.
-      yield $ ObjectBundle []
+      pure $ ObjectBundle $ pure $ LabelledObject "main" ContractType $ fromCoreContract contract
 
 bundles :: CLI (Maybe LabelledObject) -> Producer ObjectBundle CLI ()
 bundles readObject = do