mirror of
https://github.com/digital-asset/daml.git
synced 2024-09-20 01:07:18 +03:00
Add init-script field to daml.yaml (#4685)
* Add init-script daml.yaml field CHANGELOG_BEGIN [DAML Script -- Experimental] You can now define an ``init-script`` in the ``daml.yaml`` file. If present, that DAML script will be executed to initialize the sandbox on ``daml start``. This can be used instead of the ``scenario`` field. CHANGELOG_END * Add integration test for init-script * Generate JWT token in tests Addressing review comment https://github.com/digital-asset/daml/pull/4685#discussion_r383835050 * Remove unnecessary daml calls Co-authored-by: Andreas Herrmann <andreash87@gmx.ch>
This commit is contained in:
Andreas Herrmann
GitHub
parent
29ffe57c47
commit
2dbb5282ca
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -98,6 +98,7 @@ da_haskell_test(
|
||||
"main-tester",
|
||||
"network",
|
||||
"unix-compat",
|
||||
"unordered-containers",
|
||||
"process",
|
||||
"tar",
|
||||
"tar-conduit",
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user