haskell ledger bindings, support uploadDarFile (digital-asset#2146)

* support uploadDarFile * comment * move uploadDarFileGetPid into test code
TuranDev · Jul 15, 2019 · 102cca0 · 102cca0
1 parent 7c8bb02
commit 102cca0
Show file tree

Hide file tree

Showing 6 changed files with 135 additions and 2 deletions.
diff --git a/language-support/hs/bindings/BUILD.bazel b/language-support/hs/bindings/BUILD.bazel
@@ -67,10 +67,17 @@ daml_compile(
     main_src = "test/daml/quickstart/Main.daml",
 )
 
+daml_compile(
+    name = "for-upload",
+    srcs = glob(["test/daml/for-upload/ExtraModule.daml"]),
+    main_src = "test/daml/for-upload/ExtraModule.daml",
+)
+
 da_haskell_test(
     name = "test",
     srcs = glob(["test/**/*.hs"]),
     data = [
+        ":for-upload.dar",
         ":quickstart.dar",
         "//ledger/sandbox:sandbox-binary",
     ],
@@ -89,6 +96,7 @@ da_haskell_test(
         "tasty-hunit",
         "text",
         "time",
+        "utf8-string",
         "uuid",
         "zip-archive",
     ],

diff --git a/language-support/hs/bindings/src/DA/Ledger/Services.hs b/language-support/hs/bindings/src/DA/Ledger/Services.hs
@@ -8,6 +8,7 @@ import DA.Ledger.Services.CommandCompletionService as X
 import DA.Ledger.Services.CommandSubmissionService as X
 import DA.Ledger.Services.LedgerConfigurationService as X
 import DA.Ledger.Services.LedgerIdentityService as X
+import DA.Ledger.Services.PackageManagementService as X
 import DA.Ledger.Services.PackageService as X
 import DA.Ledger.Services.ResetService as X
 import DA.Ledger.Services.TransactionService as X
diff --git a/language-support/hs/bindings/src/DA/Ledger/Services/PackageManagementService.hs b/language-support/hs/bindings/src/DA/Ledger/Services/PackageManagementService.hs
@@ -0,0 +1,29 @@
+-- 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.PackageManagementService (uploadDarFile) where
+
+import Com.Digitalasset.Ledger.Api.V1.Admin.PackageManagementService
+import Data.ByteString(ByteString)
+import DA.Ledger.GrpcWrapUtils
+import DA.Ledger.LedgerService
+import Network.GRPC.HighLevel.Generated
+
+-- | Upload a DAR file to the ledger. If the ledger responds with `INVALID_ARGUMENT`, we return `Left details`.
+uploadDarFile :: ByteString -> LedgerService (Either String ()) -- Unlike other services, no LedgerId is needed. (why?!)
+uploadDarFile bytes =
+    makeLedgerService $ \timeout config ->
+    withGRPCClient config $ \client -> do
+        service <- packageManagementServiceClient client
+        let PackageManagementService {packageManagementServiceUploadDarFile=rpc} = service
+        let request = UploadDarFileRequest bytes
+        rpc (ClientNormalRequest request timeout emptyMdm)
+            >>= \case
+            ClientNormalResponse UploadDarFileResponse{} _m1 _m2 _status _details ->
+                return $ Right ()
+            ClientErrorResponse (ClientIOError (GRPCIOBadStatusCode StatusInvalidArgument details)) ->
+                return $ Left $ show $ unStatusDetails details
+            ClientErrorResponse e ->
+                fail (show e)
diff --git a/language-support/hs/bindings/test/DA/Ledger/Tests.hs b/language-support/hs/bindings/test/DA/Ledger/Tests.hs
@@ -13,7 +13,7 @@ import DA.Bazel.Runfiles
 import DA.Daml.LF.Proto3.Archive (decodeArchive)
 import DA.Daml.LF.Reader(ManifestData(..),manifestFromDar)
 import DA.Ledger.Sandbox (Sandbox,SandboxSpec(..),startSandbox,shutdownSandbox,withSandbox)
-import Data.List (elem,isPrefixOf,isInfixOf)
+import Data.List (elem,isPrefixOf,isInfixOf,(\\))
 import Data.Text.Lazy (Text)
 import System.Environment.Blank (setEnv)
 import System.Random (randomIO)
@@ -23,7 +23,9 @@ import Test.Tasty as Tasty (TestName,TestTree,testGroup,withResource,defaultMain
 import Test.Tasty.HUnit as Tasty(assertFailure,assertBool,assertEqual,testCase)
 import qualified Codec.Archive.Zip as Zip
 import qualified DA.Daml.LF.Ast as LF
-import qualified Data.ByteString.Lazy as BSL
+import qualified Data.ByteString as BS (readFile)
+import qualified Data.ByteString.UTF8 as BS (ByteString,fromString)
+import qualified Data.ByteString.Lazy as BSL (readFile,toStrict)
 import qualified Data.Text.Lazy as Text(pack,unpack,fromStrict)
 import qualified Data.UUID as UUID (toString)
 
@@ -61,6 +63,8 @@ tests = testGroupWithSandbox "Ledger Bindings"
     , tGetTransactionById
     , tGetActiveContracts
     , tGetLedgerConfiguration
+    , tUploadDarFileBad
+    , tUploadDarFile
     ]
 
 run :: WithSandbox -> (PackageId -> LedgerService ()) -> IO ()
@@ -302,6 +306,49 @@ tGetLedgerConfiguration withSandbox = testCase "tGetLedgerConfiguration" $ run w
             maxTtl = Duration {durationSeconds = 30, durationNanos = 0}}
     liftIO $ assertEqual "config" expected config
 
+tUploadDarFileBad :: SandboxTest
+tUploadDarFileBad withSandbox = testCase "tUploadDarFileBad" $ run withSandbox $ \_pid -> do
+    lid <- getLedgerIdentity
+    let bytes = BS.fromString "not-the-bytes-for-a-darfile"
+    Left err <- uploadDarFileGetPid lid bytes
+    liftIO $ assertTextContains err "Invalid DAR: package-upload"
+
+tUploadDarFile :: SandboxTest
+tUploadDarFile withSandbox = testCase "tUploadDarFileGood" $ run withSandbox $ \_pid -> do
+    lid <- getLedgerIdentity
+    bytes <- liftIO $ do
+        let extraDarFilename = "language-support/hs/bindings/for-upload.dar"
+        file <- locateRunfiles (mainWorkspace </> extraDarFilename)
+        BS.readFile file
+    pid <- uploadDarFileGetPid lid bytes >>= either (liftIO . assertFailure) return
+    cidA <- submitCommand lid alice (createExtra pid alice) >>= either (liftIO . assertFailure) return
+    withGetAllTransactions lid alice (Verbosity True) $ \txs -> do
+    Just (Right [Transaction{cid=Just cidB}]) <- liftIO $ timeout 1 (takeStream txs)
+    liftIO $ do assertEqual "cid" cidA cidB
+    where
+        createExtra :: PackageId -> Party -> Command
+        createExtra pid party = CreateCommand {tid,args}
+            where
+                tid = TemplateId (Identifier pid mod ent)
+                mod = ModuleName "ExtraModule"
+                ent = EntityName "ExtraTemplate"
+                args = Record Nothing [
+                    RecordField "owner" (VParty party),
+                    RecordField "message" (VString "Hello extra module")
+                    ]
+
+
+-- Would be nice if the underlying service returned the pid on successful upload.
+uploadDarFileGetPid :: LedgerId -> BS.ByteString -> LedgerService (Either String PackageId)
+uploadDarFileGetPid lid bytes = do
+    before <- listPackages lid
+    uploadDarFile bytes >>= \case -- call the actual service
+        Left m -> return $ Left m
+        Right () -> do
+            after <- listPackages lid
+            [newPid] <- return (after \\ before) -- see what new pid appears
+            return $ Right newPid
+
 ----------------------------------------------------------------------
 -- misc ledger ops/commands
 

diff --git a/language-support/hs/bindings/test/daml/for-upload/ExtraModule.daml b/language-support/hs/bindings/test/daml/for-upload/ExtraModule.daml
@@ -0,0 +1,13 @@
+-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+daml 1.2
+-- This module is defined for the testing of the uploadDarFile RPC
+module ExtraModule where
+
+template ExtraTemplate
+  with
+    owner : Party
+    message : Text
+  where
+    signatory owner
diff --git a/ledger-api/grpc-definitions/BUILD.bazel b/ledger-api/grpc-definitions/BUILD.bazel
@@ -214,12 +214,47 @@ genrule(
     ],
 )
 
+filegroup(
+    name = "ledger-api-protos-fg-admin",
+    srcs = glob(["com/digitalasset/ledger/api/v1/admin/*.proto"]),
+    visibility = ["//visibility:private"],
+)
+
+ledger_api_haskellpb_sources_admin = [
+    "PackageManagementService.hs",
+    "PartyManagementService.hs",
+]
+
+genrule(
+    name = "ledger-api-haskellpb-sources-admin",
+    srcs = [
+        "@com_google_protobuf//:well_known_protos",
+        "@com_github_googleapis_googleapis//google/rpc:status.proto",
+        ":ledger-api-protos-fg-admin",
+    ],
+    outs = ["Com/Digitalasset/Ledger/Api/V1/Admin/" + b for b in ledger_api_haskellpb_sources_admin],
+    cmd = """
+        for src in $(locations :ledger-api-protos-fg-admin); do
+            $(location @haskell_proto3__suite//:compile-proto-file) \
+                --includeDir """ + google_protobuf_src + """ \
+                --includeDir """ + google_rpc_src + """ \
+                --includeDir """ + ledger_api_proto_source_root + """ \
+                --proto com/digitalasset/ledger/api/v1/admin/$$(basename $$src) \
+                --out $(@D)
+        done
+    """,
+    tools = [
+        "@haskell_proto3__suite//:compile-proto-file",
+    ],
+)
+
 da_haskell_library(
     name = "ledger-api-haskellpb",
     srcs = [
         ":google-protobuf-haskellpb-sources",
         ":google-rpc-haskellpb-sources",
         ":ledger-api-haskellpb-sources",
+        ":ledger-api-haskellpb-sources-admin",
         ":ledger-api-haskellpb-sources-testing",
     ],
     compiler_flags = ["-O0"],