Implement composite dar generation

Add path and dars fields to composite-dar

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,24 @@ 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.Bifunctor (bimap)
 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 Data.Maybe (fromJust)
+import qualified Data.Text as T
 import Data.Void
+import System.FilePath (takeBaseName)
 import Text.Megaparsec
 import Text.Megaparsec.Byte
 
@@ -90,11 +97,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 +121,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 -> (T.Text, LF.PackageId)
+extractNameAndPackageIdFromPath = bimap (T.pack . intercalate "-") (LF.PackageId . T.pack) . fromJust . unsnoc . wordsBy (=='-') . 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
+          let (name, pkgId) = 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
@@ -67,7 +70,7 @@ import Module
 import qualified Module as Ghc
 import HscTypes
 import qualified Data.SemVer as V
-import DA.Daml.Project.Types (UnresolvedReleaseVersion(..))
+import DA.Daml.Project.Types (UnresolvedReleaseVersion(..), unresolvedBuiltinSdkVersion)
 
 import qualified "zip-archive" Codec.Archive.Zip as ZipArchive
 
@@ -203,6 +206,32 @@ buildDar service PackageConfigFields {..} ifDir dalfInput = do
                    , Just pkgId
                    )
 
+-- Takes maybe list of dar paths, name version, path
+buildCompositeDar :: [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
@@ -104,13 +105,18 @@ data CompositeDar = CompositeDar
     { cdName :: LF.PackageName
     , cdVersion :: LF.PackageVersion
     , cdPackages :: [FilePath]
+    , cdDars :: [FilePath]
+    , cdPath :: Maybe FilePath
     }
+    deriving Show
 
 data MultiPackageConfigFields = MultiPackageConfigFields
     { mpPackagePaths :: [FilePath]
     , mpCompositeDars :: [CompositeDar]
-    , mpTransitiveCompositeDarNames :: [LF.PackageName]
+    , 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
@@ -122,12 +128,17 @@ parseCompositeDar :: MultiPackageCompositeDar -> Either ConfigError CompositeDar
 parseCompositeDar compositeDar = do
     cdName <- queryMultiPackageCompositeDarRequired ["name"] compositeDar
     cdVersion <- queryMultiPackageCompositeDarRequired ["version"] compositeDar
-    cdPackages <- queryMultiPackageCompositeDarRequired ["packages"] compositeDar
-    Right CompositeDar {..}
+    cdPackages <- fromMaybe [] <$> queryMultiPackageCompositeDar ["packages"] compositeDar
+    cdDars <- fromMaybe [] <$> queryMultiPackageCompositeDar ["dars"] compositeDar
+    cdPath <- queryMultiPackageCompositeDar ["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
+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
@@ -197,7 +208,10 @@ findMultiPackageConfig projectPath = do
 canonicalizeCompositeDar :: CompositeDar -> IO CompositeDar
 canonicalizeCompositeDar cd = do
   canonPackages <- traverse canonicalizePath $ cdPackages cd
-  pure cd { cdPackages = canonPackages }
+  canonDars <- traverse canonicalizePath $ cdDars cd
+  canonPath <- traverse canonicalizePath $ cdPath cd
+
+  pure cd { cdPackages = canonPackages, cdDars = canonDars, cdPath = canonPath }
 
 canonicalizeMultiPackageConfigIntermediate :: ProjectPath -> MultiPackageConfigFieldsIntermediate -> IO MultiPackageConfigFieldsIntermediate
 canonicalizeMultiPackageConfigIntermediate projectPath (MultiPackageConfigFieldsIntermediate mpc multiPackagePaths) =
@@ -208,6 +222,7 @@ canonicalizeMultiPackageConfigIntermediate projectPath (MultiPackageConfigFields
             <$> traverse canonicalizePath (mpPackagePaths mpc)
             <*> traverse canonicalizeCompositeDar (mpCompositeDars mpc)
             <*> pure (mpTransitiveCompositeDarNames mpc)
+            <*> pure (mpPath mpc)
         )
       <*> traverse canonicalizePath multiPackagePaths
 
@@ -231,14 +246,15 @@ 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
     { mpPackagePaths = nubOrd $ concatMap mpPackagePaths mpcs
     , mpCompositeDars = mpCompositeDars $ head mpcs
-    , mpTransitiveCompositeDarNames = nubOrd $ concatMap (fmap cdName . mpCompositeDars) $ tail 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.