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>

compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/Archive.hs

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

compiler/damlc/daml-compiler/BUILD.bazel

@@ -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",
     ],
 )

compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Dar.hs

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

compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Fetch.hs

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

compiler/damlc/lib/DA/Cli/Damlc.hs

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

compiler/damlc/stable-packages/src/GenerateStablePackage.hs

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

compiler/damlc/tests/src/DA/Test/GenerateSimpleDalf.hs

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

daml-assistant/daml-helper/BUILD.bazel

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

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

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

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

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

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

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

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

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