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

daml-assistant/daml-helper/src/DA/Daml/Helper/Main.hs

@@ -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"

daml-assistant/daml-helper/src/DA/Daml/Helper/Start.hs

@@ -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

daml-assistant/daml-helper/src/DA/Daml/Helper/Util.hs

@@ -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

daml-assistant/integration-tests/BUILD.bazel

@@ -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 = [

daml-assistant/integration-tests/src/DA/Daml/Assistant/IntegrationTests.hs

@@ -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

libs-haskell/da-hs-base/BUILD.bazel

@@ -31,6 +31,7 @@ da_haskell_library(
         "lens",
         "monad-loops",
         "mtl",
+        "network",
         "optparse-applicative",
         "pretty-show",
         "pretty",

libs-haskell/da-hs-base/src/Network/Socket/Extended.hs

@@ -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