mirror of
https://github.com/digital-asset/daml.git
synced 2024-09-11 12:59:17 +03:00
Add --sandbox-canton option in daml start (#12192)
* --sandbox-canton option for daml start changelog_begin changelog_end * hlint * Move getFreePort to da-hs-base * Use flag' not switch
This commit is contained in:
parent
d922a562a8
commit
830497ae34
@ -156,7 +156,7 @@ commandParser = subparser $ fold
|
||||
<$> optional (argument str (metavar "TARGET_PATH" <> help "Project folder to initialize."))
|
||||
|
||||
startCmd = do
|
||||
sandboxPortM <- optional (option (maybeReader (toSandboxPortSpec <=< readMaybe)) (long "sandbox-port" <> metavar "PORT_NUM" <> help "Port number for the sandbox"))
|
||||
sandboxPortM <- sandboxPortOpt "sandbox-port" "Port number for the sandbox"
|
||||
shouldOpenBrowser <- flagYesNoAuto "open-browser" True "Open the browser after navigator" idm
|
||||
shouldStartNavigator <- flagYesNoAuto' "start-navigator" "Start navigator as part of daml start. Can be set to true or false. Defaults to true." idm
|
||||
navigatorPort <- navigatorPortOption
|
||||
@ -168,9 +168,28 @@ commandParser = subparser $ fold
|
||||
jsonApiOptions <- many (strOption (long "json-api-option" <> metavar "JSON_API_OPTION" <> help "Pass option to HTTP JSON API"))
|
||||
scriptOptions <- many (strOption (long "script-option" <> metavar "SCRIPT_OPTION" <> help "Pass option to Daml script interpreter"))
|
||||
shutdownStdinClose <- stdinCloseOpt
|
||||
sandboxClassic <- SandboxClassic <$> switch (long "sandbox-classic" <> help "Deprecated. Run with Sandbox Classic.")
|
||||
sandboxChoice <- sandboxChoiceOpt
|
||||
pure $ Start StartOptions{..} shutdownStdinClose
|
||||
|
||||
sandboxPortOpt name desc =
|
||||
optional (option (maybeReader (toSandboxPortSpec <=< readMaybe))
|
||||
(long name <> metavar "PORT_NUM" <> help desc))
|
||||
|
||||
sandboxChoiceOpt =
|
||||
flag' SandboxClassic (long "sandbox-classic" <> help "Deprecated. Run with Sandbox Classic.")
|
||||
<|> flag' SandboxKV (long "sandbox-kv" <> help "Deprecated. Run with Sandbox KV.")
|
||||
<|> flag' SandboxCanton (long "sandbox-canton" <> help "Run with Canton Sandbox. The 2.0 default.")
|
||||
<*> sandboxCantonPortSpecOpt
|
||||
<|> pure SandboxKV -- pre-2.0 default
|
||||
-- TODO https://github.com/digital-asset/daml/issues/11831
|
||||
-- Change default to --sandbox-canton
|
||||
|
||||
sandboxCantonPortSpecOpt = do
|
||||
adminApiSpec <- sandboxPortOpt "canton-admin-api-port" "Port number for the canton admin API (--sandbox-canton only)"
|
||||
domainPublicApiSpec <- sandboxPortOpt "canton-domain-public-port" "Port number for the canton domain public API (--sandbox-canton only)"
|
||||
domainAdminApiSpec <- sandboxPortOpt "canton-domain-admin-port" "Port number for the canton domain admin API (--sandbox-canton only)"
|
||||
pure SandboxCantonPortSpec {..}
|
||||
|
||||
navigatorPortOption = NavigatorPort <$> option auto
|
||||
(long "navigator-port"
|
||||
<> metavar "PORT_NUM"
|
||||
|
@ -15,7 +15,8 @@ module DA.Daml.Helper.Start
|
||||
, toSandboxPortSpec
|
||||
, JsonApiPort(..)
|
||||
, JsonApiConfig(..)
|
||||
, SandboxClassic(..)
|
||||
, SandboxChoice(..)
|
||||
, SandboxCantonPortSpec(..)
|
||||
) where
|
||||
|
||||
import Control.Concurrent
|
||||
@ -30,6 +31,7 @@ import DA.PortFile
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Network.HTTP.Simple as HTTP
|
||||
import Network.Socket.Extended (getFreePort)
|
||||
import System.Console.ANSI
|
||||
import System.Environment (getEnvironment, getEnv, lookupEnv)
|
||||
import System.FilePath
|
||||
@ -78,14 +80,14 @@ data SandboxPortSpec = FreePort | SpecifiedPort SandboxPort
|
||||
toSandboxPortSpec :: Int -> Maybe SandboxPortSpec
|
||||
toSandboxPortSpec n
|
||||
| n < 0 = Nothing
|
||||
| n == 0 = Just FreePort
|
||||
| n == 0 = Just FreePort
|
||||
| otherwise = Just (SpecifiedPort (SandboxPort n))
|
||||
|
||||
fromSandboxPortSpec :: SandboxPortSpec -> Int
|
||||
fromSandboxPortSpec FreePort = 0
|
||||
fromSandboxPortSpec (SpecifiedPort (SandboxPort n)) = n
|
||||
|
||||
newtype SandboxPort = SandboxPort Int
|
||||
newtype SandboxPort = SandboxPort { unSandboxPort :: Int }
|
||||
newtype NavigatorPort = NavigatorPort Int
|
||||
newtype JsonApiPort = JsonApiPort Int
|
||||
|
||||
@ -95,20 +97,53 @@ navigatorPortNavigatorArgs (NavigatorPort p) = ["--port", show p]
|
||||
navigatorURL :: NavigatorPort -> String
|
||||
navigatorURL (NavigatorPort p) = "http://localhost:" <> show p
|
||||
|
||||
withSandbox :: SandboxClassic -> Maybe SandboxPortSpec -> [String] -> (Process () () () -> SandboxPort -> IO a) -> IO a
|
||||
withSandbox (SandboxClassic classic) mbPortSpec extraArgs a = withTempDir $ \tempDir -> do
|
||||
let portFile = tempDir </> "sandbox-portfile"
|
||||
let sandbox = if classic then "sandbox-classic" else "sandbox"
|
||||
let args = concat
|
||||
[ [ sandbox ]
|
||||
, concat [ [ "--port", show (fromSandboxPortSpec portSpec) ] | Just portSpec <- [mbPortSpec] ]
|
||||
, [ "--port-file", portFile ]
|
||||
, extraArgs
|
||||
]
|
||||
withPlatformJar args "sandbox-logback.xml" $ \ph -> do
|
||||
putStrLn "Waiting for sandbox to start: "
|
||||
port <- readPortFile maxRetries portFile
|
||||
a ph (SandboxPort port)
|
||||
-- | Use SandboxPortSpec to determine a sandbox port number.
|
||||
-- This is racy thanks to getFreePort, but there's no good alternative at the moment.
|
||||
getPortForSandbox :: Int -> Maybe SandboxPortSpec -> IO Int
|
||||
getPortForSandbox defaultPort = \case
|
||||
Nothing -> pure defaultPort
|
||||
Just (SpecifiedPort port) -> pure (unSandboxPort port)
|
||||
Just FreePort -> fromIntegral <$> getFreePort
|
||||
|
||||
determineCantonPorts :: Maybe SandboxPortSpec -> SandboxCantonPortSpec -> IO CantonPorts
|
||||
determineCantonPorts ledgerApiSpec SandboxCantonPortSpec{..} = do
|
||||
ledgerApi <- getPortForSandbox 6865 ledgerApiSpec
|
||||
adminApi <- getPortForSandbox 6866 adminApiSpec
|
||||
domainPublicApi <- getPortForSandbox 6867 domainPublicApiSpec
|
||||
domainAdminApi <- getPortForSandbox 6868 domainAdminApiSpec
|
||||
pure CantonPorts {..}
|
||||
|
||||
withSandbox :: StartOptions -> FilePath -> [String] -> [String] -> (Process () () () -> SandboxPort -> IO a) -> IO a
|
||||
withSandbox StartOptions{..} darPath scenarioArgs sandboxArgs kont =
|
||||
case sandboxChoice of
|
||||
SandboxClassic -> oldSandbox "sandbox-classic"
|
||||
SandboxKV -> oldSandbox "sandbox"
|
||||
SandboxCanton cantonPortSpec -> cantonSandbox cantonPortSpec
|
||||
|
||||
where
|
||||
cantonSandbox cantonPortSpec = do
|
||||
cantonPorts <- determineCantonPorts sandboxPortM cantonPortSpec
|
||||
withCantonSandbox cantonPorts sandboxArgs $ \ph -> do
|
||||
let sandboxPort = ledgerApi cantonPorts
|
||||
putStrLn "Waiting for canton sandbox to start: "
|
||||
waitForConnectionOnPort (putStr "." *> threadDelay 500000) sandboxPort
|
||||
runLedgerUploadDar ((defaultLedgerFlags Grpc) {fPortM = Just sandboxPort}) (Just darPath)
|
||||
kont ph (SandboxPort sandboxPort)
|
||||
|
||||
oldSandbox sandbox = withTempDir $ \tempDir -> do
|
||||
let portFile = tempDir </> "sandbox-portfile"
|
||||
let args = concat
|
||||
[ [ sandbox ]
|
||||
, concat [ [ "--port", show (fromSandboxPortSpec portSpec) ] | Just portSpec <- [sandboxPortM] ]
|
||||
, [ "--port-file", portFile ]
|
||||
, [ darPath ]
|
||||
, scenarioArgs
|
||||
, sandboxArgs
|
||||
]
|
||||
withPlatformJar args "sandbox-logback.xml" $ \ph -> do
|
||||
putStrLn "Waiting for sandbox to start: "
|
||||
port <- readPortFile maxRetries portFile
|
||||
kont ph (SandboxPort port)
|
||||
|
||||
withNavigator :: SandboxPort -> NavigatorPort -> [String] -> (Process () () () -> IO a) -> IO a
|
||||
withNavigator (SandboxPort sandboxPort) navigatorPort args a = do
|
||||
@ -153,8 +188,6 @@ data JsonApiConfig = JsonApiConfig
|
||||
{ mbJsonApiPort :: Maybe JsonApiPort -- If Nothing, don’t start the JSON API
|
||||
}
|
||||
|
||||
newtype SandboxClassic = SandboxClassic { unSandboxClassic :: Bool }
|
||||
|
||||
withOptsFromProjectConfig :: T.Text -> [String] -> ProjectConfig -> IO [String]
|
||||
withOptsFromProjectConfig fieldName cliOpts projectConfig = do
|
||||
optsYaml :: [String] <-
|
||||
@ -175,11 +208,22 @@ data StartOptions = StartOptions
|
||||
, navigatorOptions :: [String]
|
||||
, jsonApiOptions :: [String]
|
||||
, scriptOptions :: [String]
|
||||
, sandboxClassic :: SandboxClassic
|
||||
, sandboxChoice :: !SandboxChoice
|
||||
}
|
||||
|
||||
data SandboxChoice
|
||||
= SandboxClassic
|
||||
| SandboxKV
|
||||
| SandboxCanton !SandboxCantonPortSpec
|
||||
|
||||
data SandboxCantonPortSpec = SandboxCantonPortSpec
|
||||
{ adminApiSpec :: !(Maybe SandboxPortSpec)
|
||||
, domainPublicApiSpec :: !(Maybe SandboxPortSpec)
|
||||
, domainAdminApiSpec :: !(Maybe SandboxPortSpec)
|
||||
}
|
||||
|
||||
runStart :: StartOptions -> IO ()
|
||||
runStart StartOptions{..} =
|
||||
runStart startOptions@StartOptions{..} =
|
||||
withProjectRoot Nothing (ProjectCheck "daml start" True) $ \_ _ -> do
|
||||
projectConfig <- getProjectConfig Nothing
|
||||
darPath <- getDarPath
|
||||
@ -201,7 +245,7 @@ runStart StartOptions{..} =
|
||||
doBuild
|
||||
doCodegen projectConfig
|
||||
let scenarioArgs = maybe [] (\scenario -> ["--scenario", scenario]) mbScenario
|
||||
withSandbox sandboxClassic sandboxPortM (darPath : scenarioArgs ++ sandboxOpts) $ \sandboxPh sandboxPort -> do
|
||||
withSandbox startOptions darPath scenarioArgs sandboxOpts $ \sandboxPh sandboxPort -> do
|
||||
let doRunInitScript =
|
||||
whenJust mbInitScript $ \initScript -> do
|
||||
putStrLn "Running the initialization script."
|
||||
@ -217,7 +261,7 @@ runStart StartOptions{..} =
|
||||
, "--ledger-host"
|
||||
, "localhost"
|
||||
, "--ledger-port"
|
||||
, case sandboxPort of SandboxPort port -> show port
|
||||
, show (unSandboxPort sandboxPort)
|
||||
] ++ scriptOpts
|
||||
runProcess_ procScript
|
||||
doRunInitScript
|
||||
|
@ -19,6 +19,7 @@ module DA.Daml.Helper.Util
|
||||
, withJar
|
||||
, runJar
|
||||
, runCantonSandbox
|
||||
, withCantonSandbox
|
||||
, getLogbackArg
|
||||
, waitForConnectionOnPort
|
||||
, waitForHttpServer
|
||||
@ -246,17 +247,20 @@ tokenFor parties ledgerId applicationId =
|
||||
}
|
||||
|
||||
runCantonSandbox :: CantonPorts -> [String] -> IO ()
|
||||
runCantonSandbox ports remainingArgs = do
|
||||
runCantonSandbox ports args = withCantonSandbox ports args (const $ pure ())
|
||||
|
||||
withCantonSandbox :: CantonPorts -> [String] -> (Process () () () -> IO a) -> IO a
|
||||
withCantonSandbox ports remainingArgs k = do
|
||||
sdkPath <- getSdkPath
|
||||
let cantonJar = sdkPath </> "canton" </> "canton.jar"
|
||||
withTempFile $ \config ->
|
||||
withTempFile $ \config -> do
|
||||
withTempFile $ \bootstrap -> do
|
||||
BSL.writeFile config (cantonConfig ports)
|
||||
T.writeFileUtf8 bootstrap $ T.unlines
|
||||
[ "sandbox.domains.connect_local(local)"
|
||||
, "println(\"Canton sandbox started\")"
|
||||
]
|
||||
runJar cantonJar Nothing ("daemon" : "-c" : config : "--bootstrap" : bootstrap : remainingArgs)
|
||||
[ "sandbox.domains.connect_local(local)"
|
||||
, "println(\"Canton sandbox started\")"
|
||||
]
|
||||
withJar cantonJar [] ("daemon" : "-c" : config : "--bootstrap" : bootstrap : remainingArgs) k
|
||||
|
||||
data CantonPorts = CantonPorts
|
||||
{ ledgerApi :: Int
|
||||
|
@ -107,7 +107,6 @@ da_haskell_test(
|
||||
name = "integration-tests",
|
||||
timeout = "long",
|
||||
srcs = [
|
||||
"src/DA/Daml/Assistant/FreePort.hs",
|
||||
"src/DA/Daml/Assistant/IntegrationTests.hs",
|
||||
],
|
||||
args = [
|
||||
|
@ -19,7 +19,7 @@ import qualified Data.Text.Encoding as T
|
||||
import qualified Data.Vector as Vector
|
||||
import Network.HTTP.Client
|
||||
import Network.HTTP.Types
|
||||
import Network.Socket
|
||||
import Network.Socket.Extended
|
||||
import System.Directory.Extra
|
||||
import System.Environment.Blank
|
||||
import System.FilePath
|
||||
@ -30,7 +30,6 @@ import Test.Tasty
|
||||
import Test.Tasty.HUnit
|
||||
|
||||
import DA.Bazel.Runfiles
|
||||
import DA.Daml.Assistant.FreePort (getFreePort, socketHints)
|
||||
import DA.Daml.Assistant.IntegrationTestUtils
|
||||
import DA.Daml.Helper.Util (waitForConnectionOnPort, waitForHttpServer, tokenFor)
|
||||
-- import DA.PortFile
|
||||
|
@ -31,6 +31,7 @@ da_haskell_library(
|
||||
"lens",
|
||||
"monad-loops",
|
||||
"mtl",
|
||||
"network",
|
||||
"optparse-applicative",
|
||||
"pretty-show",
|
||||
"pretty",
|
||||
|
@ -1,7 +1,11 @@
|
||||
-- Copyright (c) 2021 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
module DA.Daml.Assistant.FreePort (getFreePort,socketHints) where
|
||||
module Network.Socket.Extended
|
||||
( module Network.Socket
|
||||
, getFreePort
|
||||
, socketHints
|
||||
) where
|
||||
|
||||
import Control.Exception (bracket)
|
||||
import Network.Socket
|
Loading…
Reference in New Issue
Block a user