hlb, support: CommandService, all 4 RPCs (digital-asset#2267)

TuranDev · Jul 23, 2019 · d306814 · d306814
1 parent 5f3e4b4
commit d306814
Show file tree

Hide file tree

Showing 3 changed files with 171 additions and 7 deletions.
diff --git a/language-support/hs/bindings/src/DA/Ledger/Services.hs b/language-support/hs/bindings/src/DA/Ledger/Services.hs
@@ -4,6 +4,7 @@
 module DA.Ledger.Services (module X) where
 
 import DA.Ledger.Services.ActiveContractsService as X
+import DA.Ledger.Services.CommandService as X
 import DA.Ledger.Services.CommandCompletionService as X
 import DA.Ledger.Services.CommandSubmissionService as X
 import DA.Ledger.Services.LedgerConfigurationService as X

diff --git a/language-support/hs/bindings/src/DA/Ledger/Services/CommandService.hs b/language-support/hs/bindings/src/DA/Ledger/Services/CommandService.hs
@@ -0,0 +1,93 @@
+-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+{-# LANGUAGE GADTs #-}
+
+module DA.Ledger.Services.CommandService (
+    submitAndWait,
+    submitAndWaitForTransactionId,
+    submitAndWaitForTransaction,
+    submitAndWaitForTransactionTree,
+    ) where
+
+import DA.Ledger.Convert
+import DA.Ledger.GrpcWrapUtils
+import DA.Ledger.LedgerService
+import DA.Ledger.Types
+import Network.GRPC.HighLevel.Generated
+import qualified Com.Digitalasset.Ledger.Api.V1.CommandService as LL
+
+submitAndWait :: Commands -> LedgerService (Either String ())
+submitAndWait commands =
+    makeLedgerService $ \timeout config ->
+    withGRPCClient config $ \client -> do
+        service <- LL.commandServiceClient client
+        let LL.CommandService{commandServiceSubmitAndWaitForTransactionId=rpc} = service
+        let request = LL.SubmitAndWaitRequest (Just (lowerCommands commands)) noTrace
+        rpc (ClientNormalRequest request timeout emptyMdm)
+            >>= \case
+            ClientNormalResponse LL.SubmitAndWaitForTransactionIdResponse{} _m1 _m2 _status _details -> do
+                return $ Right ()
+            ClientErrorResponse (ClientIOError (GRPCIOBadStatusCode StatusInvalidArgument details)) ->
+                return $ Left $ show $ unStatusDetails details
+            ClientErrorResponse e ->
+                fail (show e)
+
+submitAndWaitForTransactionId :: Commands -> LedgerService (Either String TransactionId)
+submitAndWaitForTransactionId commands =
+    makeLedgerService $ \timeout config ->
+    withGRPCClient config $ \client -> do
+        service <- LL.commandServiceClient client
+        let LL.CommandService{commandServiceSubmitAndWaitForTransactionId=rpc} = service
+        let request = LL.SubmitAndWaitRequest (Just (lowerCommands commands)) noTrace
+        rpc (ClientNormalRequest request timeout emptyMdm)
+            >>= \case
+            ClientNormalResponse response _m1 _m2 _status _details -> do
+                let LL.SubmitAndWaitForTransactionIdResponse{..} = response
+                return $ Right $ TransactionId submitAndWaitForTransactionIdResponseTransactionId
+            ClientErrorResponse (ClientIOError (GRPCIOBadStatusCode StatusInvalidArgument details)) ->
+                return $ Left $ show $ unStatusDetails details
+            ClientErrorResponse e ->
+                fail (show e)
+
+submitAndWaitForTransaction :: Commands -> LedgerService (Either String Transaction)
+submitAndWaitForTransaction commands =
+    makeLedgerService $ \timeout config ->
+    withGRPCClient config $ \client -> do
+        service <- LL.commandServiceClient client
+        let LL.CommandService{commandServiceSubmitAndWaitForTransaction=rpc} = service
+        let request = LL.SubmitAndWaitRequest (Just (lowerCommands commands)) noTrace
+        rpc (ClientNormalRequest request timeout emptyMdm)
+            >>= \case
+            ClientNormalResponse response _m1 _m2 _status _details -> do
+                either (fail . show) (return . Right) $ raiseResponse response
+            ClientErrorResponse (ClientIOError (GRPCIOBadStatusCode StatusInvalidArgument details)) ->
+                return $ Left $ show $ unStatusDetails details
+            ClientErrorResponse e ->
+                fail (show e)
+  where
+      raiseResponse = \case
+          LL.SubmitAndWaitForTransactionResponse{..} -> do
+              perhaps "transaction" submitAndWaitForTransactionResponseTransaction
+                  >>= raiseTransaction
+
+submitAndWaitForTransactionTree :: Commands -> LedgerService (Either String TransactionTree)
+submitAndWaitForTransactionTree commands =
+    makeLedgerService $ \timeout config ->
+    withGRPCClient config $ \client -> do
+        service <- LL.commandServiceClient client
+        let LL.CommandService{commandServiceSubmitAndWaitForTransactionTree=rpc} = service
+        let request = LL.SubmitAndWaitRequest (Just (lowerCommands commands)) noTrace
+        rpc (ClientNormalRequest request timeout emptyMdm)
+            >>= \case
+            ClientNormalResponse response _m1 _m2 _status _details -> do
+                either (fail . show) (return . Right) $ raiseResponse response
+            ClientErrorResponse (ClientIOError (GRPCIOBadStatusCode StatusInvalidArgument details)) ->
+                return $ Left $ show $ unStatusDetails details
+            ClientErrorResponse e ->
+                fail (show e)
+  where
+      raiseResponse = \case
+          LL.SubmitAndWaitForTransactionTreeResponse{..} -> do
+              perhaps "transaction" submitAndWaitForTransactionTreeResponseTransaction
+                  >>= raiseTransactionTree
diff --git a/language-support/hs/bindings/test/DA/Ledger/Tests.hs b/language-support/hs/bindings/test/DA/Ledger/Tests.hs
@@ -70,6 +70,10 @@ tests = testGroupWithSandbox "Ledger Bindings"
     , tListKnownPackages
     , tGetTime
     , tSetTime
+    , tSubmitAndWait
+    , tSubmitAndWaitForTransactionId
+    , tSubmitAndWaitForTransaction
+    , tSubmitAndWaitForTransactionTree
     ]
 
 run :: WithSandbox -> (PackageId -> LedgerService ()) -> IO ()
@@ -415,12 +419,73 @@ tSetTime withSandbox = testCase "tSetTime" $ run withSandbox $ \_ -> do
     Just (Right time) <- liftIO $ timeout 1 (takeStream xs)
     liftIO $ assertEqual "time3" t33 time  -- time is 3,3 as we set it
 
+tSubmitAndWait :: SandboxTest
+tSubmitAndWait withSandbox =
+    testCase "tSubmitAndWait" $ run withSandbox $ \pid -> do
+    lid <- getLedgerIdentity
+    withGetAllTransactions lid alice (Verbosity False) $ \txs -> do
+    -- bad
+    (_cid,commands) <- liftIO $ makeCommands lid alice $ createIOU pid bob "B-coin" 100
+    Left err <- submitAndWait commands
+    liftIO $ assertTextContains err "requires authorizers Bob, but only Alice were given"
+    -- good
+    (_cid,commands) <- liftIO $ makeCommands lid alice $ createIOU pid alice "A-coin" 100
+    Right () <- submitAndWait commands
+    Just (Right [_]) <- liftIO $ timeout 1 $ takeStream txs
+    return ()
+
+tSubmitAndWaitForTransactionId :: SandboxTest
+tSubmitAndWaitForTransactionId withSandbox =
+    testCase "tSubmitAndWaitForTransactionId" $ run withSandbox $ \pid -> do
+    lid <- getLedgerIdentity
+    withGetAllTransactions lid alice (Verbosity False) $ \txs -> do
+    -- bad
+    (_cid,commands) <- liftIO $ makeCommands lid alice $ createIOU pid bob "B-coin" 100
+    Left err <- submitAndWaitForTransactionId commands
+    liftIO $ assertTextContains err "requires authorizers Bob, but only Alice were given"
+    -- good
+    (_cid,commands) <- liftIO $ makeCommands lid alice $ createIOU pid alice "A-coin" 100
+    Right trid <- submitAndWaitForTransactionId commands
+    Just (Right [Transaction{trid=tridExpected}]) <- liftIO $ timeout 1 $ takeStream txs
+    liftIO $ assertEqual "trid" tridExpected trid
+
+tSubmitAndWaitForTransaction :: SandboxTest
+tSubmitAndWaitForTransaction withSandbox =
+    testCase "tSubmitAndWaitForTransaction" $ run withSandbox $ \pid -> do
+    lid <- getLedgerIdentity
+    withGetAllTransactions lid alice (Verbosity True) $ \txs -> do
+    -- bad
+    (_cid,commands) <- liftIO $ makeCommands lid alice $ createIOU pid bob "B-coin" 100
+    Left err <- submitAndWaitForTransaction commands
+    liftIO $ assertTextContains err "requires authorizers Bob, but only Alice were given"
+    -- good
+    (_cid,commands) <- liftIO $ makeCommands lid alice $ createIOU pid alice "A-coin" 100
+    Right trans <- submitAndWaitForTransaction commands
+    Just (Right [transExpected]) <- liftIO $ timeout 1 $ takeStream txs
+    liftIO $ assertEqual "trans" transExpected trans
+
+tSubmitAndWaitForTransactionTree :: SandboxTest
+tSubmitAndWaitForTransactionTree withSandbox =
+    testCase "tSubmitAndWaitForTransactionTree" $ run withSandbox $ \pid -> do
+    lid <- getLedgerIdentity
+    withGetAllTransactionTrees lid alice (Verbosity True) $ \txs -> do
+    -- bad
+    (_cid,commands) <- liftIO $ makeCommands lid alice $ createIOU pid bob "B-coin" 100
+    Left err <- submitAndWaitForTransactionTree commands
+    liftIO $ assertTextContains err "requires authorizers Bob, but only Alice were given"
+    -- good
+    (_cid,commands) <- liftIO $ makeCommands lid alice $ createIOU pid alice "A-coin" 100
+    Right tree <- submitAndWaitForTransactionTree commands
+    Just (Right [treeExpected]) <- liftIO $ timeout 1 $ takeStream txs
+    liftIO $ assertEqual "tree" treeExpected tree
+
 
 ----------------------------------------------------------------------
 -- misc ledger ops/commands
 
-alice :: Party
+alice,bob :: Party
 alice = Party "Alice"
+bob = Party "Bob"
 
 createIOU :: PackageId -> Party -> Text -> Int -> Command
 createIOU quickstart party currency quantity = CreateCommand {tid,args}
@@ -460,14 +525,19 @@ createWithoutKey quickstart owner n = CreateCommand {tid,args}
 
 submitCommand :: LedgerId -> Party -> Command -> LedgerService (Either String CommandId)
 submitCommand lid party com = do
-    cid <- liftIO randomCid
-    Ledger.submit (Commands {lid,wid,aid=myAid,cid,party,leTime,mrTime,coms=[com]}) >>= \case
+    (cid,commands) <- liftIO $ makeCommands lid party com
+    Ledger.submit commands >>= \case
         Left s -> return $ Left s
         Right () -> return $ Right cid
-    where
-        wid = Nothing
-        leTime = Timestamp 0 0
-        mrTime = Timestamp 5 0
+
+makeCommands :: LedgerId -> Party -> Command -> IO (CommandId,Commands)
+makeCommands lid party com = do
+    cid <- liftIO randomCid
+    let wid = Nothing
+    let leTime = Timestamp 0 0
+    let mrTime = Timestamp 5 0
+    return $ (cid,) $ Commands {lid,wid,aid=myAid,cid,party,leTime,mrTime,coms=[com]}
+
 
 myAid :: ApplicationId
 myAid = ApplicationId ":my-application:"