mirror of
https://github.com/digital-asset/daml.git
synced 2024-09-20 01:07:18 +03:00
New command: daml ledger fetch-dar (#5225)
* New comamnd: daml ledger fetch-dar `daml ledger fetch-dar [PID] [PATH]` Download a `Package` and it's dependencies from a ledger, given a root `packageId`, and re-construct a valid `.dar` file. Addresses issue #5037. The original package names are not reconstructed. CHANGELOG_BEGIN CHANGELOG_END * address some comments * fix spello * attempt: recoverPackageName * recover main package name & version * Try to fix integration tests on Windows Co-authored-by: Moritz Kiefer <moritz.kiefer@purelyfunctional.org>
This commit is contained in:
parent
e42111b31f
commit
aa53c30de1
@ -5,8 +5,8 @@
|
||||
-- | Utilities for working with DAML-LF protobuf archives
|
||||
module DA.Daml.LF.Proto3.Archive
|
||||
( decodeArchive
|
||||
, decodeArchivePayload
|
||||
, decodeArchivePackageId
|
||||
, decodePackage
|
||||
, encodeArchive
|
||||
, encodeArchiveLazy
|
||||
, encodeArchiveAndHash
|
||||
@ -49,21 +49,26 @@ data DecodingMode
|
||||
-- the id of the package being decoded.
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
-- | Decode a LF archive header, returing the hash and the payload
|
||||
-- | Decode an LF archive, returning the package-id and the package
|
||||
decodeArchive :: DecodingMode -> BS.ByteString -> Either ArchiveError (LF.PackageId, LF.Package)
|
||||
decodeArchive mode bytes = do
|
||||
(packageId, payloadBytes) <- decodeArchivePayload bytes
|
||||
(packageId, payloadBytes) <- decodeArchiveHeader bytes
|
||||
package <- decodePackage mode packageId payloadBytes
|
||||
return (packageId, package)
|
||||
|
||||
-- | Decode an LF archive payload, returning the package
|
||||
-- Used to decode a BS returned from the PackageService ledger API
|
||||
decodePackage :: DecodingMode -> LF.PackageId -> BS.ByteString -> Either ArchiveError LF.Package
|
||||
decodePackage mode packageId payloadBytes = do
|
||||
let selfPackageRef = case mode of
|
||||
DecodeAsMain -> LF.PRSelf
|
||||
DecodeAsDependency -> LF.PRImport packageId
|
||||
|
||||
payload <- over _Left (ProtobufError . show) $ Proto.fromByteString payloadBytes
|
||||
package <- over _Left (ProtobufError. show) $ Decode.decodePayload selfPackageRef payload
|
||||
return (packageId, package)
|
||||
over _Left (ProtobufError. show) $ Decode.decodePayload selfPackageRef payload
|
||||
|
||||
decodeArchivePayload :: BS.ByteString -> Either ArchiveError (LF.PackageId, BS.ByteString)
|
||||
decodeArchivePayload bytes = do
|
||||
-- | Decode an LF archive header, returning the package-id and the payload
|
||||
decodeArchiveHeader :: BS.ByteString -> Either ArchiveError (LF.PackageId, BS.ByteString)
|
||||
decodeArchiveHeader bytes = do
|
||||
archive <- over _Left (ProtobufError . show) $ Proto.fromByteString bytes
|
||||
let payloadBytes = ProtoLF.archivePayload archive
|
||||
let archiveHash = TL.toStrict (ProtoLF.archiveHash archive)
|
||||
@ -79,18 +84,19 @@ decodeArchivePayload bytes = do
|
||||
let packageId = LF.PackageId archiveHash
|
||||
pure (packageId, payloadBytes)
|
||||
|
||||
-- | Decode an LF archive, returning the package-id
|
||||
decodeArchivePackageId :: BS.ByteString -> Either ArchiveError LF.PackageId
|
||||
decodeArchivePackageId = fmap fst . decodeArchivePayload
|
||||
decodeArchivePackageId = fmap fst . decodeArchiveHeader
|
||||
|
||||
-- | Encode a LFv1 package payload into a DAML-LF archive using the default
|
||||
-- hash function.
|
||||
encodeArchiveLazy :: LF.Package -> BSL.ByteString
|
||||
encodeArchiveLazy = fst . encodeArchiveAndHash
|
||||
|
||||
encodePackageHash :: LF.Package -> T.Text
|
||||
encodePackageHash :: LF.Package -> LF.PackageId
|
||||
encodePackageHash = snd . encodeArchiveAndHash
|
||||
|
||||
encodeArchiveAndHash :: LF.Package -> (BSL.ByteString, T.Text)
|
||||
encodeArchiveAndHash :: LF.Package -> (BSL.ByteString, LF.PackageId)
|
||||
encodeArchiveAndHash package =
|
||||
let payload = BSL.toStrict $ Proto.toLazyByteString $ Encode.encodePayload package
|
||||
hash = encodeHash (BA.convert (Crypto.hash @_ @Crypto.SHA256 payload) :: BS.ByteString)
|
||||
@ -100,7 +106,7 @@ encodeArchiveAndHash package =
|
||||
, ProtoLF.archiveHash = TL.fromStrict hash
|
||||
, ProtoLF.archiveHashFunction = Proto.Enumerated (Right ProtoLF.HashFunctionSHA256)
|
||||
}
|
||||
in (Proto.toLazyByteString archive, hash)
|
||||
in (Proto.toLazyByteString archive, LF.PackageId hash)
|
||||
|
||||
encodeArchive :: LF.Package -> BS.ByteString
|
||||
encodeArchive = BSL.toStrict . encodeArchiveLazy
|
||||
|
@ -56,6 +56,7 @@ da_haskell_library(
|
||||
"//compiler/repl-service/client",
|
||||
"//compiler/scenario-service/client",
|
||||
"//daml-assistant:daml-project-config",
|
||||
"//language-support/hs/bindings:hs-ledger",
|
||||
"//libs-haskell/da-hs-base",
|
||||
],
|
||||
)
|
||||
|
@ -1,7 +1,9 @@
|
||||
-- Copyright (c) 2020 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
module DA.Daml.Compiler.Dar
|
||||
( buildDar
|
||||
( createDarFile
|
||||
, buildDar
|
||||
, createArchive
|
||||
, FromDalf(..)
|
||||
, breakAt72Bytes
|
||||
, PackageSdkVersion(..)
|
||||
@ -61,6 +63,13 @@ import MkIface
|
||||
import Module
|
||||
import HscTypes
|
||||
|
||||
-- | Create a DAR file by running a ZipArchive action.
|
||||
createDarFile :: FilePath -> Zip.ZipArchive () -> IO ()
|
||||
createDarFile fp dar = do
|
||||
createDirectoryIfMissing True $ takeDirectory fp
|
||||
Zip.createArchive fp dar
|
||||
putStrLn $ "Created " <> fp
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
{- | Builds a dar file.
|
||||
|
||||
@ -123,7 +132,7 @@ buildDar service pkgConf@PackageConfigFields {..} ifDir dalfInput = do
|
||||
bytes <- BSL.readFile pSrc
|
||||
-- in the dalfInput case we interpret pSrc as the filepath pointing to the dalf.
|
||||
-- Note that the package id is obviously wrong but this feature is not something we expose to users.
|
||||
pure $ Just $ createArchive pkgConf (LF.PackageId "") bytes [] (toNormalizedFilePath' ".") [] [] []
|
||||
pure $ Just $ createArchive pName pVersion pSdkVersion (LF.PackageId "") bytes [] (toNormalizedFilePath' ".") [] [] []
|
||||
-- We need runActionSync here to ensure that diagnostics are printed to the terminal.
|
||||
-- Otherwise runAction can return before the diagnostics have been printed and we might die
|
||||
-- without ever seeing diagnostics.
|
||||
@ -147,7 +156,7 @@ buildDar service pkgConf@PackageConfigFields {..} ifDir dalfInput = do
|
||||
error $
|
||||
"The following modules are declared in exposed-modules but are not part of the DALF: " <>
|
||||
show (S.toList missingExposed)
|
||||
let (dalf, LF.PackageId -> pkgId) = encodeArchiveAndHash pkg
|
||||
let (dalf,pkgId) = encodeArchiveAndHash pkg
|
||||
-- For now, we don’t include ifaces and hie files in incremental mode.
|
||||
-- The main reason for this is that writeIfacesAndHie is not yet ported to incremental mode
|
||||
-- but it also makes creation of the archive slightly faster and those files are only required
|
||||
@ -167,7 +176,7 @@ buildDar service pkgConf@PackageConfigFields {..} ifDir dalfInput = do
|
||||
srcRoot <- getSrcRoot pSrc
|
||||
pure $
|
||||
createArchive
|
||||
pkgConf
|
||||
pName pVersion pSdkVersion
|
||||
pkgId
|
||||
dalf
|
||||
dalfDependencies
|
||||
@ -318,8 +327,10 @@ sinkEntryDeterministic compression sink sel = do
|
||||
where fixedTime = UTCTime (fromGregorian 1980 1 1) 0
|
||||
|
||||
-- | Helper to bundle up all files into a DAR.
|
||||
createArchive ::
|
||||
PackageConfigFields
|
||||
createArchive
|
||||
:: LF.PackageName
|
||||
-> Maybe LF.PackageVersion
|
||||
-> PackageSdkVersion
|
||||
-> LF.PackageId
|
||||
-> BSL.ByteString -- ^ DALF
|
||||
-> [(T.Text, BS.ByteString, LF.PackageId)] -- ^ DALF dependencies
|
||||
@ -328,7 +339,7 @@ createArchive ::
|
||||
-> [(String, BS.ByteString)] -- ^ Data files
|
||||
-> [NormalizedFilePath] -- ^ Interface files
|
||||
-> Zip.ZipArchive ()
|
||||
createArchive PackageConfigFields {..} pkgId dalf dalfDependencies srcRoot fileDependencies dataFiles ifaces
|
||||
createArchive pName pVersion pSdkVersion pkgId dalf dalfDependencies srcRoot fileDependencies dataFiles ifaces
|
||||
= do
|
||||
-- Reads all module source files, and pairs paths (with changed prefix)
|
||||
-- with contents as BS. The path must be within the module root path, and
|
||||
|
112
compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Fetch.hs
Normal file
112
compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Fetch.hs
Normal file
@ -0,0 +1,112 @@
|
||||
-- Copyright (c) 2020 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
module DA.Daml.Compiler.Fetch (
|
||||
LedgerArgs(..), runWithLedgerArgs,
|
||||
createDarFile,
|
||||
fetchDar
|
||||
) where
|
||||
|
||||
import Control.Lens (toListOf)
|
||||
import Data.List.Extra (nubSort)
|
||||
import Data.String (fromString)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy as TL
|
||||
|
||||
import DA.Daml.Compiler.Dar (PackageSdkVersion(..),createDarFile,createArchive)
|
||||
import qualified DA.Daml.LF.Ast as LF
|
||||
import qualified DA.Daml.LF.Ast.Optics as LF (packageRefs)
|
||||
import qualified DA.Daml.LF.Proto3.Archive as LFArchive
|
||||
import qualified DA.Ledger as L
|
||||
import qualified SdkVersion
|
||||
|
||||
data LedgerArgs = LedgerArgs
|
||||
{ host :: String
|
||||
, port :: Int
|
||||
, tokM :: Maybe L.Token
|
||||
, sslConfigM :: Maybe L.ClientSSLConfig
|
||||
}
|
||||
|
||||
instance Show LedgerArgs where
|
||||
show LedgerArgs{host,port} = host <> ":" <> show port
|
||||
|
||||
-- | Reconstruct a DAR file by downloading packages from a ledger. Returns how many packages fetched.
|
||||
fetchDar :: LedgerArgs -> LF.PackageId -> FilePath -> IO Int
|
||||
fetchDar ledgerArgs rootPid saveAs = do
|
||||
xs <- downloadAllReachablePackages ledgerArgs rootPid
|
||||
[pkg] <- pure [ pkg | (pid,pkg) <- xs, pid == rootPid ]
|
||||
let (dalf,pkgId) = LFArchive.encodeArchiveAndHash pkg
|
||||
let dalfDependencies :: [(T.Text,BS.ByteString,LF.PackageId)] =
|
||||
[ (txt,bs,pkgId)
|
||||
| (pid,pkg) <- xs, pid /= rootPid
|
||||
, let txt = recoverPackageName pkg ("dep",pid)
|
||||
, let (bsl,pkgId) = LFArchive.encodeArchiveAndHash pkg
|
||||
, let bs = BSL.toStrict bsl
|
||||
]
|
||||
let (pName,pVersion) = do
|
||||
let LF.Package {packageMetadata} = pkg
|
||||
case packageMetadata of
|
||||
Nothing -> (LF.PackageName $ T.pack "reconstructed",Nothing)
|
||||
Just LF.PackageMetadata{packageName,packageVersion} -> (packageName,Just packageVersion)
|
||||
let pSdkVersion = PackageSdkVersion SdkVersion.sdkVersion
|
||||
let srcRoot = error "unexpected use of srcRoot when there are no sources"
|
||||
let za = createArchive pName pVersion pSdkVersion pkgId dalf dalfDependencies srcRoot [] [] []
|
||||
createDarFile saveAs za
|
||||
return $ length xs
|
||||
|
||||
recoverPackageName :: LF.Package -> (String,LF.PackageId) -> T.Text
|
||||
recoverPackageName pkg (tag,pid)= do
|
||||
let LF.Package {packageMetadata} = pkg
|
||||
case packageMetadata of
|
||||
Just LF.PackageMetadata{packageName} -> LF.unPackageName packageName
|
||||
-- fallback, manufacture a name from the pid
|
||||
Nothing -> T.pack (tag <> "-" <> T.unpack (LF.unPackageId pid))
|
||||
|
||||
|
||||
-- | Download all Packages reachable from a PackageId; fail if any don't exist or can't be decoded.
|
||||
downloadAllReachablePackages :: LedgerArgs -> LF.PackageId -> IO [(LF.PackageId,LF.Package)]
|
||||
downloadAllReachablePackages ledgerArgs pid = loop [] [pid]
|
||||
where
|
||||
loop :: [(LF.PackageId,LF.Package)] -> [LF.PackageId] -> IO [(LF.PackageId,LF.Package)]
|
||||
loop acc = \case
|
||||
[] -> return acc
|
||||
pid:morePids ->
|
||||
if pid `elem` [ pid | (pid,_) <- acc ]
|
||||
then loop acc morePids
|
||||
else do
|
||||
pkg <- downloadPackage ledgerArgs pid
|
||||
loop ((pid,pkg):acc) (packageRefs pkg ++ morePids)
|
||||
|
||||
packageRefs :: LF.Package -> [LF.PackageId]
|
||||
packageRefs pkg = nubSort [ pid | LF.PRImport pid <- toListOf LF.packageRefs pkg ]
|
||||
|
||||
-- | Download the Package identified by a PackageId; fail if it doesn't exist or can't be decoded.
|
||||
downloadPackage :: LedgerArgs -> LF.PackageId -> IO LF.Package
|
||||
downloadPackage ledgerArgs pid = do
|
||||
let ls :: L.LedgerService (Maybe L.Package) = do
|
||||
lid <- L.getLedgerIdentity
|
||||
L.getPackage lid $ convPid pid
|
||||
runWithLedgerArgs ledgerArgs ls >>= \case
|
||||
Nothing -> fail $ "Unable to download package with identity: " <> show pid
|
||||
Just (L.Package bs) -> do
|
||||
let mode = LFArchive.DecodeAsMain
|
||||
case LFArchive.decodePackage mode pid bs of
|
||||
Left err -> fail $ show err
|
||||
Right pkg -> return pkg
|
||||
where
|
||||
convPid :: LF.PackageId -> L.PackageId
|
||||
convPid (LF.PackageId text) = L.PackageId $ TL.fromStrict text
|
||||
|
||||
runWithLedgerArgs :: LedgerArgs -> L.LedgerService a -> IO a
|
||||
runWithLedgerArgs args ls = do
|
||||
let LedgerArgs{host,port,tokM} = args
|
||||
let ls' = case tokM of Nothing -> ls; Just tok -> L.setToken tok ls
|
||||
let timeout = 30 :: L.TimeoutSeconds
|
||||
let ledgerClientConfig =
|
||||
L.configOfHostAndPort
|
||||
(L.Host $ fromString host)
|
||||
(L.Port port)
|
||||
(sslConfigM args)
|
||||
L.runLedgerService ls' timeout ledgerClientConfig
|
@ -10,7 +10,6 @@
|
||||
module DA.Cli.Damlc (main) where
|
||||
|
||||
import qualified "zip-archive" Codec.Archive.Zip as ZipArchive
|
||||
import qualified "zip" Codec.Archive.Zip as Zip
|
||||
import Control.Exception
|
||||
import Control.Exception.Safe (catchIO)
|
||||
import Control.Monad.Except
|
||||
@ -574,12 +573,6 @@ initPackageDb opts (InitPkgDb shouldInit) =
|
||||
withPackageConfig defaultProjectPath $ \PackageConfigFields {..} ->
|
||||
createProjectPackageDb (toNormalizedFilePath' projRoot) opts pSdkVersion pDependencies pDataDependencies
|
||||
|
||||
createDarFile :: FilePath -> Zip.ZipArchive () -> IO ()
|
||||
createDarFile fp dar = do
|
||||
createDirectoryIfMissing True $ takeDirectory fp
|
||||
Zip.createArchive fp dar
|
||||
putStrLn $ "Created " <> fp
|
||||
|
||||
execBuild :: ProjectOpts -> Options -> Maybe FilePath -> IncrementalBuild -> InitPkgDb -> Command
|
||||
execBuild projectOpts opts mbOutFile incrementalBuild initPkgDb =
|
||||
Command Build (Just projectOpts) effect
|
||||
|
@ -75,7 +75,7 @@ main = do
|
||||
ModuleName ["DA", "Logic", "Types"] ->
|
||||
writePackage daLogicTypes optOutputPath
|
||||
ModuleName ["DA", "Validation", "Types"] ->
|
||||
writePackage (daValidationTypes (PackageId $ encodePackageHash daNonEmptyTypes)) optOutputPath
|
||||
writePackage (daValidationTypes (encodePackageHash daNonEmptyTypes)) optOutputPath
|
||||
ModuleName ["DA", "Internal", "Down"] ->
|
||||
writePackage daInternalDown optOutputPath
|
||||
ModuleName ["DA", "Internal", "Erased"] ->
|
||||
|
@ -120,7 +120,7 @@ main = do
|
||||
, packageModules = NM.fromList [mod]
|
||||
, packageMetadata = Nothing
|
||||
}
|
||||
let (bytes, hash) = encodeArchiveAndHash pkg
|
||||
let (bytes, PackageId hash) = encodeArchiveAndHash pkg
|
||||
BSL.writeFile file bytes
|
||||
T.putStrLn hash
|
||||
pure ()
|
||||
|
@ -39,6 +39,8 @@ da_haskell_library(
|
||||
],
|
||||
visibility = ["//visibility:public"],
|
||||
deps = [
|
||||
"//compiler/daml-lf-ast",
|
||||
"//compiler/damlc/daml-compiler",
|
||||
"//daml-assistant:daml-project-config",
|
||||
"//language-support/hs/bindings:hs-ledger",
|
||||
"//libs-haskell/da-hs-base",
|
||||
|
@ -11,20 +11,14 @@ module DA.Daml.Helper.Ledger (
|
||||
|
||||
import DA.Ledger(LedgerService,PartyDetails(..),Party(..),Token)
|
||||
import Data.List.Extra as List
|
||||
import Data.String(fromString)
|
||||
import qualified DA.Ledger as L
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.Text.Lazy as Text(pack)
|
||||
|
||||
data LedgerArgs = LedgerArgs
|
||||
{ host :: String
|
||||
, port :: Int
|
||||
, tokM :: Maybe Token
|
||||
, sslConfigM :: Maybe L.ClientSSLConfig
|
||||
}
|
||||
import DA.Daml.Compiler.Fetch (LedgerArgs(..),runWithLedgerArgs)
|
||||
|
||||
instance Show LedgerArgs where
|
||||
show LedgerArgs{host,port} = host <> ":" <> show port
|
||||
run :: LedgerArgs -> LedgerService a -> IO a
|
||||
run = runWithLedgerArgs
|
||||
|
||||
listParties :: LedgerArgs -> IO [PartyDetails]
|
||||
listParties hp = run hp L.listKnownParties
|
||||
@ -48,15 +42,3 @@ allocateParty hp name = run hp $ do
|
||||
uploadDarFile :: LedgerArgs -> BS.ByteString -> IO ()
|
||||
uploadDarFile hp bytes = run hp $ do
|
||||
L.uploadDarFile bytes >>= either fail return
|
||||
|
||||
run :: LedgerArgs -> LedgerService a -> IO a
|
||||
run hp ls = do
|
||||
let LedgerArgs{host,port,tokM} = hp
|
||||
let ls' = case tokM of Nothing -> ls; Just tok -> L.setToken tok ls
|
||||
let timeout = 30 :: L.TimeoutSeconds
|
||||
let ledgerClientConfig =
|
||||
L.configOfHostAndPort
|
||||
(L.Host $ fromString host)
|
||||
(L.Port port)
|
||||
(sslConfigM hp)
|
||||
L.runLedgerService ls' timeout ledgerClientConfig
|
||||
|
@ -59,6 +59,7 @@ data Command
|
||||
| LedgerListParties { flags :: LedgerFlags, json :: JsonFlag }
|
||||
| LedgerAllocateParties { flags :: LedgerFlags, parties :: [String] }
|
||||
| LedgerUploadDar { flags :: LedgerFlags, darPathM :: Maybe FilePath }
|
||||
| LedgerFetchDar { flags :: LedgerFlags, pid :: String, saveAs :: FilePath }
|
||||
| LedgerNavigator { flags :: LedgerFlags, remainingArguments :: [String] }
|
||||
| Codegen { lang :: Lang, remainingArguments :: [String] }
|
||||
|
||||
@ -217,6 +218,9 @@ commandParser = subparser $ fold
|
||||
, command "upload-dar" $ info
|
||||
(ledgerUploadDarCmd <**> helper)
|
||||
(progDesc "Upload DAR file to ledger")
|
||||
, command "fetch-dar" $ info
|
||||
(ledgerFetchDarCmd <**> helper)
|
||||
(progDesc "Fetch DAR from ledger into file")
|
||||
, command "navigator" $ info
|
||||
(ledgerNavigatorCmd <**> helper)
|
||||
(forwardOptions <> progDesc "Launch Navigator on ledger")
|
||||
@ -245,6 +249,11 @@ commandParser = subparser $ fold
|
||||
<$> ledgerFlags
|
||||
<*> optional (argument str (metavar "PATH" <> help "DAR file to upload (defaults to project DAR)"))
|
||||
|
||||
ledgerFetchDarCmd = LedgerFetchDar
|
||||
<$> ledgerFlags
|
||||
<*> option str (long "main-package-id" <> metavar "PKGID" <> help "Fetch DAR for this package identifier.")
|
||||
<*> option str (short 'o' <> long "output" <> metavar "PATH" <> help "Save fetched DAR into this file.")
|
||||
|
||||
ledgerNavigatorCmd = LedgerNavigator
|
||||
<$> ledgerFlags
|
||||
<*> many (argument str (metavar "ARG" <> help "Extra arguments to navigator."))
|
||||
@ -331,6 +340,7 @@ runCommand = \case
|
||||
LedgerListParties {..} -> runLedgerListParties flags json
|
||||
LedgerAllocateParties {..} -> runLedgerAllocateParties flags parties
|
||||
LedgerUploadDar {..} -> runLedgerUploadDar flags darPathM
|
||||
LedgerFetchDar {..} -> runLedgerFetchDar flags pid saveAs
|
||||
LedgerNavigator {..} -> runLedgerNavigator flags remainingArguments
|
||||
Codegen {..} ->
|
||||
case lang of
|
||||
|
@ -19,6 +19,7 @@ module DA.Daml.Helper.Run
|
||||
, runLedgerAllocateParties
|
||||
, runLedgerListParties
|
||||
, runLedgerUploadDar
|
||||
, runLedgerFetchDar
|
||||
, runLedgerNavigator
|
||||
|
||||
, withJar
|
||||
@ -97,6 +98,9 @@ import DA.Daml.Project.Consts
|
||||
import DA.Daml.Project.Types
|
||||
import DA.Daml.Project.Util
|
||||
|
||||
import DA.Daml.Compiler.Fetch (fetchDar)
|
||||
import qualified DA.Daml.LF.Ast as LF
|
||||
|
||||
data DamlHelperError = DamlHelperError
|
||||
{ errMessage :: T.Text
|
||||
, errInternal :: Maybe T.Text
|
||||
@ -990,6 +994,15 @@ runLedgerUploadDar flags darPathM = do
|
||||
Ledger.uploadDarFile hp bytes
|
||||
putStrLn "DAR upload succeeded."
|
||||
|
||||
-- | Fetch the packages reachable from a main package-id, and reconstruct a DAR file.
|
||||
runLedgerFetchDar :: LedgerFlags -> String -> FilePath -> IO ()
|
||||
runLedgerFetchDar flags pidString saveAs = do
|
||||
let pid = LF.PackageId $ T.pack pidString
|
||||
hp <- getHostAndPortDefaults flags
|
||||
putStrLn $ "Fetching " <> show (LF.unPackageId pid) <> " from " <> show hp <> " into " <> saveAs
|
||||
n <- fetchDar hp pid saveAs
|
||||
putStrLn $ "DAR fetch succeeded; contains " <> show n <> " packages."
|
||||
|
||||
-- | Run navigator against configured ledger. We supply Navigator with
|
||||
-- the list of parties from the ledger, but in the future Navigator
|
||||
-- should fetch the list of parties itself.
|
||||
|
@ -72,6 +72,7 @@ tests tmpDir damlTypesDir = withSdkResource $ \_ -> testGroup "Integration tests
|
||||
, quickstartTests quickstartDir mvnDir
|
||||
, cleanTests cleanDir
|
||||
, deployTest deployDir
|
||||
, fetchTest tmpDir
|
||||
, codegenTests codegenDir damlTypesDir
|
||||
]
|
||||
where quickstartDir = tmpDir </> "q-u-i-c-k-s-t-a-r-t"
|
||||
@ -502,6 +503,62 @@ codegenTests codegenDir damlTypes = testGroup "daml codegen" (
|
||||
contents <- listDirectory outDir
|
||||
assertBool "bindings were written" (not $ null contents)
|
||||
|
||||
-- | Start a sandbox on any free port
|
||||
withSandboxOnFreePort :: (Int -> IO ()) -> IO ()
|
||||
withSandboxOnFreePort f = do
|
||||
port :: Int <- fromIntegral <$> getFreePort
|
||||
withDevNull $ \devNull -> do
|
||||
let sandboxProc =
|
||||
(shell $ unwords
|
||||
["daml"
|
||||
, "sandbox"
|
||||
, "--wall-clock-time"
|
||||
, "--port", show port
|
||||
]) { std_out = UseHandle devNull, std_in = CreatePipe }
|
||||
withCreateProcess sandboxProc $ \_ _ _ ph -> do
|
||||
race_ (waitForProcess' sandboxProc ph) $ do
|
||||
waitForConnectionOnPort (threadDelay 100000) port
|
||||
f port
|
||||
-- waitForProcess' will block on Windows so we explicitly kill the process.
|
||||
terminateProcess ph
|
||||
|
||||
-- | Using `daml inspect-dar`, discover the main package-identifier of a dar.
|
||||
getMainPidByInspecingDar :: FilePath -> String -> IO String
|
||||
getMainPidByInspecingDar dar projName = do
|
||||
stdout <- callCommandForStdout $ unwords ["daml damlc inspect-dar", dar ]
|
||||
[grepped] <- pure $
|
||||
[ line
|
||||
| line <- lines stdout
|
||||
-- expect a single line containing double quotes and the projName
|
||||
, "\"" `isInfixOf` line
|
||||
, projName `isInfixOf` line
|
||||
]
|
||||
-- and the main pid is found between the 1st and 2nd double-quotes
|
||||
[_,pid,_] <- pure $ splitOn "\"" grepped
|
||||
return pid
|
||||
|
||||
-- | Tests for the `daml ledger fetch-dar` command
|
||||
fetchTest :: FilePath -> TestTree
|
||||
fetchTest tmpDir = testCaseSteps "daml ledger fetch-dar" $ \step -> do
|
||||
let fetchDir = tmpDir </> "fetchTest"
|
||||
withSandboxOnFreePort $ \port -> do
|
||||
createDirectoryIfMissing True fetchDir
|
||||
withCurrentDirectory fetchDir $ do
|
||||
callCommandQuiet $ unwords ["daml new", "proj1"]
|
||||
withCurrentDirectory "proj1" $ do
|
||||
let origDar = ".daml/dist/proj1-0.0.1.dar"
|
||||
step "build/upload"
|
||||
callCommandQuiet $ unwords ["daml ledger upload-dar --port", show port]
|
||||
pid <- getMainPidByInspecingDar origDar "proj1"
|
||||
step "fetch/validate"
|
||||
let fetchedDar = "fetched.dar"
|
||||
callCommandQuiet $ unwords [ "daml ledger fetch-dar"
|
||||
, "--port", show port
|
||||
, "--main-package-id", pid
|
||||
, "-o", fetchedDar
|
||||
]
|
||||
callCommandQuiet $ unwords ["daml damlc validate-dar", fetchedDar]
|
||||
|
||||
deployTest :: FilePath -> TestTree
|
||||
deployTest deployDir = testCase "daml deploy" $ do
|
||||
createDirectoryIfMissing True deployDir
|
||||
@ -552,16 +609,27 @@ damlInstallerName
|
||||
| isWindows = "daml.exe"
|
||||
| otherwise = "daml"
|
||||
|
||||
-- | Like call process but hides stdout.
|
||||
runCreateProcessQuiet :: CreateProcess -> IO ()
|
||||
runCreateProcessQuiet createProcess = do
|
||||
-- | Like call process but returning stdout.
|
||||
runCreateProcessForStdout :: CreateProcess -> IO String
|
||||
runCreateProcessForStdout createProcess = do
|
||||
-- We use `repeat ' '` to keep stdin open. Really we would just
|
||||
-- like to inherit stdin but readCreateProcessWithExitCode does
|
||||
-- not allow us to overwrite just that and I don’t want to
|
||||
-- reimplement everything.
|
||||
(exit, _out, err) <- readCreateProcessWithExitCode createProcess (repeat ' ')
|
||||
(exit, out, err) <- readCreateProcessWithExitCode createProcess (repeat ' ')
|
||||
hPutStr stderr err
|
||||
unless (exit == ExitSuccess) $ throwIO $ ProcessExitFailure exit createProcess
|
||||
return out
|
||||
|
||||
callCommandForStdout :: String -> IO String
|
||||
callCommandForStdout cmd =
|
||||
runCreateProcessForStdout (shell cmd)
|
||||
|
||||
-- | Like call process but hiding stdout.
|
||||
runCreateProcessQuiet :: CreateProcess -> IO ()
|
||||
runCreateProcessQuiet createProcess = do
|
||||
_ <- runCreateProcessForStdout createProcess
|
||||
return ()
|
||||
|
||||
-- | Like callProcess but hides stdout.
|
||||
callProcessQuiet :: FilePath -> [String] -> IO ()
|
||||
|
Loading…
Reference in New Issue
Block a user