From c21768c616f48313a863cfd63db1c51275a06870 Mon Sep 17 00:00:00 2001 From: Moritz Kiefer Date: Wed, 6 May 2020 12:09:34 +0200 Subject: [PATCH] Make Bearer prefix optional in Haskell ledger bindings (#5858) * Make Bearer prefix optional in Haskell ledger bindings This matches the change to the JVM bindings in 1.0.0 changelog_begin - [DAML Assistant] The ``daml ledger`` commands no longer require the ``Bearer `` prefix in the access token file. This matches the behavior of DAML Script and other SDK tools. changelog_end * Fix tasty crash changelog_begin changelog_end * Update compatibility/bazel_tools/daml_ledger/Main.hs Co-authored-by: Martin Huschenbett Co-authored-by: Martin Huschenbett --- compatibility/bazel_tools/daml_ledger/Main.hs | 66 ++++++++++++------- .../test/DA/Daml/Helper/Test/Deployment.hs | 57 +++++++++------- .../bindings/src/DA/Ledger/LedgerService.hs | 15 ++++- 3 files changed, 86 insertions(+), 52 deletions(-) diff --git a/compatibility/bazel_tools/daml_ledger/Main.hs b/compatibility/bazel_tools/daml_ledger/Main.hs index 2d1351d326f..aa04bfe7963 100644 --- a/compatibility/bazel_tools/daml_ledger/Main.hs +++ b/compatibility/bazel_tools/daml_ledger/Main.hs @@ -19,7 +19,7 @@ import System.IO.Extra (withTempDir,writeFileUTF8) import System.Process (CreateProcess,proc,readCreateProcessWithExitCode) import Test.Tasty (TestTree,askOption,defaultMainWithIngredients,defaultIngredients,includingOptions,testGroup,withResource) import Test.Tasty.Options (IsOption(..), OptionDescription(..), mkOptionCLParser) -import Test.Tasty.HUnit (testCaseSteps) +import Test.Tasty.HUnit (testCaseSteps, testCase) import qualified Bazel.Runfiles import qualified Data.Aeson as Aeson import qualified Data.List as List @@ -91,9 +91,13 @@ withTools tests = do } tests tools +-- | This is the version of daml-helper. newtype SdkVersion = SdkVersion String + deriving Eq instance IsOption SdkVersion where - defaultValue = SdkVersion (error "SDK version has to be set explicitly using --sdk-version") + defaultValue = SdkVersion "0.0.0" + -- Tasty seems to force the value somewhere so we cannot just set this + -- to `error`. However, this will always be set. parseValue = Just . SdkVersion optionName = Tagged "sdk-version" optionHelp = Tagged "The SDK version number" @@ -119,33 +123,45 @@ main = do , fetchTest sdkVersion getTools ] --- | Test `daml ledger upload-dar --access-token-file` +-- | Test `daml ledger list-parties --access-token-file` authenticatedUploadTest :: SdkVersion -> IO Tools -> TestTree authenticatedUploadTest sdkVersion getTools = do - let sharedSecret = "TheSharedSecret" - let getSandboxConfig = do + withSandbox getSandboxConfig $ \getSandboxPort -> testGroup "authentication" $ + [ testCase "Bearer prefix" $ do + Tools{..} <- getTools + port <- getSandboxPort + withTempDir $ \deployDir -> do + withCurrentDirectory deployDir $ do + let tokenFile = deployDir "secretToken.jwt" + -- The trailing newline is not required but we want to test that it is supported. + writeFileUTF8 tokenFile ("Bearer " <> makeSignedJwt sharedSecret <> "\n") + callProcessSilent daml + [ "ledger", "list-parties" + , "--access-token-file", tokenFile + , "--host", "localhost", "--port", show port + ] + ] <> + [ testCase "no Bearer prefix" $ do + Tools{..} <- getTools + port <- getSandboxPort + withTempDir $ \deployDir -> do + withCurrentDirectory deployDir $ do + let tokenFile = deployDir "secretToken.jwt" + -- The trailing newline is not required but we want to test that it is supported. + writeFileUTF8 tokenFile (makeSignedJwt sharedSecret <> "\n") + callProcessSilent daml + [ "ledger", "list-parties" + , "--access-token-file", tokenFile + , "--host", "localhost", "--port", show port + ] + | sdkVersion == SdkVersion "0.0.0" + -- TODO Once we have releases supporting this should be extended. + ] + where + sharedSecret = "TheSharedSecret" + getSandboxConfig = do cfg <- sandboxConfig <$> getTools pure cfg { mbSharedSecret = Just sharedSecret } - withSandbox getSandboxConfig $ \getSandboxPort -> - testCaseSteps "authenticatedUploadTest" $ \step -> do - Tools{..} <- getTools - port <- getSandboxPort - withTempDir $ \deployDir -> do - withCurrentDirectory deployDir $ do - writeMinimalProject sdkVersion - step "build" - callProcessSilent daml ["damlc", "build"] - let dar = ".daml/dist/proj1-0.0.1.dar" - let tokenFile = deployDir "secretToken.jwt" - step "upload" - -- The trailing newline is not required but we want to test that it is supported. - writeFileUTF8 tokenFile ("Bearer " <> makeSignedJwt sharedSecret <> "\n") - callProcessSilent daml - [ "ledger", "upload-dar" - , "--access-token-file", tokenFile - , "--host", "localhost", "--port", show port - , dar - ] makeSignedJwt :: String -> String makeSignedJwt sharedSecret = do diff --git a/daml-assistant/daml-helper/test/DA/Daml/Helper/Test/Deployment.hs b/daml-assistant/daml-helper/test/DA/Daml/Helper/Test/Deployment.hs index 73cb4b38005..4e800873fb8 100644 --- a/daml-assistant/daml-helper/test/DA/Daml/Helper/Test/Deployment.hs +++ b/daml-assistant/daml-helper/test/DA/Daml/Helper/Test/Deployment.hs @@ -8,7 +8,7 @@ import System.Environment.Blank (setEnv) import System.FilePath (()) import System.IO.Extra (withTempDir,writeFileUTF8) import Test.Tasty (TestTree,defaultMain,testGroup) -import Test.Tasty.HUnit (testCaseSteps) +import Test.Tasty.HUnit (testCase, testCaseSteps) import qualified "zip-archive" Codec.Archive.Zip as Zip import qualified Data.Aeson as Aeson import qualified Data.ByteString.Lazy as BSL @@ -41,33 +41,42 @@ main = do damlHelper <- locateRunfiles (mainWorkspace "daml-assistant" "daml-helper" exe "daml-helper") let tools = Tools {..} defaultMain $ testGroup "Deployment" - [ authenticatedUploadTest tools + [ authenticationTests tools , fetchTest tools ] --- | Test `daml ledger upload-dar --access-token-file` -authenticatedUploadTest :: Tools -> TestTree -authenticatedUploadTest Tools{..} = do - let sharedSecret = "TheSharedSecret" +-- | Test `daml ledger list-parties --access-token-file` +authenticationTests :: Tools -> TestTree +authenticationTests Tools{..} = withSandbox defaultSandboxConf { mbSharedSecret = Just sharedSecret } $ \getSandboxPort -> - testCaseSteps "authenticatedUploadTest" $ \step -> do - port <- getSandboxPort - withTempDir $ \deployDir -> do - withCurrentDirectory deployDir $ do - writeMinimalProject - step "build" - callProcessSilent damlc ["build"] - let dar = ".daml/dist/proj1-0.0.1.dar" - let tokenFile = deployDir "secretToken.jwt" - step "upload" - -- The trailing newline is not required but we want to test that it is supported. - writeFileUTF8 tokenFile ("Bearer " <> makeSignedJwt sharedSecret <> "\n") - callProcessSilent damlHelper - [ "ledger", "upload-dar" - , "--access-token-file", tokenFile - , "--host", "localhost", "--port", show port - , dar - ] + testGroup "authentication" + [ testCase "Bearer prefix" $ do + port <- getSandboxPort + withTempDir $ \deployDir -> do + withCurrentDirectory deployDir $ do + let tokenFile = deployDir "secretToken.jwt" + -- The trailing newline is not required but we want to test that it is supported. + writeFileUTF8 tokenFile ("Bearer " <> makeSignedJwt sharedSecret <> "\n") + callProcessSilent damlHelper + [ "ledger", "list-parties" + , "--access-token-file", tokenFile + , "--host", "localhost", "--port", show port + ] + , testCase "no Bearer prefix" $ do + port <- getSandboxPort + withTempDir $ \deployDir -> do + withCurrentDirectory deployDir $ do + let tokenFile = deployDir "secretToken.jwt" + -- The trailing newline is not required but we want to test that it is supported. + writeFileUTF8 tokenFile (makeSignedJwt sharedSecret <> "\n") + callProcessSilent damlHelper + [ "ledger", "list-parties" + , "--access-token-file", tokenFile + , "--host", "localhost", "--port", show port + ] + ] + where + sharedSecret = "TheSharedSecret" makeSignedJwt :: String -> String makeSignedJwt sharedSecret = do diff --git a/language-support/hs/bindings/src/DA/Ledger/LedgerService.hs b/language-support/hs/bindings/src/DA/Ledger/LedgerService.hs index ac871b726eb..e6d52285ddf 100644 --- a/language-support/hs/bindings/src/DA/Ledger/LedgerService.hs +++ b/language-support/hs/bindings/src/DA/Ledger/LedgerService.hs @@ -13,6 +13,7 @@ import Control.Monad.IO.Class (MonadIO) import Control.Monad.Reader (MonadReader,local,asks) import Control.Monad.Trans.Reader (ReaderT(..)) import DA.Ledger.Retry (ledgerRetry) +import Data.List import Network.GRPC.HighLevel.Client(TimeoutSeconds) import Network.GRPC.HighLevel.Generated(ClientConfig,MetadataMap(..)) import UnliftIO(MonadUnliftIO) @@ -39,6 +40,7 @@ runLedgerService (LedgerService r) ts cc = setToken :: Token -> LedgerService a -> LedgerService a setToken tok = local $ \context -> context { tokMaybe = Just tok } + makeLedgerService :: (TimeoutSeconds -> ClientConfig -> MetadataMap -> IO a) -> LedgerService a makeLedgerService f = do LedgerService $ ReaderT $ \Context{ts,cc,tokMaybe} -> @@ -47,9 +49,16 @@ makeLedgerService f = do makeMdm :: Maybe Token -> MetadataMap makeMdm = \case Nothing -> MetadataMap Map.empty - Just (Token tok) -> MetadataMap $ Map.fromList [ - ("authorization", - SortedList.toSortedList [ BSU8.fromString tok ])] + Just (Token tok) -> + -- This matches how the com.daml.ledger.api.auth.client.LedgerCallCredentials + -- behaves. + let tok' | "Bearer " `isPrefixOf` tok = tok + | otherwise = "Bearer " <> tok + in MetadataMap $ Map.fromList + [ ( "authorization" + , SortedList.toSortedList [ BSU8.fromString tok' ] + ) + ] askTimeout :: LedgerService TimeoutSeconds askTimeout = asks ts