Upgrade validation compare deps

sdk/canton/community/ledger/ledger-api-core/src/main/scala/com/digitalasset/canton/platform/apiserver/services/admin/PackageUpgradeValidator.scala

@@ -72,12 +72,14 @@ class PackageUpgradeValidator(
               TypecheckUpgrades.MaximalDarCheck,
               optUpgradingDar,
               optMaximalDar,
+              packageMap,
             )
             optMinimalDar <- minimalVersionedDar(upgradingPackageAst, packageMap)
             _ <- typecheckUpgrades(
               TypecheckUpgrades.MinimalDarCheck,
               optMinimalDar,
               optUpgradingDar,
+              packageMap,
             )
             _ = logger.info(s"Typechecking upgrades for $upgradingPackageId succeeded.")
           } yield ()
@@ -141,11 +143,13 @@ class PackageUpgradeValidator(
       .map(_.flatten)
   }
 
+  type PackageMap = Map[Ref.PackageId, (Ref.PackageName, Ref.PackageVersion)]
+
   private def strictTypecheckUpgrades(
       phase: TypecheckUpgrades.UploadPhaseCheck,
-      optNewDar1: Option[(Ref.PackageId, Ast.Package)],
+      optNewDar1: Option[(Ref.PackageId, Ast.Package, PackageMap)],
       oldPkgId2: Ref.PackageId,
-      optOldPkg2: Option[Ast.Package],
+      optOldPkg2: Option[(Ast.Package, PackageMap)],
   )(implicit
       loggingContext: LoggingContextWithTrace
   ): Future[Unit] = {
@@ -156,11 +160,11 @@ class PackageUpgradeValidator(
         case None =>
           Future.unit
 
-        case Some((newPkgId1, newPkg1)) =>
+        case Some((newPkgId1, newPkg1, newPkgDeps1)) =>
           logger.info(s"Package $newPkgId1 claims to upgrade package id $oldPkgId2")
           Future
             .fromTry(
-              TypecheckUpgrades.typecheckUpgrades((newPkgId1, newPkg1), oldPkgId2, optOldPkg2)
+              TypecheckUpgrades.typecheckUpgrades((newPkgId1, newPkg1, newPkgDeps1), oldPkgId2, optOldPkg2)
             )
             .recoverWith {
               case err: UpgradeError =>
@@ -189,6 +193,7 @@ class PackageUpgradeValidator(
       typecheckPhase: TypecheckUpgrades.UploadPhaseCheck,
       optNewDar1: Option[(Ref.PackageId, Ast.Package)],
       optOldDar2: Option[(Ref.PackageId, Ast.Package)],
+      packageMap: PackageMap,
   )(implicit
       loggingContext: LoggingContextWithTrace
   ): Future[Unit] = {
@@ -199,9 +204,9 @@ class PackageUpgradeValidator(
       case (Some((newPkgId1, newPkg1)), Some((oldPkgId2, oldPkg2))) =>
         strictTypecheckUpgrades(
           typecheckPhase,
-          Some((newPkgId1, newPkg1)),
+          Some((newPkgId1, newPkg1, newPkg1.directDeps.map((x: Ref.PackageId) => (x, packageMap(x))).toMap)),
           oldPkgId2,
-          Some(oldPkg2),
+          Some(oldPkg2, oldPkg2.directDeps.map((x: Ref.PackageId) => (x, packageMap(x))).toMap),
         )
     }
   }

sdk/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs

@@ -16,6 +16,7 @@ import Data.List.Extra (nubSort, stripInfixEnd)
 import qualified Data.NameMap as NM
 import Module (UnitId, unitIdString, stringToUnitId)
 import System.FilePath
+import Text.Read (readMaybe)
 
 import DA.Daml.LF.Ast.Base
 import DA.Daml.LF.Ast.TypeLevelNat
@@ -323,3 +324,30 @@ splitUnitId (unitIdString -> unitId) = fromMaybe (PackageName (T.pack unitId), N
     (name, ver) <- stripInfixEnd "-" unitId
     guard $ all (`elem` '.' : ['0' .. '9']) ver
     pure (PackageName (T.pack name), Just (PackageVersion (T.pack ver)))
+
+-- | Take a package version of regex "(0|[1-9][0-9]*)(\.(0|[1-9][0-9]*))*" into
+-- a list of integers [Integer]
+splitPackageVersion
+  :: (PackageVersion -> a) -> PackageVersion
+  -> Either a [Integer]
+splitPackageVersion mkError version@(PackageVersion raw) =
+  let pieces = T.split (== '.') raw
+  in
+  case traverse (readMaybe . T.unpack) pieces of
+    Nothing -> Left (mkError version)
+    Just versions -> Right versions
+
+data ComparePackageVersionError
+  = FirstVersionUnparseable PackageVersion
+  | SecondVersionUnparseable PackageVersion
+  deriving (Show, Eq, Ord)
+
+comparePackageVersion :: PackageVersion -> PackageVersion -> Either ComparePackageVersionError Ordering
+comparePackageVersion v1 v2 = do
+  v1Pieces <- splitPackageVersion FirstVersionUnparseable v1
+  v2Pieces <- splitPackageVersion SecondVersionUnparseable v2
+  let pad xs target =
+        take
+          (length target `max` length xs)
+          (xs ++ repeat 0)
+  pure $ compare (pad v1Pieces v2Pieces) (pad v2Pieces v1Pieces)

sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs

@@ -191,6 +191,7 @@ data UpgradeError
   | TemplateAddedKey !TypeConName !TemplateKey
   | TriedToUpgradeIface !TypeConName
   | MissingImplementation !TypeConName !TypeConName
+  | DependencyHasLowerVersionDespiteUpgrade !PackageName !PackageVersion !PackageVersion
   deriving (Eq, Ord, Show)
 
 data UpgradedRecordOrigin
@@ -595,6 +596,11 @@ instance Pretty UpgradeError where
     TemplateAddedKey template _key -> "The upgraded template " <> pPrint template <> " cannot add a key where it didn't have one previously."
     TriedToUpgradeIface iface -> "Tried to upgrade interface " <> pPrint iface <> ", but interfaces cannot be upgraded. They should be removed in any upgrading package."
     MissingImplementation tpl iface -> "Implementation of interface " <> pPrint iface <> " by template " <> pPrint tpl <> " appears in package that is being upgraded, but does not appear in this package."
+    DependencyHasLowerVersionDespiteUpgrade pkgName presentVersion pastVersion ->
+      vcat
+        [ "Dependency " <> pPrint pkgName <> " has version " <> pPrint presentVersion <> " on the upgrading package, which is older than version " <> pPrint pastVersion <> " on the upgraded package."
+        , "Dependency versions of upgrading packages must always be greater or equal to the dependency versions on upgraded packages."
+        ]
 
 instance Pretty UpgradedRecordOrigin where
   pPrint = \case
@@ -654,6 +660,8 @@ data Warning
   | WShouldDefineIfacesAndTemplatesSeparately
   | WShouldDefineIfaceWithoutImplementation !TypeConName ![TypeConName]
   | WShouldDefineTplInSeparatePackage !TypeConName !TypeConName
+  | WPastDependencyHasUnparseableVersion !PackageName !PackageVersion
+  | WPresentDependencyHasUnparseableVersion !PackageName !PackageVersion
   deriving (Show)
 
 warningLocation :: Warning -> Maybe SourceLoc
@@ -694,6 +702,10 @@ instance Pretty Warning where
         [ "The template " <> pPrint tpl <> " has implemented interface " <> pPrint iface <> ", which is defined in a previous version of this package."
         , "However, it is recommended that interfaces are defined in their own package separate from their implementations."
         ]
+    WPastDependencyHasUnparseableVersion pkgName version ->
+      "Dependency " <> pPrint pkgName <> " of upgrading package has a version which cannot be parsed: '" <> pPrint version <> "'"
+    WPresentDependencyHasUnparseableVersion pkgName version ->
+      "Dependency " <> pPrint pkgName <> " of upgraded package has a version which cannot be parsed: '" <> pPrint version <> "'"
 
 instance ToDiagnostic Warning where
   toDiagnostic warning = Diagnostic

sdk/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Upgrade.hs

@@ -61,6 +61,56 @@ runGammaUnderUpgrades Upgrading{ _past = pastAction, _present = presentAction }
     presentResult <- withReaderT _present presentAction
     pure Upgrading { _past = pastResult, _present = presentResult }
 
+checkUpgradeDependencies
+    :: Version
+    -> Bool
+    -> LF.Package
+    -> [LF.DalfPackage]
+    -> Maybe ((LF.PackageId, LF.Package), [(LF.PackageId, LF.Package)])
+    -> [Diagnostic]
+checkUpgradeDependencies _ _ _ _ Nothing = []
+checkUpgradeDependencies version shouldTypecheckUpgrades presentPkg presentDeps (Just ((_pastPkgId, pastPkg), pastDeps)) =
+    let package = Upgrading { _past = pastPkg, _present = presentPkg }
+        upgradingWorld = fmap (\package -> emptyGamma (initWorldSelf [] package) version) package
+    in
+    extractDiagnostics $
+        runGammaF upgradingWorld $
+            when shouldTypecheckUpgrades (checkUpgradeDependenciesM presentPkg presentDeps pastPkg pastDeps)
+
+checkUpgradeDependenciesM
+    :: LF.Package
+    -> [LF.DalfPackage]
+    -> LF.Package
+    -> [(LF.PackageId, LF.Package)]
+    -> TcUpgradeM ()
+checkUpgradeDependenciesM _presentPkg presentDeps _pastPkg pastDeps = do
+    let packageToNameVersion :: LF.Package -> (LF.PackageName, LF.PackageVersion)
+        packageToNameVersion LF.Package{packageMetadata = LF.PackageMetadata{packageName, packageVersion}} =
+            (packageName, packageVersion)
+        presentDepsMap =
+            HMS.fromList $ map (packageToNameVersion . extPackagePkg . dalfPackagePkg) presentDeps
+        pastDepsMap =
+            HMS.fromList $ map (packageToNameVersion . snd) pastDeps
+    let (_del, existingDeps, _new) = extractDelExistNew Upgrading { _past = pastDepsMap, _present = presentDepsMap }
+    forM_ (HMS.toList existingDeps) $ \(depName, depVersions) -> do
+        case LF.comparePackageVersion (_present depVersions) (_past depVersions) of
+          Left (FirstVersionUnparseable presentVersion) ->
+            warnWithContextF present $
+              WPresentDependencyHasUnparseableVersion depName presentVersion
+          Left (SecondVersionUnparseable pastVersion) ->
+            warnWithContextF present $
+              WPastDependencyHasUnparseableVersion depName pastVersion
+          Right LT ->
+            throwWithContextF present $ EUpgradeError $
+              DependencyHasLowerVersionDespiteUpgrade depName (_present depVersions) (_past depVersions)
+          _ -> pure () -- if it's greater than or equal, the dependency is a valid upgrade
+
+extractDiagnostics :: Either Error ((), [Warning]) -> [Diagnostic]
+extractDiagnostics result =
+    case result of
+      Left err -> [toDiagnostic err]
+      Right ((), warnings) -> map toDiagnostic warnings
+
 checkUpgrade :: Version -> Bool -> LF.Package -> Maybe (LF.PackageId, LF.Package) -> [Diagnostic]
 checkUpgrade version shouldTypecheckUpgrades presentPkg mbUpgradedPackage =
     let bothPkgDiagnostics :: Either Error ((), [Warning])
@@ -82,12 +132,6 @@ checkUpgrade version shouldTypecheckUpgrades presentPkg mbUpgradedPackage =
             runGamma world version $ do
                  checkNewInterfacesHaveNoTemplates presentPkg
                  checkNewInterfacesAreUnused presentPkg
-
-        extractDiagnostics :: Either Error ((), [Warning]) -> [Diagnostic]
-        extractDiagnostics result =
-            case result of
-              Left err -> [toDiagnostic err]
-              Right ((), warnings) -> map toDiagnostic warnings
     in
     extractDiagnostics bothPkgDiagnostics ++ extractDiagnostics singlePkgDiagnostics
 

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

@@ -136,23 +136,29 @@ buildDar service PackageConfigFields {..} ifDir dalfInput = do
                  lfVersion <- lift getDamlLfVersion
                  mbUpgradedPackage <-
                    forM pUpgradedPackagePath $ \path -> do
-                     ExtractedDar{edMain} <- liftIO $ extractDar path
-                     let bs = BSL.toStrict $ ZipArchive.fromEntry edMain
-                     case Archive.decodeArchive Archive.DecodeAsMain bs of
+                     ExtractedDar{edMain,edDalfs} <- liftIO $ extractDar path
+                     let bsMain = BSL.toStrict $ ZipArchive.fromEntry edMain
+                     let bsDeps = BSL.toStrict . ZipArchive.fromEntry <$> edDalfs
+                     let mainAndDeps :: Either Archive.ArchiveError ((LF.PackageId, LF.Package), [(LF.PackageId, LF.Package)])
+                         mainAndDeps = do
+                            main <- Archive.decodeArchive Archive.DecodeAsMain bsMain
+                            deps <- Archive.decodeArchive Archive.DecodeAsDependency `traverse` bsDeps
+                            pure (main, deps)
+                     case mainAndDeps of
                         Left _ -> error $ "Could not decode path " ++ path
-                        Right (pid, package) -> return (pid, package)
+                        Right mainAndDeps -> pure mainAndDeps
                  let pMeta = LF.PackageMetadata
                         { packageName = pName
                         , packageVersion = fromMaybe (LF.PackageVersion "0.0.0") pVersion
-                        , upgradedPackageId = fst <$> mbUpgradedPackage
+                        , upgradedPackageId = fst . fst <$> mbUpgradedPackage
                         }
                  pkg <- case optShakeFiles opts of
                      Nothing -> mergePkgs pMeta lfVersion . map fst <$> usesE GeneratePackage files
                      Just _ -> generateSerializedPackage pName pVersion pMeta files
 
                  MaybeT $
                      runDiagnosticCheck $ diagsToIdeResult (toNormalizedFilePath' pSrc) $
-                         TypeChecker.Upgrade.checkUpgrade lfVersion pTypecheckUpgrades pkg mbUpgradedPackage
+                         TypeChecker.Upgrade.checkUpgrade lfVersion pTypecheckUpgrades pkg (fst <$> mbUpgradedPackage)
                  MaybeT $ finalPackageCheck (toNormalizedFilePath' pSrc) pkg
 
                  let pkgModuleNames = map (Ghc.mkModuleName . T.unpack) $ LF.packageModuleNames pkg
@@ -174,6 +180,9 @@ buildDar service PackageConfigFields {..} ifDir dalfInput = do
                          [ (T.pack $ unitIdString unitId, LF.dalfPackageBytes pkg, LF.dalfPackageId pkg)
                          | (unitId, pkg) <- Map.toList dalfDependencies0
                          ]
+                 MaybeT $
+                     runDiagnosticCheck $ diagsToIdeResult (toNormalizedFilePath' pSrc) $
+                         TypeChecker.Upgrade.checkUpgradeDependencies lfVersion pTypecheckUpgrades pkg (Map.elems dalfDependencies0) mbUpgradedPackage
                  unstableDeps <- getUnstableDalfDependencies files
                  let confFile = mkConfFile pName pVersion (Map.keys unstableDeps) pExposedModules pkgModuleNames pkgId
                  let dataFiles = [confFile]

sdk/compiler/damlc/tests/BUILD.bazel

@@ -446,7 +446,6 @@ da_haskell_test(
 da_haskell_test(
     name = "upgrades",
     srcs = ["src/DA/Test/DamlcUpgrades.hs"],
-    compiler_flags = ["-Wno-unused-local-binds"],
     data = [
         "//compiler/damlc",
         "//daml-script/daml:daml-script.dar",
@@ -462,6 +461,7 @@ da_haskell_test(
         "//test-common:upgrades-FailsWhenATopLevelVariantRemovesAVariant-files",
         "//test-common:upgrades-FailsWhenAnInstanceIsDropped-files",
         "//test-common:upgrades-FailsWhenAnInterfaceIsDefinedInAnUpgradingPackageWhenItWasAlreadyInThePriorPackage-files",
+        "//test-common:upgrades-FailsWhenDepsDowngradeVersions-files",
         "//test-common:upgrades-FailsWhenExistingFieldInTemplateChoiceIsChanged-files",
         "//test-common:upgrades-FailsWhenExistingFieldInTemplateIsChanged-files",
         "//test-common:upgrades-FailsWhenNewFieldIsAddedToTemplateChoiceWithoutOptionalType-files",

sdk/compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs

@@ -298,17 +298,22 @@ tests damlc =
               "FailsWithSynonymReturnTypeChangeInSeparatePackage"
               (FailWithError "\ESC\\[0;91merror type checking template Main.T choice C:\n  The upgraded choice C cannot change its return type.")
               LF.versionDefault
-              SeparateDeps
+              (SeparateDeps False)
         , test
               "SucceedsWhenUpgradingADependency"
               Succeed
               LF.versionDefault
-              SeparateDeps
+              (SeparateDeps False)
         , test
               "FailsOnlyInModuleNotInReexports"
               (FailWithError "\ESC\\[0;91merror type checking data type Other.A:\n  The upgraded data type A has added new fields, but those fields are not Optional.")
               LF.versionDefault
               NoDependencies
+        , test
+              "FailsWhenDepsDowngradeVersions"
+              (FailWithError "\ESC\\[0;91merror type checking <none>:\n  Dependency upgrades-example-FailsWhenDepsDowngradeVersions-dep has version 0.0.1 on the upgrading package, which is older than version 0.0.2 on the upgraded package.\n  Dependency versions of upgrading packages must always be greater or equal to the dependency versions on upgraded packages.")
+              LF.versionDefault
+              (SeparateDeps True)
         ]
   where
     contractKeysMinVersion :: LF.Version
@@ -353,18 +358,18 @@ tests damlc =
                       )
                 let sharedDir = dir </> "shared"
                 let sharedDar = sharedDir </> "out.dar"
-                writeFiles sharedDir (projectFile lfVersion ("upgrades-example-" <> name <> "-dep") Nothing Nothing : sharedDepFiles)
+                writeFiles sharedDir (projectFile lfVersion "0.0.1" ("upgrades-example-" <> name <> "-dep") Nothing Nothing : sharedDepFiles)
                 callProcessSilent damlc ["build", "--project-root", sharedDir, "-o", sharedDar]
                 pure (Just sharedDar, Just sharedDar)
-              SeparateDeps -> do
+              SeparateDeps { shouldSwap } -> do
                 depV1FilePaths <- listDirectory =<< testRunfile (name </> "dep-v1")
                 let depV1Files = flip map depV1FilePaths $ \path ->
                       ( "daml" </> path
                       , readFile =<< testRunfile (name </> "dep-v1" </> path)
                       )
                 let depV1Dir = dir </> "shared-v1"
                 let depV1Dar = depV1Dir </> "out.dar"
-                writeFiles depV1Dir (projectFile lfVersion ("upgrades-example-" <> name <> "-dep-v1") Nothing Nothing : depV1Files)
+                writeFiles depV1Dir (projectFile lfVersion "0.0.1" ("upgrades-example-" <> name <> "-dep") Nothing Nothing : depV1Files)
                 callProcessSilent damlc ["build", "--project-root", depV1Dir, "-o", depV1Dar]
 
                 depV2FilePaths <- listDirectory =<< testRunfile (name </> "dep-v2")
@@ -374,19 +379,21 @@ tests damlc =
                       )
                 let depV2Dir = dir </> "shared-v2"
                 let depV2Dar = depV2Dir </> "out.dar"
-                writeFiles depV2Dir (projectFile lfVersion ("upgrades-example-" <> name <> "-dep-v2") Nothing Nothing : depV2Files)
+                writeFiles depV2Dir (projectFile lfVersion "0.0.2" ("upgrades-example-" <> name <> "-dep") Nothing Nothing : depV2Files)
                 callProcessSilent damlc ["build", "--project-root", depV2Dir, "-o", depV2Dar]
 
-                pure (Just depV1Dar, Just depV2Dar)
+                if shouldSwap
+                   then pure (Just depV2Dar, Just depV1Dar)
+                   else pure (Just depV1Dar, Just depV2Dar)
               DependOnV1 ->
                 pure (Nothing, Just oldDar)
               _ ->
                 pure (Nothing, Nothing)
 
-            writeFiles oldDir (projectFile lfVersion ("upgrades-example-" <> name) Nothing depV1Dar : oldVersion)
+            writeFiles oldDir (projectFile lfVersion "0.0.1" ("upgrades-example-" <> name) Nothing depV1Dar : oldVersion)
             callProcessSilent damlc ["build", "--project-root", oldDir, "-o", oldDar]
 
-            writeFiles newDir (projectFile lfVersion ("upgrades-example-" <> name <> "-v2") (Just oldDar) depV2Dar : newVersion)
+            writeFiles newDir (projectFile lfVersion "0.0.2" ("upgrades-example-" <> name <> "-v2") (Just oldDar) depV2Dar : newVersion)
             case expectation of
               Succeed ->
                   callProcessSilent damlc ["build", "--project-root", newDir, "-o", newDar]
@@ -411,13 +418,13 @@ tests damlc =
             createDirectoryIfMissing True (takeDirectory $ dir </> file)
             writeFileUTF8 (dir </> file) content
 
-    projectFile lfVersion name upgradedFile mbDep =
+    projectFile lfVersion version name upgradedFile mbDep =
         ( "daml.yaml"
         , unlines $
           [ "sdk-version: " <> sdkVersion
           , "name: " <> name
           , "source: daml"
-          , "version: 0.0.1"
+          , "version: " <> version
           , "dependencies:"
           , "  - daml-prim"
           , "  - daml-stdlib"
@@ -439,4 +446,4 @@ data Dependency
   = NoDependencies
   | DependOnV1
   | SeparateDep
-  | SeparateDeps
+  | SeparateDeps { shouldSwap :: Bool }