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 6795eab36c..fced47d26f 100644 --- a/daml-assistant/daml-helper/src/DA/Daml/Helper/Main.hs +++ b/daml-assistant/daml-helper/src/DA/Daml/Helper/Main.hs @@ -49,6 +49,7 @@ data Command , sandboxOptions :: SandboxOptions , navigatorOptions :: NavigatorOptions , jsonApiOptions :: JsonApiOptions + , scriptOptions :: ScriptOptions , shutdownStdinClose :: Bool } | Deploy { flags :: LedgerFlags } @@ -124,6 +125,7 @@ commandParser = subparser $ fold <*> (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 deployCmdInfo = mconcat @@ -274,6 +276,7 @@ runCommand = \case sandboxOptions navigatorOptions jsonApiOptions + scriptOptions Deploy {..} -> runDeploy flags LedgerListParties {..} -> runLedgerListParties flags json LedgerAllocateParties {..} -> runLedgerAllocateParties flags parties diff --git a/daml-assistant/daml-helper/src/DA/Daml/Helper/Run.hs b/daml-assistant/daml-helper/src/DA/Daml/Helper/Run.hs index 5e3da76b0d..2f07a16c98 100644 --- a/daml-assistant/daml-helper/src/DA/Daml/Helper/Run.hs +++ b/daml-assistant/daml-helper/src/DA/Daml/Helper/Run.hs @@ -39,6 +39,7 @@ module DA.Daml.Helper.Run , SandboxOptions(..) , NavigatorOptions(..) , JsonApiOptions(..) + , ScriptOptions(..) ) where import Control.Concurrent @@ -772,6 +773,7 @@ newtype WaitForSignal = WaitForSignal Bool newtype SandboxOptions = SandboxOptions [String] newtype NavigatorOptions = NavigatorOptions [String] newtype JsonApiOptions = JsonApiOptions [String] +newtype ScriptOptions = ScriptOptions [String] runStart :: Maybe SandboxPort @@ -783,6 +785,7 @@ runStart -> SandboxOptions -> NavigatorOptions -> JsonApiOptions + -> ScriptOptions -> IO () runStart sandboxPortM @@ -794,6 +797,7 @@ runStart (SandboxOptions sandboxOpts) (NavigatorOptions navigatorOpts) (JsonApiOptions jsonApiOpts) + (ScriptOptions scriptOpts) = withProjectRoot Nothing (ProjectCheck "daml start" True) $ \_ _ -> do let sandboxPort = fromMaybe defaultSandboxPort sandboxPortM projectConfig <- getProjectConfig @@ -801,10 +805,29 @@ runStart mbScenario :: Maybe String <- requiredE "Failed to parse scenario" $ queryProjectConfig ["scenario"] projectConfig + mbInitScript :: Maybe String <- + requiredE "Failed to parse init-script" $ + queryProjectConfig ["init-script"] projectConfig doBuild let scenarioArgs = maybe [] (\scenario -> ["--scenario", scenario]) mbScenario withSandbox sandboxPort (darPath : scenarioArgs ++ sandboxOpts) $ \sandboxPh -> do withNavigator' sandboxPh sandboxPort navigatorPort navigatorOpts $ \navigatorPh -> do + whenJust mbInitScript $ \initScript -> do + procScript <- toAssistantCommand $ + [ "script" + , "--dar" + , darPath + , "--script-name" + , initScript + , if any (`elem` ["-w", "--wall-clock-time"]) sandboxOpts + then "--wall-clock-time" + else "--static-time" + , "--ledger-host" + , "localhost" + , "--ledger-port" + , case sandboxPort of SandboxPort port -> show port + ] ++ scriptOpts + runProcess_ procScript whenJust onStartM $ \onStart -> runProcess_ (shell onStart) when (shouldStartNavigator && shouldOpenBrowser) $ void $ openBrowser (navigatorURL navigatorPort) diff --git a/daml-assistant/integration-tests/BUILD.bazel b/daml-assistant/integration-tests/BUILD.bazel index b0d7e6b832..e6bb82dd50 100644 --- a/daml-assistant/integration-tests/BUILD.bazel +++ b/daml-assistant/integration-tests/BUILD.bazel @@ -98,6 +98,7 @@ da_haskell_test( "main-tester", "network", "unix-compat", + "unordered-containers", "process", "tar", "tar-conduit", diff --git a/daml-assistant/integration-tests/src/DA/Daml/Assistant/IntegrationTests.hs b/daml-assistant/integration-tests/src/DA/Daml/Assistant/IntegrationTests.hs index 6a2dbc2b29..36e3954919 100644 --- a/daml-assistant/integration-tests/src/DA/Daml/Assistant/IntegrationTests.hs +++ b/daml-assistant/integration-tests/src/DA/Daml/Assistant/IntegrationTests.hs @@ -8,13 +8,15 @@ import Control.Concurrent.Async import Control.Exception import Control.Monad import Control.Monad.Fail (MonadFail) -import qualified Data.Aeson.Types as Aeson +import qualified Data.Aeson as Aeson import qualified Data.Conduit.Tar.Extra as Tar.Conduit.Extra import qualified Data.Conduit.Zlib as Zlib import Data.List.Extra +import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map import Data.Maybe (maybeToList) import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Data.Typeable import Network.HTTP.Client import Network.HTTP.Types @@ -185,6 +187,75 @@ packagingTests = testGroup "packaging" withCurrentDirectory projDir $ callCommandQuiet "daml build" let dar = projDir ".daml/dist/script-example-0.0.1.dar" assertBool "script-example-0.0.1.dar was not created." =<< doesFileExist dar + , testCase "Run init-script" $ withTempDir $ \tmpDir -> do + let projDir = tmpDir "init-script-example" + createDirectoryIfMissing True (projDir "daml") + writeFileUTF8 (projDir "daml.yaml") $ unlines + [ "sdk-version: " <> sdkVersion + , "name: init-script-example" + , "version: \"1.0\"" + , "source: daml" + , "dependencies:" + , " - daml-prim" + , " - daml-stdlib" + , " - daml-script" + , "parties:" + , "- Alice" + , "init-script: Main:init" + ] + writeFileUTF8 (projDir "daml/Main.daml") $ unlines + [ "daml 1.2" + , "module Main where" + , "import Prelude hiding (submit)" + , "import Daml.Script" + , "template T with p : Party where signatory p" + , "init : Script ()" + , "init = do" + , " alice <- allocatePartyWithHint \"Alice\" (PartyIdHint \"Alice\")" + , " alice `submit` createCmd (T alice)" + , " pure ()" + ] + sandboxPort :: Int <- fromIntegral <$> getFreePort + jsonApiPort :: Int <- fromIntegral <$> getFreePort + let startProc = shell $ unwords + [ "daml" + , "start" + , "--start-navigator" + , "no" + , "--sandbox-port" + , show sandboxPort + , "--json-api-port" + , show jsonApiPort + ] + withCurrentDirectory projDir $ + withCreateProcess startProc $ \_ _ _ startPh -> + race_ (waitForProcess' startProc startPh) $ do + -- The hard-coded secret for testing is "secret". + let token = JWT.encodeSigned (JWT.HMACSecret "secret") mempty mempty + { JWT.unregisteredClaims = JWT.ClaimsMap $ + Map.fromList [("https://daml.com/ledger-api", Aeson.Object $ HashMap.fromList [("actAs", Aeson.toJSON ["Alice" :: T.Text]), ("ledgerId", "MyLedger"), ("applicationId", "foobar")])] + } + let headers = + [ ("Authorization", "Bearer " <> T.encodeUtf8 token) + ] :: RequestHeaders + waitForHttpServer (threadDelay 100000) ("http://localhost:" <> show jsonApiPort <> "/v1/query") headers + initialRequest <- parseRequest $ "http://localhost:" <> show jsonApiPort <> "/v1/query" + let queryRequest = initialRequest + { method = "POST" + , requestHeaders = headers + , requestBody = RequestBodyLBS $ Aeson.encode $ Aeson.object + ["templateIds" Aeson..= [Aeson.String "Main:T"]] + } + manager <- newManager defaultManagerSettings + queryResponse <- httpLbs queryRequest manager + statusCode (responseStatus queryResponse) @?= 200 + case Aeson.decode (responseBody queryResponse) of + Just (Aeson.Object body) + | Just (Aeson.Array result) <- HashMap.lookup "result" body + -> length result @?= 1 + _ -> assertFailure "Expected JSON object in response body" + -- waitForProcess' will block on Windows so we explicitly kill the process. + terminateProcess startPh -- Note(MK): The hacks around daml-prim which were already not quite right, e.g., -- we didn’t include daml-prim from all SDK versions, are broken completely -- now that we split daml-prim into multiple packages. Therefore, we