Only extract main dalf from a dependency (digital-asset#4515)

This is a spin off from my fixes for making data-deps work with typeclasses cross-SDK. We only have the interface files for the main dalf so it doesn’t really make sense to extract the other dalfs. The current behavior of extracting all dalfs results in them being picked up by `GeneratePackageMap` even if GHC doesn’t know about them which causes issues in other placse. I’ve adapted the collision check to check for transitive dependencies when creating the project db. changelog_begin changelog_end
FlashSheridan · Feb 14, 2020 · 1fce415 · 1fce415
1 parent 514b859
commit 1fce415
Show file tree

Hide file tree

Showing 2 changed files with 28 additions and 8 deletions.
diff --git a/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/Archive.hs b/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/Archive.hs
@@ -5,6 +5,7 @@
 -- | Utilities for working with DAML-LF protobuf archives
 module DA.Daml.LF.Proto3.Archive
   ( decodeArchive
+  , decodeArchivePayload
   , encodeArchive
   , encodeArchiveLazy
   , encodeArchiveAndHash
@@ -51,6 +52,17 @@ data DecodingMode
 -- | Decode a LF archive header, returing the hash and the payload
 decodeArchive :: DecodingMode -> BS.ByteString -> Either ArchiveError (LF.PackageId, LF.Package)
 decodeArchive mode bytes = do
+    (packageId, payloadBytes) <- decodeArchivePayload bytes
+    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)
+
+decodeArchivePayload :: BS.ByteString -> Either ArchiveError (LF.PackageId, BS.ByteString)
+decodeArchivePayload bytes = do
     archive <- over _Left (ProtobufError . show) $ Proto.fromByteString bytes
     let payloadBytes = ProtoLF.archivePayload archive
     let archiveHash = TL.toStrict (ProtoLF.archiveHash archive)
@@ -64,13 +76,7 @@ decodeArchive mode bytes = do
     when (computedHash /= archiveHash) $
       Left (HashMismatch archiveHash computedHash)
     let packageId = LF.PackageId archiveHash
-    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)
+    pure (packageId, payloadBytes)
 
 
 -- | Encode a LFv1 package payload into a DAML-LF archive using the default

diff --git a/compiler/damlc/lib/DA/Cli/Damlc/Packaging.hs b/compiler/damlc/lib/DA/Cli/Damlc/Packaging.hs
@@ -97,7 +97,9 @@ createProjectPackageDb projectRoot opts thisSdkVer deps dataDeps = do
     -- See https://github.com/digital-asset/daml/issues/4218 for more details.
     -- TODO Enforce this with useful error messages
     forM_ depsExtracted $
-        \ExtractedDar{..} -> installDar dbPath edConfFiles edDalfs edSrcs
+        -- We only have the interface files for the main DALF in a `dependency` so we
+        -- also only extract the main dalf.
+        \ExtractedDar{..} -> installDar dbPath edConfFiles edMain edSrcs
 
     loggerH <- getLogger opts "generate package maps"
     mbRes <- withDamlIdeState opts loggerH diagnosticsLogger $ \ide -> runActionSync ide $ runMaybeT $
@@ -156,11 +158,23 @@ createProjectPackageDb projectRoot opts thisSdkVer deps dataDeps = do
               _ -> parsedUnitId
         pure (pkgId, package, dalf, unitId)
 
+    -- All transitive packages from DARs specified in  `dependencies`. This is only used for unit-id collision checks.
+    transitiveDependencies <- fmap concat $ forM depsExtracted $ \ExtractedDar{..} -> forM edDalfs $ \zipEntry -> do
+       let bytes = BSL.toStrict $ ZipArchive.fromEntry zipEntry
+       (pkgId, _) <- liftIO $
+            either (fail . DA.Pretty.renderPretty) pure $
+            Archive.decodeArchivePayload bytes
+       let unitId = parseUnitId (takeBaseName $ ZipArchive.eRelativePath zipEntry) pkgId
+       pure (pkgId, stringToUnitId unitId)
+
     let unitIdConflicts = MS.filter ((>=2) . Set.size) .  MS.fromListWith Set.union $ concat
             [ [ (unitId, Set.singleton pkgId)
               | (pkgId, _package, _dalf, unitId) <- pkgs ]
             , [ (unitId, Set.singleton (LF.dalfPackageId dalfPkg))
               | (unitId, dalfPkg) <- MS.toList dependencies ]
+            , [ (unitId, Set.singleton pkgId)
+              | (pkgId, unitId) <- transitiveDependencies
+              ]
             ]
     when (not $ MS.null unitIdConflicts) $ do
         fail $ "Transitive dependencies with same unit id but conflicting package ids: "