diff --git a/daml-assistant/daml-helper/src/DA/Daml/Helper/Main.hs b/daml-assistant/daml-helper/src/DA/Daml/Helper/Main.hs index fa7b84fb74..ca4b5530c3 100644 --- a/daml-assistant/daml-helper/src/DA/Daml/Helper/Main.hs +++ b/daml-assistant/daml-helper/src/DA/Daml/Helper/Main.hs @@ -61,20 +61,9 @@ data Command | Init { targetFolderM :: Maybe FilePath } | ListTemplates | Start - { sandboxPortM :: Maybe SandboxPortSpec - , openBrowser :: OpenBrowser - , startNavigator :: Maybe StartNavigator - , navigatorPort :: NavigatorPort - , jsonApiCfg :: JsonApiConfig - , onStartM :: Maybe String - , waitForSignal :: WaitForSignal - , sandboxOptions :: SandboxOptions - , navigatorOptions :: NavigatorOptions - , jsonApiOptions :: JsonApiOptions - , scriptOptions :: ScriptOptions - , shutdownStdinClose :: Bool - , sandboxClassic :: SandboxClassic - } + { startOptions :: StartOptions + , shutdownStdinClose :: Bool + } | Deploy { flags :: LedgerFlags } | LedgerListParties { flags :: LedgerFlags, json :: JsonFlag } | LedgerAllocateParties { flags :: LedgerFlags, parties :: [String] } @@ -166,37 +155,21 @@ commandParser = subparser $ fold initCmd = Init <$> optional (argument str (metavar "TARGET_PATH" <> help "Project folder to initialize.")) - startCmd = Start - <$> optional (option (maybeReader (toSandboxPortSpec <=< readMaybe)) (long "sandbox-port" <> metavar "PORT_NUM" <> help "Port number for the sandbox")) - <*> (OpenBrowser <$> flagYesNoAuto "open-browser" True "Open the browser after navigator" idm) - <*> optional navigatorFlag - <*> navigatorPortOption - <*> jsonApiCfg - <*> optional (option str (long "on-start" <> metavar "COMMAND" <> help "Command to run once sandbox and navigator are running.")) - <*> (WaitForSignal <$> flagYesNoAuto "wait-for-signal" True "Wait for Ctrl+C or interrupt after starting servers." idm) - <*> (SandboxOptions <$> many (strOption (long "sandbox-option" <> metavar "SANDBOX_OPTION" <> help "Pass option to sandbox"))) - <*> (NavigatorOptions <$> many (strOption (long "navigator-option" <> metavar "NAVIGATOR_OPTION" <> help "Pass option to navigator"))) - <*> (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"))) - <*> stdinCloseOpt - <*> (SandboxClassic <$> switch (long "sandbox-classic" <> help "Deprecated. Run with Sandbox Classic.")) - - navigatorFlag = - -- We do not use flagYesNoAuto here since that doesn’t allow us to differentiate - -- if the flag was passed explicitly or not. - StartNavigator <$> - option reader (long "start-navigator" <> help helpText <> completeWith ["true", "false"] <> idm) - where - reader = eitherReader $ \case - -- We allow for both yes and true since we want a boolean in daml.yaml - "true" -> Right True - "yes" -> Right True - "false" -> Right False - "no" -> Right False - "auto" -> Right True - s -> Left ("Expected \"yes\", \"true\", \"no\", \"false\" or \"auto\" but got " <> show s) - -- To make things less confusing, we do not mention yes, no and auto here. - helpText = "Start navigator as part of daml start. Can be set to true or false. Defaults to true." + startCmd = do + sandboxPortM <- optional (option (maybeReader (toSandboxPortSpec <=< readMaybe)) (long "sandbox-port" <> metavar "PORT_NUM" <> help "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 + jsonApiConfig <- jsonApiCfg + onStartM <- optional (option str (long "on-start" <> metavar "COMMAND" <> help "Command to run once sandbox and navigator are running.")) + shouldWaitForSignal <- flagYesNoAuto "wait-for-signal" True "Wait for Ctrl+C or interrupt after starting servers." idm + sandboxOptions <- many (strOption (long "sandbox-option" <> metavar "SANDBOX_OPTION" <> help "Pass option to sandbox")) + navigatorOptions <- many (strOption (long "navigator-option" <> metavar "NAVIGATOR_OPTION" <> help "Pass option to navigator")) + 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.") + pure $ Start StartOptions{..} shutdownStdinClose navigatorPortOption = NavigatorPort <$> option auto (long "navigator-port" @@ -475,19 +448,7 @@ runCommand = \case ListTemplates -> runListTemplates Start {..} -> (if shutdownStdinClose then withCloseOnStdin else id) $ - runStart - sandboxPortM - startNavigator - navigatorPort - jsonApiCfg - openBrowser - onStartM - waitForSignal - sandboxOptions - navigatorOptions - jsonApiOptions - scriptOptions - sandboxClassic + runStart startOptions Deploy {..} -> runDeploy flags LedgerListParties {..} -> runLedgerListParties flags json PackagesList {..} -> runLedgerListPackages0 flags diff --git a/daml-assistant/daml-helper/src/DA/Daml/Helper/Start.hs b/daml-assistant/daml-helper/src/DA/Daml/Helper/Start.hs index 34c22b2fb3..fb0d98ba87 100644 --- a/daml-assistant/daml-helper/src/DA/Daml/Helper/Start.hs +++ b/daml-assistant/daml-helper/src/DA/Daml/Helper/Start.hs @@ -8,19 +8,13 @@ module DA.Daml.Helper.Start , withSandbox , withNavigator + , StartOptions(..) , NavigatorPort(..) , SandboxPort(..) , SandboxPortSpec(..) , toSandboxPortSpec , JsonApiPort(..) , JsonApiConfig(..) - , OpenBrowser(..) - , StartNavigator(..) - , WaitForSignal(..) - , SandboxOptions(..) - , NavigatorOptions(..) - , JsonApiOptions(..) - , ScriptOptions(..) , SandboxClassic(..) ) where @@ -46,6 +40,8 @@ import Web.Browser import qualified Web.JWT as JWT import Data.Aeson +import Options.Applicative.Extended (YesNoAuto, determineAutoM) + import DA.Daml.Helper.Codegen import DA.Daml.Helper.Ledger import DA.Daml.Helper.Util @@ -153,23 +149,10 @@ withJsonApi (SandboxPort sandboxPort) (JsonApiPort jsonApiPort) extraArgs a = do waitForHttpServer (putStr "." *> threadDelay 500000) ("http://localhost:" <> show jsonApiPort <> "/v1/query") headers a ph --- | Whether `daml start` should open a browser automatically. -newtype OpenBrowser = OpenBrowser Bool - --- | Whether `daml start` should start the navigator automatically. -newtype StartNavigator = StartNavigator Bool - data JsonApiConfig = JsonApiConfig { mbJsonApiPort :: Maybe JsonApiPort -- If Nothing, don’t start the JSON API } --- | Whether `daml start` should wait for Ctrl+C or interrupt after starting servers. -newtype WaitForSignal = WaitForSignal Bool - -newtype SandboxOptions = SandboxOptions [String] -newtype NavigatorOptions = NavigatorOptions [String] -newtype JsonApiOptions = JsonApiOptions [String] -newtype ScriptOptions = ScriptOptions [String] newtype SandboxClassic = SandboxClassic { unSandboxClassic :: Bool } withOptsFromProjectConfig :: T.Text -> [String] -> ProjectConfig -> IO [String] @@ -180,35 +163,24 @@ withOptsFromProjectConfig fieldName cliOpts projectConfig = do queryProjectConfig [fieldName] projectConfig pure (optsYaml ++ cliOpts) +data StartOptions = StartOptions + { sandboxPortM :: Maybe SandboxPortSpec + , shouldOpenBrowser :: Bool + , shouldStartNavigator :: YesNoAuto + , navigatorPort :: NavigatorPort + , jsonApiConfig :: JsonApiConfig + , onStartM :: Maybe String + , shouldWaitForSignal :: Bool + , sandboxOptions :: [String] + , navigatorOptions :: [String] + , jsonApiOptions :: [String] + , scriptOptions :: [String] + , sandboxClassic :: SandboxClassic + } -runStart - :: Maybe SandboxPortSpec - -> Maybe StartNavigator - -> NavigatorPort - -> JsonApiConfig - -> OpenBrowser - -> Maybe String - -> WaitForSignal - -> SandboxOptions - -> NavigatorOptions - -> JsonApiOptions - -> ScriptOptions - -> SandboxClassic - -> IO () -runStart - sandboxPortM - mbStartNavigator - navigatorPort - (JsonApiConfig mbJsonApiPort) - (OpenBrowser shouldOpenBrowser) - onStartM - (WaitForSignal shouldWaitForSignal) - (SandboxOptions sandboxOpts) - (NavigatorOptions navigatorOpts) - (JsonApiOptions jsonApiOpts) - (ScriptOptions scriptOpts) - sandboxClassic - = withProjectRoot Nothing (ProjectCheck "daml start" True) $ \_ _ -> do +runStart :: StartOptions -> IO () +runStart StartOptions{..} = + withProjectRoot Nothing (ProjectCheck "daml start" True) $ \_ _ -> do projectConfig <- getProjectConfig Nothing darPath <- getDarPath mbScenario :: Maybe String <- @@ -217,17 +189,15 @@ runStart mbInitScript :: Maybe String <- requiredE "Failed to parse init-script" $ queryProjectConfig ["init-script"] projectConfig - shouldStartNavigator :: Bool <- case mbStartNavigator of - -- If an option is passed explicitly, we use it, otherwise we read daml.yaml. - Nothing -> - fmap (fromMaybe True) $ - requiredE "Failed to parse start-navigator" $ - queryProjectConfig ["start-navigator"] projectConfig - Just (StartNavigator explicit) -> pure explicit - sandboxOpts <- withOptsFromProjectConfig "sandbox-options" sandboxOpts projectConfig - navigatorOpts <- withOptsFromProjectConfig "navigator-options" navigatorOpts projectConfig - jsonApiOpts <- withOptsFromProjectConfig "json-api-options" jsonApiOpts projectConfig - scriptOpts <- withOptsFromProjectConfig "script-options" scriptOpts projectConfig + shouldStartNavigator :: Bool <- + determineAutoM (fmap (fromMaybe True) $ + requiredE "Failed to parse start-navigator" $ + queryProjectConfig ["start-navigator"] projectConfig) + shouldStartNavigator + sandboxOpts <- withOptsFromProjectConfig "sandbox-options" sandboxOptions projectConfig + navigatorOpts <- withOptsFromProjectConfig "navigator-options" navigatorOptions projectConfig + jsonApiOpts <- withOptsFromProjectConfig "json-api-options" jsonApiOptions projectConfig + scriptOpts <- withOptsFromProjectConfig "script-options" scriptOptions projectConfig doBuild doCodegen projectConfig let scenarioArgs = maybe [] (\scenario -> ["--scenario", scenario]) mbScenario @@ -266,7 +236,7 @@ runStart then withNavigator else (\_ _ _ f -> f sandboxPh) withJsonApi' sandboxPh sandboxPort args f = - case mbJsonApiPort of + case mbJsonApiPort jsonApiConfig of Nothing -> f sandboxPh Just jsonApiPort -> withJsonApi sandboxPort jsonApiPort args f doCodegen projectConfig = diff --git a/libs-haskell/da-hs-base/src/Options/Applicative/Extended.hs b/libs-haskell/da-hs-base/src/Options/Applicative/Extended.hs index ecfb68c0c1..ad6adc6a76 100644 --- a/libs-haskell/da-hs-base/src/Options/Applicative/Extended.hs +++ b/libs-haskell/da-hs-base/src/Options/Applicative/Extended.hs @@ -7,6 +7,7 @@ module Options.Applicative.Extended , flagYesNoAuto , flagYesNoAuto' , determineAuto + , determineAutoM ) where import Options.Applicative @@ -25,16 +26,25 @@ determineAuto b = \case Auto -> b Yes -> True +-- | Convert YesNoAuto value to Bool by specifying how default value for Auto should be determined, in a monad. +determineAutoM :: Monad m => m Bool -> YesNoAuto -> m Bool +determineAutoM m = \case + No -> pure False + Auto -> m + Yes -> pure True + -- | This constructs flags that can be set to yes, no, or auto, with auto being the default. -- This maps yes to "Just true", no to "Just False" and auto to "Nothing" flagYesNoAuto' :: String -> String -> Mod OptionFields YesNoAuto -> Parser YesNoAuto flagYesNoAuto' flagName helpText mods = - option reader (long flagName <> value Auto <> help helpText <> completeWith ["yes", "no", "auto"] <> mods) + option reader (long flagName <> value Auto <> help helpText <> completeWith ["true", "false", "yes", "no", "auto"] <> mods) where reader = eitherReader $ \case "yes" -> Right Yes + "true" -> Right Yes "no" -> Right No + "false" -> Right No "auto" -> Right Auto - s -> Left ("Expected \"yes\", \"no\" or \"auto\" but got " <> show s) + s -> Left ("Expected \"yes\", \"true\", \"no\", \"false\", or \"auto\" but got " <> show s) -- | This constructs flags that can be set to yes, no, or auto to control a boolean value -- with auto using the default.