mirror of
https://github.com/digital-asset/daml.git
synced 2024-11-08 21:34:22 +03:00
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 <martin.huschenbett@posteo.me> Co-authored-by: Martin Huschenbett <martin.huschenbett@posteo.me>
This commit is contained in:
Moritz Kiefer
GitHub
parent
df12c529c8
commit
c21768c616
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user