Add metadata checks to upgraded dar

sdk/bazel-haskell-deps.bzl

@@ -18,8 +18,8 @@ load("@dadew//:dadew.bzl", "dadew_tool_home")
 load("@rules_haskell//haskell:cabal.bzl", "stack_snapshot")
 load("//bazel_tools/ghc-lib:repositories.bzl", "ghc_lib_and_dependencies")
 
-GHCIDE_REV = "eff0d9141f5825f4765fb0899f65f5174cb29261"
-GHCIDE_SHA256 = "a43aa87c1b8e4ff4b861c0ab728df8ac125ab4c4c01420eaa86d60c1e32f5c87"
+GHCIDE_REV = "1ec6a3457f8f3700376be6b6ee4fe6591fc129ee"
+GHCIDE_SHA256 = "6ed371ebf9597aab21675fc4c54dbc59bc4b7648ab7513482620c996b650ea29"
 GHCIDE_LOCAL_PATH = None
 JS_JQUERY_VERSION = "3.3.1"
 JS_DGTABLE_VERSION = "0.5.2"

sdk/compiler/damlc/daml-ide-core/BUILD.bazel

@@ -66,6 +66,7 @@ da_haskell_library(
         "//compiler/damlc/daml-package-config",
         "//compiler/damlc/daml-rule-types",
         "//compiler/scenario-service/client",
+        "//daml-assistant:daml-project-config",
         "//libs-haskell/bazel-runfiles",
         "//libs-haskell/da-hs-base",
         "//sdk-version/hs:sdk-version-class-lib",

sdk/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Rules/Daml.hs

@@ -23,7 +23,7 @@ import qualified DA.Daml.LF.Proto3.EncodeV1 as EncodeV1
 import qualified DA.Daml.LF.Proto3.EncodeV2 as EncodeV2
 import HscTypes
 import MkIface
-import Maybes (MaybeErr(..))
+import Maybes (MaybeErr(..), rightToMaybe)
 import TcRnMonad (initIfaceLoad)
 
 import qualified "zip-archive" Codec.Archive.Zip as ZipArchive
@@ -38,6 +38,8 @@ import DA.Daml.LF.Ast (renderMajorVersion, Version (versionMajor))
 import DA.Daml.Options
 import DA.Daml.Options.Packaging.Metadata
 import DA.Daml.Options.Types
+import DA.Daml.Project.Consts (projectConfigName)
+import DA.Daml.Project.Types (ProjectPath (..))
 import Data.Aeson hiding (Options)
 import Data.Bifunctor (bimap)
 import Data.Binary (Binary())
@@ -46,6 +48,7 @@ import qualified Data.ByteString.Lazy as BSL
 import qualified Data.ByteString.UTF8 as BS
 import Data.Either.Extra
 import Data.Foldable
+import Data.Function (on)
 import qualified Data.HashMap.Strict as HashMap
 import qualified Data.HashSet as HashSet
 import Data.Hashable (Hashable())
@@ -536,12 +539,87 @@ generatePackageMap version mbProjRoot userPkgDbs = do
                      (LF.extPackagePkg $ LF.dalfPackagePkg pkg)
                      (LF.dalfPackageId pkg)
 
+getUpgradedPackageErrs :: Options -> LSP.NormalizedFilePath -> LF.Package -> [FileDiagnostic]
+getUpgradedPackageErrs opts file mainPkg = catMaybes $
+  [ justIf (not $ optDamlLfVersion opts `LF.supports` LF.featurePackageUpgrades) $
+      ideErrorPretty file $ mconcat
+        [ mainPackage <> " LF Version ("
+        , T.pack $ LF.renderVersion $ optDamlLfVersion opts
+        , ") does not support Smart Contract Upgrades"
+        ]
+  , justIf (not $ LF.packageLfVersion mainPkg `LF.supports` LF.featurePackageUpgrades) $
+      ideErrorPretty file $ mconcat
+        [ upgradedPackage <> " LF Version ("
+        , T.pack $ LF.renderVersion $ LF.packageLfVersion mainPkg
+        , ") does not support Smart Contract Upgrades"
+        ]
+  , if optDamlLfVersion opts `lfVersionMajorNe` LF.packageLfVersion mainPkg
+      then
+        Just $
+          ideErrorPretty file $ mconcat
+            [ mainPackage <> " LF Version ("
+            , T.pack $ LF.renderVersion $ LF.packageLfVersion mainPkg
+            , ") must have the same major LF version as " <> upgradedPackage <> " LF Version ("
+            , T.pack $ LF.renderVersion $ optDamlLfVersion opts
+            , ")"
+            ]
+      else
+        justIf (optDamlLfVersion opts `lfVersionMinorLt` LF.packageLfVersion mainPkg) $
+          ideErrorPretty file $ mconcat
+            [ mainPackage <> " LF Version ("
+            , T.pack $ LF.renderVersion $ optDamlLfVersion opts
+            , ") cannot be lower than the " <> upgradedPackage <> " LF Version ("
+            , T.pack $ LF.renderVersion $ LF.packageLfVersion mainPkg
+            , ")"
+            ]
+  ] ++ case LF.packageMetadata mainPkg of
+    Nothing -> [Just $ ideErrorPretty file ("Upgraded DAR does not contain metadata" :: T.Text)]
+    Just meta ->
+      [ justIf (optMbPackageName opts /= Just (LF.packageName meta)) $
+          ideErrorPretty file $ mconcat
+            [ "Main package must have the same package name as upgraded package."
+            , "\n" <> mainPackage <> " name: "
+            , maybe "<unknown>" LF.unPackageName (optMbPackageName opts)
+
+            , "\n" <> upgradedPackage <> " name: "
+            , LF.unPackageName (LF.packageName meta)
+            ]
+      , justIf (optMbPackageVersion opts == Just (LF.packageVersion meta)) $
+          ideErrorPretty file $
+            mainPackage <> " cannot have the same package version as " <> upgradedPackage
+      , justIf (maybe False (`packageVersionLt` LF.packageVersion meta) $ optMbPackageVersion opts) $
+          ideErrorPretty file $
+            upgradedPackage <> " cannot have a higher package version than " <> mainPackage
+      ]
+  where
+    justIf :: Bool -> a -> Maybe a
+    justIf cond val = guard cond >> Just val
+
+    -- package versions have been checked at this point
+    packageVersionLt :: LF.PackageVersion -> LF.PackageVersion -> Bool
+    packageVersionLt = (<) `on` fromRight (error "Impossible invalid package version") . LF.splitPackageVersion id
+
+    lfVersionMinorLt :: LF.Version -> LF.Version -> Bool
+    lfVersionMinorLt = (<) `on` LF.versionMinor
+
+    lfVersionMajorNe :: LF.Version -> LF.Version -> Bool
+    lfVersionMajorNe = (/=) `on` LF.versionMajor
+
+    -- Renders "v1.0.0" if the version exists, "no version" else
+    renderMPackageVersion :: Maybe LF.PackageVersion -> T.Text
+    renderMPackageVersion = maybe "no version" $ \v -> "v" <> LF.unPackageVersion v
+
+    mainPackage :: T.Text
+    mainPackage = "Main package (" <> renderMPackageVersion (optMbPackageVersion opts) <> ")"
+
+    upgradedPackage :: T.Text
+    upgradedPackage = "Upgraded package (" <> renderMPackageVersion (LF.packageVersion <$> LF.packageMetadata mainPkg) <> ")"
+
 extractUpgradedPackageRule :: Options -> Rules ()
 extractUpgradedPackageRule opts = do
   defineNoFile $ \ExtractUpgradedPackage ->
-    case uiUpgradedPackagePath (optUpgradeInfo opts) of
-      Nothing -> pure Nothing
-      Just path -> use ExtractUpgradedPackageFile (toNormalizedFilePath' path)
+    forM (uiUpgradedPackagePath $ optUpgradeInfo opts) $
+      use_ ExtractUpgradedPackageFile . toNormalizedFilePath'
   define $ \ExtractUpgradedPackageFile file -> do
     ExtractedDar{edMain,edDalfs} <- liftIO $ extractDar (fromNormalizedFilePath file)
     let decodeEntryWithUnitId decodeAs entry = do
@@ -557,10 +635,13 @@ extractUpgradedPackageRule opts = do
            main <- decodeEntryWithUnitId Archive.DecodeAsMain edMain
            deps <- decodeEntryWithUnitId Archive.DecodeAsDependency `traverse` edDalfs
            pure (main, deps)
-    let myThing = case mainAndDeps of
-          Left _ -> ([ideErrorPretty file ("Could not decode file as a DAR." :: T.Text)], Nothing)
-          Right mainAndDeps -> ([], Just mainAndDeps)
-    pure myThing
+        packageConfigFilePath = maybe file (LSP.toNormalizedFilePath . (</> projectConfigName) . unwrapProjectPath) $ optMbPackageConfigPath opts
+        diags = case mainAndDeps of
+          Left _ -> [ideErrorPretty packageConfigFilePath ("Could not decode file as a DAR." :: T.Text)]
+          Right ((_, mainPkg, _, _), _) -> getUpgradedPackageErrs opts packageConfigFilePath mainPkg
+    extras <- getShakeExtras
+    updateFileDiagnostics packageConfigFilePath ExtractUpgradedPackageFile extras $ map (\(_,y,z) -> (y,z)) diags
+    pure ([], guard (null diags) >> rightToMaybe mainAndDeps)
 
 readDalfPackage :: FilePath -> IO (Either FileDiagnostic LF.DalfPackage)
 readDalfPackage dalf = do

sdk/compiler/damlc/daml-opts/BUILD.bazel

@@ -27,6 +27,7 @@ da_haskell_library(
     deps = [
         "//compiler/daml-lf-ast",
         "//compiler/damlc/daml-package-config",
+        "//daml-assistant:daml-project-config",
         "//libs-haskell/bazel-runfiles",
         "//libs-haskell/da-hs-base",
     ],

sdk/compiler/damlc/daml-opts/daml-opts-types/DA/Daml/Options/Types.hs

@@ -43,6 +43,7 @@ module DA.Daml.Options.Types
 import Control.Monad.Reader
 import DA.Bazel.Runfiles
 import qualified DA.Daml.LF.Ast as LF
+import DA.Daml.Project.Types (ProjectPath)
 import DA.Pretty
 import qualified DA.Service.Logger as Logger
 import qualified DA.Service.Logger.Impl.IO as Logger.IO
@@ -72,6 +73,8 @@ data Options = Options
     -- ^ Name of the package (version not included, so this is not the unit id)
   , optMbPackageVersion :: Maybe LF.PackageVersion
     -- ^ Version of the package
+  , optMbPackageConfigPath :: Maybe ProjectPath
+    -- ^ Path to the daml.yaml
   , optIfaceDir :: Maybe FilePath
     -- ^ directory to write interface files to. If set to `Nothing` we default to <current working dir>.daml/interfaces.
   , optPackageImports :: [PackageFlag]
@@ -128,6 +131,9 @@ data Options = Options
   -- packages from remote ledgers.
   , optAllowLargeTuples :: AllowLargeTuples
   -- ^ Do not warn when tuples of size > 5 are used
+  , optHideUnitId :: Bool
+  -- ^ When running in IDE, some rules need access to the package name and version, but we don't want to use own
+  -- unit-id, as script + scenario service assume it will be "main"
   , optUpgradeInfo :: UpgradeInfo
   }
 
@@ -252,6 +258,7 @@ defaultOptions mbVersion =
         , optStablePackages = Nothing
         , optMbPackageName = Nothing
         , optMbPackageVersion = Nothing
+        , optMbPackageConfigPath = Nothing
         , optIfaceDir = Nothing
         , optPackageImports = []
         , optShakeProfiling = Nothing
@@ -275,6 +282,7 @@ defaultOptions mbVersion =
         , optEnableOfInterestRule = False
         , optAccessTokenPath = Nothing
         , optAllowLargeTuples = AllowLargeTuples False
+        , optHideUnitId = False
         , optUpgradeInfo = defaultUpgradeInfo
         }
 
@@ -302,7 +310,7 @@ fullPkgName (LF.PackageName n) mbV (LF.PackageId h) =
         Just (LF.PackageVersion v) -> n <> "-" <> v <> "-" <> h
 
 optUnitId :: Options -> Maybe UnitId
-optUnitId Options{..} = fmap (\name -> pkgNameVersion name optMbPackageVersion) optMbPackageName
+optUnitId Options{..} = guard (not optHideUnitId) >> fmap (\name -> pkgNameVersion name optMbPackageVersion) optMbPackageName
 
 getLogger :: Options -> T.Text -> IO (Logger.Handle IO)
 getLogger Options {optLogLevel} name = Logger.IO.newStderrLogger optLogLevel name