Implement multi-package composite dars

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

@@ -4,6 +4,7 @@
 module DA.Daml.LF.Proto3.Archive.Decode
   ( decodeArchive
   , decodeArchivePackageId
+  , decodeArchiveLfVersion
   , decodePackage
   , ArchiveError(..)
   , DecodingMode(..)
@@ -47,6 +48,11 @@ decodeArchive mode bytes = do
     package <- decodePackage mode packageId payloadBytes
     return (packageId, package)
 
+decodeArchiveLfVersion :: BS.ByteString -> Either ArchiveError LF.Version
+decodeArchiveLfVersion bytes = do
+  (packageId, payloadBytes) <- decodeArchiveHeader bytes
+  decodePackageLfVersion packageId payloadBytes
+
 -- | 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
@@ -55,7 +61,12 @@ decodePackage mode packageId payloadBytes = do
             DecodeAsMain -> LF.PRSelf
             DecodeAsDependency -> LF.PRImport packageId
     payload <- over _Left (ProtobufError . show) $ Proto.fromByteString payloadBytes
-    over _Left (ProtobufError. show) $ Decode.decodePayload packageId selfPackageRef payload
+    over _Left (ProtobufError . show) $ Decode.decodePayload packageId selfPackageRef payload
+
+decodePackageLfVersion :: LF.PackageId -> BS.ByteString -> Either ArchiveError LF.Version
+decodePackageLfVersion packageId payloadBytes = do
+  payload <- over _Left (ProtobufError . show) $ Proto.fromByteString payloadBytes
+  over _Left (ProtobufError . show) $ Decode.extractLFVersion packageId payload
 
 -- | Decode an LF archive header, returning the package-id and the payload
 decodeArchiveHeader :: BS.ByteString -> Either ArchiveError (LF.PackageId, BS.ByteString)

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

@@ -6,6 +6,7 @@
 module DA.Daml.LF.Proto3.Decode
   ( Error(..)
   , decodePayload
+  , extractLFVersion
   ) where
 
 import Com.Daml.DamlLfDev.DamlLf (ArchivePayload(..), ArchivePayloadSum(..))
@@ -47,3 +48,11 @@ decodePayload pkgId selfPackageRef payload = case archivePayloadSum payload of
     Nothing -> Left $ ParseError "Empty payload"
   where
     minorText = TL.toStrict (archivePayloadMinor payload)
+
+extractLFVersion :: PackageId -> ArchivePayload -> Either Error LF.Version
+extractLFVersion pkgId payload = case archivePayloadSum payload of
+    Just (ArchivePayloadSumDamlLf1 _) -> decodeLfVersion LF.V1 pkgId minorText
+    Just (ArchivePayloadSumDamlLf2 _) -> decodeLfVersion LF.V2 pkgId minorText
+    Nothing -> Left $ ParseError "Empty payload"
+  where
+    minorText = TL.toStrict (archivePayloadMinor payload)

compiler/daml-lf-reader/src/DA/Daml/LF/Reader.hs

@@ -9,17 +9,23 @@ module DA.Daml.LF.Reader
     , Dalfs(..)
     , readDalfManifest
     , readDalfs
+    , readDalfsWithMeta
+    , dalfsToList
     ) where
 
 import "zip-archive" Codec.Archive.Zip
+import qualified DA.Daml.LF.Ast as LF
+import Data.Bitraversable (bimapM)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BSL
 import qualified Data.ByteString.UTF8 as BSUTF8
 import Data.Char
 import Data.Either.Extra
 import Data.List.Extra
+import qualified Data.Text as T
 import Data.Void
+import System.FilePath (takeBaseName)
 import Text.Megaparsec
 import Text.Megaparsec.Byte
 
@@ -90,11 +96,14 @@ data DalfManifest = DalfManifest
     } deriving (Show)
 
 -- | The dalfs stored in the DAR.
-data Dalfs = Dalfs
-    { mainDalf :: BSL.ByteString
-    , dalfs :: [BSL.ByteString]
+data Dalfs a = Dalfs
+    { mainDalf :: a
+    , dalfs :: [a]
     -- ^ Excludes the mainDalf.
-    } deriving (Show)
+    } deriving (Eq, Ord, Show, Functor)
+
+dalfsToList :: Dalfs a -> [a]
+dalfsToList d = mainDalf d : dalfs d
 
 readDalfManifest :: Archive -> Either String DalfManifest
 readDalfManifest dar = do
@@ -111,13 +120,27 @@ readDalfManifest dar = do
         lookup attrName attrs
     missingAttr attrName = Left $ "No " <> BSUTF8.toString attrName <> " attribute in manifest."
 
-readDalfs :: Archive -> Either String Dalfs
+readDalfs :: Archive -> Either String (Dalfs BSL.ByteString)
 readDalfs dar = do
     DalfManifest{..} <- readDalfManifest dar
     mainDalf <- getEntry dar mainDalfPath
     dalfs <- mapM (getEntry dar) (delete mainDalfPath dalfPaths)
     pure $ Dalfs mainDalf dalfs
 
+extractNameAndPackageIdFromPath :: FilePath -> Maybe (T.Text, LF.PackageId)
+extractNameAndPackageIdFromPath = bimapM (T.stripSuffix "-") (pure . LF.PackageId) . T.breakOnEnd "-" . T.pack . takeBaseName
+
+readDalfsWithMeta :: Archive -> Either String (Dalfs (T.Text, BSL.ByteString, LF.PackageId))
+readDalfsWithMeta dar = do
+    DalfManifest{..} <- readDalfManifest dar
+    let getEntryWithMeta dar path = do
+          dalf <- getEntry dar path
+          (name, pkgId) <- maybe (Left "Couldn't parse dalf filename, didn't contain dash.") Right $ extractNameAndPackageIdFromPath path
+          pure (name, dalf, pkgId)
+    mainDalf <- getEntryWithMeta dar mainDalfPath
+    dalfs <- mapM (getEntryWithMeta dar) (delete mainDalfPath dalfPaths)
+    pure $ Dalfs mainDalf dalfs
+
 getEntry :: Archive -> FilePath -> Either String BSL.ByteString
 getEntry dar path = case findEntryByPath path dar of
     Nothing -> Left $ "Could not find " <> path <> " in DAR"

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

@@ -3,6 +3,7 @@
 module DA.Daml.Compiler.Dar
     ( createDarFile
     , buildDar
+    , buildCompositeDar
     , createArchive
     , FromDalf(..)
     , breakAt72Bytes
@@ -25,8 +26,9 @@ import Control.Monad.Trans.Class
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Resource (ResourceT)
 import qualified DA.Daml.LF.Ast as LF
-import DA.Daml.LF.Proto3.Archive (encodeArchiveAndHash)
+import DA.Daml.LF.Proto3.Archive (decodeArchiveLfVersion, encodeArchiveAndHash)
 import qualified DA.Daml.LF.Proto3.Archive as Archive
+import DA.Daml.LF.Reader (Dalfs (..), dalfsToList, readDalfsWithMeta)
 import DA.Daml.Compiler.ExtractDar (extractDar,ExtractedDar(..))
 import DA.Daml.LF.TypeChecker.Error (Error(EUnsupportedFeature))
 import DA.Daml.LF.TypeChecker.Upgrade as TypeChecker.Upgrade
@@ -48,6 +50,7 @@ import qualified Data.NameMap as NM
 import qualified Data.Set as S
 import qualified Data.Text as T
 import Data.Time
+import Data.Tuple.Extra (second3, snd3, thd3)
 import Development.IDE.Core.API
 import Development.IDE.Core.Service (getIdeOptions)
 import Development.IDE.Core.RuleTypes.Daml
@@ -71,7 +74,7 @@ import DA.Daml.Project.Types (UnresolvedReleaseVersion(..))
 
 import qualified "zip-archive" Codec.Archive.Zip as ZipArchive
 
-import SdkVersion.Class (SdkVersioned)
+import SdkVersion.Class (SdkVersioned, unresolvedBuiltinSdkVersion)
 
 -- | Create a DAR file by running a ZipArchive action.
 createDarFile :: Logger.Handle IO -> FilePath -> Zip.ZipArchive () -> IO ()
@@ -206,6 +209,34 @@ buildDar service PackageConfigFields {..} ifDir dalfInput = do
                    , Just pkgId
                    )
 
+-- | Takes a list of paths to dars, composite package name and composite package version
+-- Merges together all the dars without usage checks, generates a main package with 0 modules
+-- Generated package uses latest LF version with matching Major version to the dars given, and the current builtin sdk version.
+buildCompositeDar :: SdkVersioned => [FilePath] -> LF.PackageName -> LF.PackageVersion -> IO (Zip.ZipArchive ())
+buildCompositeDar darPaths name version = do
+  dars <-
+    forM darPaths $ \darPath -> do
+      bs <- BSL.readFile darPath
+      pure $ ZipArchive.toArchive bs
+
+  let darDalfs = fmap (fmap (second3 BSL.toStrict) . either error id . readDalfsWithMeta) dars
+  darLfVersions <- forM darDalfs $ either (fail . DA.Pretty.renderPretty) pure . decodeArchiveLfVersion . snd3 . mainDalf
+
+  let lfVersion =
+        case nubOrd $ LF.versionMajor <$> darLfVersions of
+          -- Note that this will not select dev. We may want to detect if any of the packages are `X.dev` and use this if so (and warn)
+          [mv] -> LF.defaultOrLatestStable mv
+          xs -> error $ "Dars contained multiple different Major LF versions: " <> show (sort xs)        
+      pkgMeta = LF.PackageMetadata name version Nothing
+      pkg = LF.Package { LF.packageLfVersion = lfVersion, LF.packageModules = NM.empty, LF.packageMetadata = Just pkgMeta }
+      (dalf, pkgId) = encodeArchiveAndHash pkg
+      conf = mkConfFile name (Just version) [] Nothing [] pkgId
+      -- Dalfs included unique by packageId
+      dalfs = nubOrdOn thd3 $ concatMap dalfsToList darDalfs
+      dar = createArchive name (Just version) unresolvedBuiltinSdkVersion pkgId dalf dalfs "." [] [conf] []
+
+  pure dar
+
 validateExposedModules :: Maybe [ModuleName] -> [ModuleName] -> MaybeT Action ()
 validateExposedModules mbExposedModules pkgModuleNames = do
     let missingExposed =

compiler/damlc/daml-package-config/src/DA/Daml/Package/Config.hs

@@ -7,6 +7,7 @@
 module DA.Daml.Package.Config
     ( MultiPackageConfigFields (..)
     , PackageConfigFields (..)
+    , CompositeDar (..)
     , parseProjectConfig
     , overrideSdkVersion
     , withPackageConfig
@@ -21,7 +22,7 @@ import DA.Daml.Project.Consts
 import DA.Daml.Project.Types
 
 import Control.Exception.Safe (throwIO, displayException)
-import Control.Monad (when)
+import Control.Monad (forM_, when)
 import Control.Monad.Extra (loopM)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.State.Lazy
@@ -100,21 +101,57 @@ checkPkgConfig PackageConfigFields {pName, pVersion} =
     versionRegex = "^(0|[1-9][0-9]*)(\\.(0|[1-9][0-9]*))*$" :: T.Text
     packageNameRegex = "^[A-Za-z][A-Za-z0-9]*(\\-[A-Za-z][A-Za-z0-9]*)*$" :: T.Text
 
+data CompositeDar = CompositeDar
+    { cdName :: LF.PackageName
+    , cdVersion :: LF.PackageVersion
+    , cdPackages :: [FilePath]
+    , cdDars :: [FilePath]
+    , cdPath :: FilePath
+    }
+    deriving Show
+
 data MultiPackageConfigFields = MultiPackageConfigFields
     { mpPackagePaths :: [FilePath]
+    , mpCompositeDars :: [CompositeDar]
+    , mpTransitiveCompositeDarNames :: [(FilePath, [LF.PackageName])]
+    , mpPath :: FilePath
     }
+    deriving Show
 
 -- | Intermediate of MultiPackageConfigFields that carries links to other config files, before being flattened into a single MultiPackageConfigFields
 data MultiPackageConfigFieldsIntermediate = MultiPackageConfigFieldsIntermediate
     { mpiConfigFields :: MultiPackageConfigFields
     , mpiOtherConfigFiles :: [FilePath]
     }
 
+parseCompositeDar :: MultiPackageCompositeDar -> Either ConfigError CompositeDar
+parseCompositeDar compositeDar = do
+    cdName <- queryMultiPackageCompositeDarRequired ["name"] compositeDar
+    cdVersion <- queryMultiPackageCompositeDarRequired ["version"] compositeDar
+    cdPackages <- fromMaybe [] <$> queryMultiPackageCompositeDar ["packages"] compositeDar
+    cdDars <- fromMaybe [] <$> queryMultiPackageCompositeDar ["dars"] compositeDar
+    cdPath <- queryMultiPackageCompositeDarRequired ["path"] compositeDar
+    if null $ cdPackages <> cdDars
+      then Left $ ConfigFileInvalid "multi-package" $ Y.InvalidYaml $ Just
+            $ Y.YamlException $ "Missing either `packages` or `dars` in composite dar \"" <> (T.unpack $ LF.unPackageName cdName) <> "\""
+      else Right CompositeDar {..}
+
 -- | Parse the multi-package.yaml file for auto rebuilds/IDE intelligence in multi-package projects
-parseMultiPackageConfig :: MultiPackageConfig -> Either ConfigError MultiPackageConfigFieldsIntermediate
-parseMultiPackageConfig multiPackage = do
-    mpiConfigFields <- MultiPackageConfigFields . fromMaybe [] <$> queryMultiPackageConfig ["packages"] multiPackage
+parseMultiPackageConfig :: MultiPackageConfig -> FilePath -> Either ConfigError MultiPackageConfigFieldsIntermediate
+parseMultiPackageConfig multiPackage mpPath = do
+    mpPackagePaths <- fromMaybe [] <$> queryMultiPackageConfig ["packages"] multiPackage
     mpiOtherConfigFiles <- fromMaybe [] <$> queryMultiPackageConfig ["projects"] multiPackage
+    compositeDarObjects <- fromMaybe [] <$> queryMultiPackageConfig ["composite-dars"] multiPackage
+    mpCompositeDars <- traverse parseCompositeDar compositeDarObjects
+    -- n^2 but this list is usually so small that its not worth complicating the logic
+    forM_ mpCompositeDars $ \cd ->
+      let matching = length $ filter (\otherCd -> (cdName cd, cdVersion cd) == (cdName otherCd, cdVersion otherCd)) mpCompositeDars
+       in when (matching > 1) $ Left $ ConfigFileInvalid "multi-package" $ Y.InvalidYaml $ Just
+            $ Y.YamlException $ "Multiple composite dars with the same name and version: " <>
+              T.unpack (LF.unPackageName (cdName cd) <> "-" <> LF.unPackageVersion (cdVersion cd))
+
+    let mpTransitiveCompositeDarNames = []
+        mpiConfigFields = MultiPackageConfigFields {..}
     Right MultiPackageConfigFieldsIntermediate {..}
 
 overrideSdkVersion :: PackageConfigFields -> IO PackageConfigFields
@@ -175,11 +212,25 @@ findMultiPackageConfig projectPath = do
         let newPath = takeDirectory path
         in pure $ if path == newPath then Right Nothing else Left newPath
 
+canonicalizeCompositeDar :: CompositeDar -> IO CompositeDar
+canonicalizeCompositeDar cd = do
+  canonPackages <- traverse canonicalizePath $ cdPackages cd
+  canonDars <- traverse canonicalizePath $ cdDars cd
+  canonPath <- canonicalizePath $ cdPath cd
+
+  pure cd { cdPackages = canonPackages, cdDars = canonDars, cdPath = canonPath }
+
 canonicalizeMultiPackageConfigIntermediate :: ProjectPath -> MultiPackageConfigFieldsIntermediate -> IO MultiPackageConfigFieldsIntermediate
-canonicalizeMultiPackageConfigIntermediate projectPath (MultiPackageConfigFieldsIntermediate (MultiPackageConfigFields packagePaths) multiPackagePaths) =
+canonicalizeMultiPackageConfigIntermediate projectPath (MultiPackageConfigFieldsIntermediate mpc multiPackagePaths) =
   withCurrentDirectory (unwrapProjectPath projectPath) $ do
     MultiPackageConfigFieldsIntermediate
-      <$> (MultiPackageConfigFields <$> traverse canonicalizePath packagePaths)
+      <$> 
+        ( MultiPackageConfigFields
+            <$> traverse canonicalizePath (mpPackagePaths mpc)
+            <*> traverse canonicalizeCompositeDar (mpCompositeDars mpc)
+            <*> pure (mpTransitiveCompositeDarNames mpc)
+            <*> pure (mpPath mpc)
+        )
       <*> traverse canonicalizePath multiPackagePaths
 
 -- Given some computation to give a result and dependencies, we explore the entire cyclic graph to give the combined
@@ -202,11 +253,16 @@ fullParseMultiPackageConfig :: ProjectPath -> IO MultiPackageConfigFields
 fullParseMultiPackageConfig startPath = do
   mpcs <- exploreAndFlatten startPath $ \projectPath -> do
     multiPackage <- readMultiPackageConfig projectPath
-    multiPackageConfigI <- either throwIO pure (parseMultiPackageConfig multiPackage)
+    multiPackageConfigI <- either throwIO pure (parseMultiPackageConfig multiPackage $ unwrapProjectPath projectPath)
     canonMultiPackageConfigI <- canonicalizeMultiPackageConfigIntermediate projectPath multiPackageConfigI
     pure (ProjectPath <$> mpiOtherConfigFiles canonMultiPackageConfigI, mpiConfigFields canonMultiPackageConfigI)
 
-  pure $ MultiPackageConfigFields $ nubOrd $ concatMap mpPackagePaths mpcs
+  pure MultiPackageConfigFields
+    { mpPackagePaths = nubOrd $ concatMap mpPackagePaths mpcs
+    , mpCompositeDars = mpCompositeDars $ head mpcs
+    , mpTransitiveCompositeDarNames = (\mpc -> (mpPath mpc, cdName <$> mpCompositeDars mpc)) <$> tail mpcs
+    , mpPath = mpPath $ head mpcs
+    }
 
 -- Gives the filepath where the multipackage was found if its not the same as project path.
 withMultiPackageConfig :: ProjectPath -> (MultiPackageConfigFields -> IO a) -> IO a