SCP-5012 Added command to list contract headers.

input-output-hk · Feb 7, 2023 · 38f811f · 38f811f
1 parent 832e79f
commit 38f811f
Show file tree

Hide file tree

Showing 4 changed files with 24 additions and 8 deletions.
diff --git a/marlowe-apps/src/Language/Marlowe/Protocol/Query/Client/Extra.hs b/marlowe-apps/src/Language/Marlowe/Protocol/Query/Client/Extra.hs
@@ -1,8 +1,6 @@
 
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE EmptyCase #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
 
 

diff --git a/marlowe-apps/src/Language/Marlowe/Runtime/App.hs b/marlowe-apps/src/Language/Marlowe/Runtime/App.hs
@@ -18,7 +18,7 @@ import Control.Exception (SomeException, catch)
 import Data.Bifunctor (second)
 import Data.Either (fromRight)
 import Language.Marlowe.Runtime.App.Build (buildApplication, buildCreation, buildWithdrawal)
-import Language.Marlowe.Runtime.App.List (allContracts, getContract)
+import Language.Marlowe.Runtime.App.List (allContracts, allHeaders, getContract)
 import Language.Marlowe.Runtime.App.Run (runClientWithConfig)
 import Language.Marlowe.Runtime.App.Sign (sign)
 import Language.Marlowe.Runtime.App.Submit (submit, waitForTx)
@@ -35,7 +35,8 @@ handle config request =
     let
       run =
         case request of
-          List -> Right . Contracts <$> allContracts
+          ListContracts -> Right . Contracts <$> allContracts
+          ListHeaders -> Right . Headers <$> allHeaders
           Get{..} -> fmap (uncurry Info) <$> getContract reqContractId
           Create{..} -> second (uncurry mkBody) <$> buildCreation MarloweV1 reqContract reqRoles reqMinUtxo reqMetadata reqAddresses reqChange reqCollateral
           Apply{..} -> second (uncurry mkBody) <$> buildApplication MarloweV1 reqContractId reqInputs reqValidityLowerBound reqValidityUpperBound reqMetadata reqAddresses reqChange reqCollateral

diff --git a/marlowe-apps/src/Language/Marlowe/Runtime/App/List.hs b/marlowe-apps/src/Language/Marlowe/Runtime/App/List.hs
@@ -8,6 +8,7 @@
 
 module Language.Marlowe.Runtime.App.List
   ( allContracts
+  , allHeaders
   , getContract
   ) where
 
@@ -35,8 +36,12 @@ allContracts :: Client [ContractId]
 allContracts = listContracts runSyncQueryClient $ fmap contractId
 
 
+allHeaders :: Client [ContractHeader]
+allHeaders = listContracts runSyncQueryClient id
+
+
 pageSize :: Int
-pageSize = 1000
+pageSize = 1024
 
 
 listContracts

diff --git a/marlowe-apps/src/Language/Marlowe/Runtime/App/Types.hs b/marlowe-apps/src/Language/Marlowe/Runtime/App/Types.hs
@@ -60,6 +60,7 @@ import Language.Marlowe.Runtime.Core.Api
   , TransactionScriptOutput(..)
   , renderContractId
   )
+import Language.Marlowe.Runtime.Discovery.Api (ContractHeader)
 import Language.Marlowe.Runtime.History.Api
   (ContractStep(..), CreateStep(..), RedeemStep(RedeemStep, datum, redeemingTx, utxo))
 import Language.Marlowe.Runtime.Transaction.Api (MarloweTxCommand)
@@ -150,7 +151,8 @@ type RunClient m client = forall a. client m a -> m a
 
 
 data MarloweRequest v =
-    List
+    ListContracts
+  | ListHeaders
   | Get
     { reqContractId :: ContractId
     }
@@ -201,7 +203,8 @@ instance A.FromJSON (MarloweRequest 'V1) where
       $ \o ->
         (o A..: "request" :: A.Parser String)
           >>= \case
-            "list" -> pure List
+            "list" -> pure ListContracts
+            "headers" -> pure ListHeaders
             "get" -> do
                        reqContractId <- fromString <$> o A..: "contractId"
                        pure Get{..}
@@ -246,7 +249,8 @@ instance A.FromJSON (MarloweRequest 'V1) where
             request -> fail $ "Invalid request: " <> request <> "."
 
 instance A.ToJSON (MarloweRequest 'V1) where
-  toJSON List = A.object ["request" A..= ("list" :: String)]
+  toJSON ListContracts = A.object ["request" A..= ("list" :: String)]
+  toJSON ListHeaders = A.object ["request" A..= ("headers" :: String)]
   toJSON Get{..} =
     A.object
       [ "request" A..= ("get" :: String)
@@ -306,6 +310,9 @@ data MarloweResponse v =
     Contracts
     { resContractIds :: [ContractId]
     }
+  | Headers
+    { resContractHeaders :: [ContractHeader]
+    }
   | FollowResult
     { resResult :: Bool
     }
@@ -337,6 +344,11 @@ instance A.ToJSON (MarloweResponse 'V1) where
       [ "response" A..= ("contracts" :: String)
       , "contractIds" A..= fmap renderContractId resContractIds
       ]
+  toJSON Headers{..} =
+    A.object
+      [ "response" A..= ("headers" :: String)
+      , "contractHeaders" A..= resContractHeaders
+      ]
   toJSON FollowResult{..} =
     A.object
       [ "response" A..= ("result" :: String)