[ANE-2235] Add support for PNPM v9 lockfile format

src/Strategy/Node/Pnpm/PnpmLock.hs

@@ -8,6 +8,7 @@
 import Control.Applicative ((<|>))
 import Control.Effect.Diagnostics (Diagnostics, Has, context)
 import Data.Aeson.Extra (TextLike (..))
+import Data.Aeson.KeyMap qualified as KeyMap
 import Data.Foldable (for_)
 import Data.Map (Map, toList)
 import Data.Map qualified as Map
@@ -33,6 +34,7 @@
 import Effect.ReadFS (ReadFS, readContentsYaml)
 import Graphing (Graphing, shrink)
 import Path (Abs, File, Path)
+import qualified Data.Maybe as Maybe
 
 -- | Pnpm Lockfile
 --
@@ -122,6 +124,7 @@
 data PnpmLockfile = PnpmLockfile
   { importers :: Map Text ProjectMap
   , packages :: Map Text PackageData
+  , catalogs :: Map Text CatalogMap
   , lockFileVersion :: PnpmLockFileVersion
   }
   deriving (Show, Eq, Ord)
@@ -138,6 +141,7 @@
     rawLockFileVersion <- getVersion =<< obj .:? "lockfileVersion" .!= (TextLike mempty)
     importers <- obj .:? "importers" .!= mempty
     packages <- obj .:? "packages" .!= mempty
+    catalogs <- obj .:? "catalogs" .!= mempty
 
     -- Map pnpm non-workspace lockfile format to pnpm workspace lockfile format.
     --
@@ -156,7 +160,7 @@
             then Map.insert "." virtualRootWs importers
             else importers
 
-    pure $ PnpmLockfile refinedImporters packages rawLockFileVersion
+    pure $ PnpmLockfile refinedImporters packages catalogs rawLockFileVersion
     where
       getVersion (TextLike ver) = case (listToMaybe . toString $ ver) of
         (Just '1') -> pure $ PnpmLockLt4 ver
@@ -165,7 +169,7 @@
         (Just '4') -> pure PnpmLock4Or5
         (Just '5') -> pure PnpmLock4Or5
         (Just '6') -> pure PnpmLock6
-        (Just _) -> pure $ PnpmLockGt6 ver
+        (Just x) | x `elem` ['7', '8', '9'] -> pure $ PnpmLockGt6 ver
         _ -> fail ("expected numeric lockfileVersion, got: " <> show ver)
 
 data ProjectMap = ProjectMap
@@ -181,7 +185,7 @@
       <*> obj .:? "devDependencies" .!= mempty
 
 newtype ProjectMapDepMetadata = ProjectMapDepMetadata
-  { version :: Text
+  { depVersion :: Text  -- renamed from version to avoid name collision
   }
   deriving (Show, Eq, Ord)
 
@@ -218,13 +222,15 @@
   deriving (Show, Eq, Ord)
 
 data GitResolution = GitResolution
-  { gitUrl :: Text
-  , revision :: Text
+  { gitUrl :: Text,
+    revision :: Text
   }
   deriving (Show, Eq, Ord)
 
 newtype TarballResolution = TarballResolution {tarballUrl :: Text} deriving (Show, Eq, Ord)
+
 newtype RegistryResolution = RegistryResolution {integrity :: Text} deriving (Show, Eq, Ord)
+
 newtype DirectoryResolution = DirectoryResolution {directory :: Text} deriving (Show, Eq, Ord)
 
 instance FromJSON Resolution where
@@ -243,6 +249,28 @@
       gitRes :: Object -> Parser Resolution
       gitRes obj = GitResolve <$> (GitResolution <$> obj .: "repo" <*> obj .: "commit")
 
+-- | Catalog map contains package versions and their metadata
+newtype CatalogMap = CatalogMap
+  { catalogEntries :: Map Text CatalogEntry
+  }
+  deriving (Show, Eq, Ord)
+
+instance FromJSON CatalogMap where
+  parseJSON = Yaml.withObject "CatalogMap" $ \obj ->
+    CatalogMap <$> traverse Yaml.parseJSON (KeyMap.toMap obj)
+
+data CatalogEntry = CatalogEntry
+  { specifier :: Text
+  , catalogVersion :: Text  -- renamed from version to avoid name collision
+  }
+  deriving (Show, Eq, Ord)
+
+instance FromJSON CatalogEntry where
+  parseJSON = Yaml.withObject "CatalogEntry" $ \obj ->
+    CatalogEntry
+      <$> obj .: "specifier"
+      <*> obj .: "version"  -- maps the JSON field "version" to our catalogVersion field
+
 analyze :: (Has ReadFS sig m, Has Logger sig m, Has Diagnostics sig m) => Path Abs File -> m (Graphing Dependency)
 analyze file = context "Analyzing Npm Lockfile (v3)" $ do
   pnpmLockFile <- context "Parsing pnpm-lock file" $ readContentsYaml file
@@ -258,12 +286,15 @@
 buildGraph lockFile = withoutLocalPackages $
   run . evalGrapher $ do
     for_ (toList $ importers lockFile) $ \(_, projectSnapshot) -> do
+      -- Track which packages are dev dependencies from the importers section
+      let prodDeps = Set.fromList $ map fst $ toList (directDependencies projectSnapshot)
+      let devDeps = Set.fromList $ map fst $ toList (directDevDependencies projectSnapshot)
       let allDirectDependencies =
             toList (directDependencies projectSnapshot)
               <> toList (directDevDependencies projectSnapshot)
 
       for_ allDirectDependencies $ \(depName, (ProjectMapDepMetadata depVersion)) ->
-        maybe (pure ()) direct $ toResolvedDependency depName depVersion
+        maybe (pure ()) direct $ toResolvedDependency depName depVersion (Set.member depName devDeps)
 
     -- Add edges and deep dependencies by iterating over all packages.
     --
@@ -291,21 +322,21 @@
       let (depName, depVersion) = case getPkgNameVersion pkgKey of
             Nothing -> (pkgKey, Nothing)
             Just (name, version) -> (name, Just version)
-      let parentDep = toDependency depName depVersion pkgMeta
+      let parentDep = toDependency depName depVersion pkgMeta False -- Not a direct dependency, use package's isDev
 
       -- It is ok, if this dependency was already graphed as direct
       -- @direct 1 <> deep 1 = direct 1@
       deep parentDep
 
       for_ deepDependencies $ \(deepName, deepVersion) -> do
-        maybe (pure ()) (edge parentDep) (toResolvedDependency deepName deepVersion)
+        maybe (pure ()) (edge parentDep) (toResolvedDependency deepName deepVersion False)
   where
     getPkgNameVersion :: Text -> Maybe (Text, Text)
     getPkgNameVersion = case lockFileVersion lockFile of
       PnpmLock4Or5 -> getPkgNameVersionV5
       PnpmLock6 -> getPkgNameVersionV6
+      PnpmLockGt6 _ -> getPkgNameVersionV9
       PnpmLockLt4 _ -> getPkgNameVersionV5 -- v3 or below are deprecated and are not used in practice, fallback to closest
-      PnpmLockGt6 _ -> getPkgNameVersionV6 -- at the time of writing there is no v7, so default to closest
 
     -- Gets package name and version from package's key.
     --
@@ -323,6 +354,20 @@
         case (Text.stripSuffix "@" nameWithSlash, version) of
           (Just name, v) -> Just (name, v <> peerDepInfo)
           _ -> Nothing
+    -- Pnpm 9.0 registry packages may not have a leading slash, so it is not required.
+    -- Version may also be a catalog reference like "workspace:*" or "workspace:^1.0.0"
+    --
+    -- >> getPkgNameVersionV9 "@angular/core@1.0.0(babel@1.0.0)" = Just ("@angular/core", "1.0.0(babel@1.0.0)")
+    -- >> getPkgNameVersionV9 "pkg-a@workspace:*" = Just ("pkg-a", "workspace:*")
+    -- >> getPkgNameVersionV9 "pkg-b@workspace:^1.0.0" = Just ("pkg-b", "workspace:^1.0.0")
+    getPkgNameVersionV9 :: Text -> Maybe (Text, Text)
+    getPkgNameVersionV9 pkgKey = do
+      let txt = Maybe.fromMaybe pkgKey (Text.stripPrefix "/" pkgKey)
+          (nameAndVersion, peerDepInfo) = Text.breakOn "(" txt
+          (nameWithSlash, version) = Text.breakOnEnd "@" nameAndVersion
+      case (Text.stripSuffix "@" nameWithSlash, version) of
+        (Just name, v) -> Just (name, v <> peerDepInfo)
+        _ -> Nothing
 
     -- Gets package name and version from package's key.
     --
@@ -360,41 +405,51 @@
     --    e.g.
     --      file:../local-package
     --
-    toResolvedDependency :: Text -> Text -> Maybe Dependency
-    toResolvedDependency depName depVersion = do
+    toResolvedDependency :: Text -> Text -> Bool -> Maybe Dependency
+    toResolvedDependency depName depVersion isImporterDevDep = do
       let maybeNonRegistrySrcPackage = Map.lookup depVersion (packages lockFile)
       let maybeRegistrySrcPackage = Map.lookup (mkPkgKey depName depVersion) (packages lockFile)
       case (maybeNonRegistrySrcPackage, maybeRegistrySrcPackage) of
         (Nothing, Nothing) -> Nothing
-        (Just nonRegistryPkg, _) -> Just $ toDependency depName Nothing nonRegistryPkg
-        (Nothing, Just registryPkg) -> Just $ toDependency depName (Just depVersion) registryPkg
+        (Just nonRegistryPkg, _) -> Just $ toDependency depName Nothing nonRegistryPkg isImporterDevDep
+        (Nothing, Just registryPkg) -> Just $ toDependency depName (Just depVersion) registryPkg isImporterDevDep
 
     -- Makes representative key if the package was
     -- resolved via registry resolver.
     --
     -- >> mkPkgKey "pkg-a" "1.0.0" = "/pkg-a/1.0.0" -- for v5 fmt
     -- >> mkPkgKey "pkg-a" "1.0.0" = "/pkg-a@1.0.0" -- for v6 fmt
     -- >> mkPkgKey "pkg-a" "1.0.0(babal@1.0.0)" = "/pkg-a@1.0.0(babal@1.0.0)" -- for v6 fmt
+    -- >> mkPkgKey "pkg-a" "1.0.0" = "pkg-a@1.0.0" -- for v9 fmt (no leading slash)
     mkPkgKey :: Text -> Text -> Text
     mkPkgKey name version = case lockFileVersion lockFile of
       PnpmLock4Or5 -> "/" <> name <> "/" <> version
       PnpmLock6 -> "/" <> name <> "@" <> version
+      PnpmLockGt6 _ -> name <> "@" <> version  -- v9 doesn't use leading slash
       -- v3 or below are deprecated and are not used in practice, fallback to closest
       PnpmLockLt4 _ -> "/" <> name <> "/" <> version
-      -- at the time of writing there is no v7, so default to closest
-      PnpmLockGt6 _ -> "/" <> name <> "@" <> version
-
-    toDependency :: Text -> Maybe Text -> PackageData -> Dependency
-    toDependency name maybeVersion (PackageData isDev _ (RegistryResolve _) _ _) =
-      toDep NodeJSType name (withoutPeerDepSuffix . withoutSymConstraint <$> maybeVersion) isDev
-    toDependency _ _ (PackageData isDev _ (GitResolve (GitResolution url rev)) _ _) =
-      toDep GitType url (Just rev) isDev
-    toDependency _ _ (PackageData isDev _ (TarballResolve (TarballResolution url)) _ _) =
-      toDep URLType url Nothing isDev
-    toDependency _ _ (PackageData isDev (Just name) (DirectoryResolve _) _ _) =
-      toDep UserType name Nothing isDev
-    toDependency name _ (PackageData isDev Nothing (DirectoryResolve _) _ _) =
-      toDep UserType name Nothing isDev
+
+    -- | Get the actual version for a package, checking catalogs if needed
+    getPackageVersion :: Text -> Text -> Maybe Text
+    getPackageVersion name version = 
+      if "catalog" `Text.isPrefixOf` version
+        then do
+          defaultCatalog <- Map.lookup "default" (catalogs lockFile)
+          entry <- Map.lookup name (catalogEntries defaultCatalog)
+          Just $ catalogVersion entry
+        else Just version
+
+    toDependency :: Text -> Maybe Text -> PackageData -> Bool -> Dependency
+    toDependency name maybeVersion (PackageData isDev _ (RegistryResolve _) _ _) isImporterDevDep =
+      toDep NodeJSType name (withoutPeerDepSuffix . withoutSymConstraint <$> (maybeVersion >>= getPackageVersion name)) (isDev || isImporterDevDep)
+    toDependency _ _ (PackageData isDev _ (GitResolve (GitResolution url rev)) _ _) isImporterDevDep =
+      toDep GitType url (Just rev) (isDev || isImporterDevDep)
+    toDependency _ _ (PackageData isDev _ (TarballResolve (TarballResolution url)) _ _) isImporterDevDep =
+      toDep URLType url Nothing (isDev || isImporterDevDep)
+    toDependency _ _ (PackageData isDev (Just name) (DirectoryResolve _) _ _) isImporterDevDep =
+      toDep UserType name Nothing (isDev || isImporterDevDep)
+    toDependency name _ (PackageData isDev Nothing (DirectoryResolve _) _ _) isImporterDevDep =
+      toDep UserType name Nothing (isDev || isImporterDevDep)
 
     -- Sometimes package versions include symlinked paths
     -- of sibling dependencies used for resolution.
@@ -413,6 +468,15 @@
     withoutPeerDepSuffix :: Text -> Text
     withoutPeerDepSuffix version = fst $ Text.breakOn "(" version
 
+    -- | Normalize version string by handling catalog references
+    -- >> normalizeVersion "workspace:*" = "*"
+    -- >> normalizeVersion "workspace:^1.0.0" = "1.0.0"
+    -- >> normalizeVersion "1.0.0" = "1.0.0"
+    normalizeVersion :: Text -> Text
+    normalizeVersion version
+      | "workspace:" `Text.isPrefixOf` version = Text.dropWhile (/= '*') $ Text.drop 10 version
+      | otherwise = version
+
     toDep :: DepType -> Text -> Maybe Text -> Bool -> Dependency
     toDep depType name version isDev = Dependency depType name (CEq <$> version) mempty (toEnv isDev) mempty