diff --git a/language-support/hs/bindings/BUILD.bazel b/language-support/hs/bindings/BUILD.bazel index 8509567a015c..12be1aed8c96 100644 --- 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 index 4bb54b945def..856aec66c6e2 100644 --- 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 new file mode 100644 index 000000000000..e614d5ce08cc --- /dev/null +++ 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 index eb67c186dc8a..00816cb576e8 100644 --- 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 new file mode 100644 index 000000000000..2bc04b6dd89b --- /dev/null +++ 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 index 900ccfb75928..a1cf9c63f12a 100644 --- 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"],