From b9366073598174fdd96943d62d98baf7a92e6d3a Mon Sep 17 00:00:00 2001 From: Christopher Sasarak Date: Tue, 19 May 2026 11:02:47 -0500 Subject: [PATCH 01/14] Update makefile --- Makefile | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/Makefile b/Makefile index 9e63a0a20..af8781fbe 100644 --- a/Makefile +++ b/Makefile @@ -9,6 +9,7 @@ MOUNTED_DEV_TOOLS_OPTS := --rm MOUNTED_DEV_TOOLS_OPTS += --mount "type=bind,source=${current_dir},target=/fossa-cli" MOUNTED_DEV_TOOLS_OPTS += --workdir "/fossa-cli" MOUNTED_DEV_TOOLS := ${MOUNTED_DEV_TOOLS_OPTS} ${DEV_TOOLS} +CONTAINER_CMD ?= docker SHELL := bash build-cli: build-cargo @@ -160,29 +161,29 @@ check-links: # Run the formatter from within a docker image, with the project mounted as a volume fmt-ci: - docker pull ${DEV_TOOLS} - docker run ${MOUNTED_DEV_TOOLS} make fmt-haskell + @${CONTAINER_CMD} pull ${DEV_TOOLS} + @${CONTAINER_CMD} run ${MOUNTED_DEV_TOOLS} make fmt-haskell # Run the fast-lint target with the CI docker container fast-lint-ci: - docker pull ${DEV_TOOLS} - docker run ${MOUNTED_DEV_TOOLS} make fast-lint-haskell + @${CONTAINER_CMD} pull ${DEV_TOOLS} + @${CONTAINER_CMD} run ${MOUNTED_DEV_TOOLS} make fast-lint-haskell # Docker doesn't always check for new versions during build, so pulling ensures # that we always have the latest. check-ci: - docker pull ${DEV_TOOLS} - docker run ${MOUNTED_DEV_TOOLS} make check-haskell + @${CONTAINER_CMD} pull ${DEV_TOOLS} + @${CONTAINER_CMD} run ${MOUNTED_DEV_TOOLS} make check-haskell # Run the fast-check target with the CI docker container fast-check-ci: - docker pull ${DEV_TOOLS} - docker run ${MOUNTED_DEV_TOOLS} make fast-check + @${CONTAINER_CMD} pull ${DEV_TOOLS} + @${CONTAINER_CMD} run ${MOUNTED_DEV_TOOLS} make fast-check # Run bash in the CI edocker container. Useful for debugging make with CI tools. ci-shell: - docker pull ${DEV_TOOLS} - docker run -it ${MOUNTED_DEV_TOOLS} bash + @${CONTAINER_CMD} pull ${DEV_TOOLS} + @${CONTAINER_CMD} run -it ${MOUNTED_DEV_TOOLS} bash # Runs benchmarks bench: From 468c2244e9786a4950680bc3e4a2e06a0fac4ae1 Mon Sep 17 00:00:00 2001 From: Christopher Sasarak Date: Tue, 19 May 2026 16:29:22 -0500 Subject: [PATCH 02/14] refactor: restructure PnpmLock.hs with per-version builders and shared helpers - Extract per-version graph builders (buildGraphV4or5, buildGraphV678, buildGraphV9) - Replace Bool useLabels with LabelingMode sum type - Share getPkgNameVersionV6/V9 via parseAtKey - Extract buildGraphPreV9 to eliminate duplicate bodies - Lift shared helpers to top level (toDependency, toDep, applyLabels, etc.) - Fix context string 'Npm Lockfile' -> 'Pnpm Lockfile' - Remove unused Control.Monad (when) import --- TODO.md | 43 +++ src/Strategy/Node/Pnpm/PnpmLock.hs | 478 +++++++++++++++++------------ 2 files changed, 318 insertions(+), 203 deletions(-) create mode 100644 TODO.md diff --git a/TODO.md b/TODO.md new file mode 100644 index 000000000..532981750 --- /dev/null +++ b/TODO.md @@ -0,0 +1,43 @@ +# TODO + +## Goal +Refactor `PnpmLock.hs` so each lockfile version (v4/v5, v6/v7/v8, v9) has its own discrete graph builder, with version dispatch only at the top level of `buildGraph`. + +## Tasks + +### 1. Lift shared helpers out of `buildGraph` where-clause +- [x] Move `toDependency`, `toDep`, `withoutSymConstraint`, `withoutPeerDepSuffix`, `applyLabels`, `withoutLocalPackages`, `PnpmLabel` to top-level definitions. + +### 2. Create version-specific helper functions at top level +- [x] Promote `getPkgNameVersionV5`, `getPkgNameVersionV6`, `getPkgNameVersionV9` to top-level. +- [x] Create `mkPkgKeyV5`, `mkPkgKeyV6`, `mkPkgKeyV9` as top-level functions. +- [x] Create `toResolvedDependency` as a top-level function parameterized by the package map, key-maker, and `toEnv` callback. + +### 3. Factor shared graph-building loop +- [x] Extract the common loop body into `buildGraphCore` that takes callbacks for version-specific behavior (key parsing, key making, env resolution, label usage, snapshot edges). + +### 4. Create per-version `buildGraph` entry points +- [x] `buildGraphV4or5` — `getPkgNameVersionV5`, `mkPkgKeyV5`, `toEnvInline`, no labels. +- [x] `buildGraphV678` — `getPkgNameVersionV6`, `mkPkgKeyV6`, `toEnvInline`, no labels. +- [x] `buildGraphV9` — `getPkgNameVersionV9`, `mkPkgKeyV9`, `toEnvEmpty`, labels enabled, snapshot edges. + +### 5. Top-level dispatch in `buildGraph` +- [x] Simple `case lockFileVersion of` delegating to the three builders above. + +### 6. Clean up and verify +- [x] Remove `isV9` local, `getPkgNameVersion` dispatcher, `mkPkgKey` dispatcher, `toEnv` version-check, and `when isV9` guards. +- [x] `cabal build` — clean, zero warnings. +- [x] `cabal test unit-tests` — 1374 examples, 0 failures. + +### 7. Follow-up refinements +- [x] Replace `Bool useLabels` with `LabelingMode` sum type (`LabelingOff`/`LabelingOn`). +- [x] Share `getPkgNameVersionV6`/`V9` via common `parseAtKey :: Bool -> Text -> Maybe (Text, Text)`. +- [x] Extract `buildGraphPreV9` to eliminate duplicate `buildGraphV4or5`/`V678` bodies. +- [x] Fix context string "Npm Lockfile" → "Pnpm Lockfile". +- [x] Remove unused `Control.Monad (when)` import. +- [x] `cabal test unit-tests` — 1374 examples, 0 failures. + +## Notes +- The `PnpmLockfile` data type and its `FromJSON` instance stay as-is — the refactor targets graph construction only. +- `ProjectMapDepMetadata` parser handles both v5/v6 formats via `Yaml.Value` pattern matching — acceptable as a leaf parser. +- `resolveCatalogVersion` was already top-level and shared — no change needed. diff --git a/src/Strategy/Node/Pnpm/PnpmLock.hs b/src/Strategy/Node/Pnpm/PnpmLock.hs index 7a98380da..8a53d1d9a 100644 --- a/src/Strategy/Node/Pnpm/PnpmLock.hs +++ b/src/Strategy/Node/Pnpm/PnpmLock.hs @@ -10,7 +10,6 @@ where import Control.Applicative ((<|>)) import Control.Effect.Diagnostics (Diagnostics, Has, context) -import Control.Monad (when) import Data.Aeson (FromJSON (..), withObject) import Data.Aeson.Extra (TextLike (..)) import Data.Aeson.KeyMap (toHashMapText) @@ -45,6 +44,9 @@ import Graphing (Graphing) import Graphing qualified import Path (Abs, File, Path) +-- | Label attached to direct dependencies so that hydrateDepEnvs can +-- propagate environments to transitive successors. Used only for v9 +-- lockfiles where the @dev@ field on packages is unreliable. newtype PnpmLabel = PnpmEnv DepEnvironment deriving (Eq, Ord) @@ -329,8 +331,279 @@ instance FromJSON Resolution where gitRes :: Object -> Parser Resolution gitRes obj = GitResolve <$> (GitResolution <$> obj .: "repo" <*> obj .: "commit") +-- +-- Shared helpers (version-independent) +-- + +-- | Convert a resolved package into a 'Dependency' node. +toDependency :: (Bool -> Set.Set DepEnvironment) + -> Text -> Maybe Text -> PackageData -> Dependency +toDependency toEnv name maybeVersion (PackageData isDev _ (RegistryResolve _) _ _) = + toDep toEnv NodeJSType name (withoutPeerDepSuffix . withoutSymConstraint <$> maybeVersion) isDev +toDependency toEnv _ _ (PackageData isDev _ (GitResolve (GitResolution url rev)) _ _) = + toDep toEnv GitType url (Just rev) isDev +toDependency toEnv _ _ (PackageData isDev _ (TarballResolve (TarballResolution url)) _ _) = + toDep toEnv URLType url Nothing isDev +toDependency toEnv _ _ (PackageData isDev (Just name) (DirectoryResolve _) _ _) = + toDep toEnv UserType name Nothing isDev +toDependency toEnv name _ (PackageData isDev Nothing (DirectoryResolve _) _ _) = + toDep toEnv UserType name Nothing isDev + +-- | Construct a 'Dependency' from its components. +toDep :: (Bool -> Set.Set DepEnvironment) + -> DepType -> Text -> Maybe Text -> Bool -> Dependency +toDep toEnv depType name version isDev = + Dependency depType name (CEq <$> version) mempty (toEnv isDev) mempty + +-- | Sometimes package versions include symlinked paths +-- of sibling dependencies used for resolution. +-- +-- >> withoutSymConstraint "1.2.0" = "1.2.0" +-- >> withoutSymConstraint "1.2.0_vue@3.0" = "1.2.0" +withoutSymConstraint :: Text -> Text +withoutSymConstraint version = fst $ Text.breakOn "_" version + +-- | Apply accumulated labels to transform a graph node. +applyLabels :: Dependency -> Set.Set PnpmLabel -> Dependency +applyLabels = foldr applyLabel + where + applyLabel (PnpmEnv env) = insertEnvironment env + +-- | Strip local (file:) packages from the final graph. +withoutLocalPackages :: Graphing Dependency -> Graphing Dependency +withoutLocalPackages = Graphing.shrink (\dep -> dependencyType dep /= UserType) + +-- +-- Version-specific key parsers +-- + +-- | Parse a v5-style key: @\/name\/version@ (slash required). +-- +-- >> getPkgNameVersionV5 "" = Nothing +-- >> getPkgNameVersionV5 "/pkg-a/1.0.0" = Just ("pkg-a", "1.0.0") +getPkgNameVersionV5 :: Text -> Maybe (Text, Text) +getPkgNameVersionV5 pkgKey = case Text.stripPrefix "/" pkgKey of + Nothing -> Nothing + Just txt -> do + let (nameWithSlash, version) = Text.breakOnEnd "/" txt + case (Text.stripSuffix "/" nameWithSlash, version) of + (Just name, v) -> Just (name, v) + _ -> Nothing + +-- | Parse an @-style key (v6+). When @slashRequired@ is 'True', the key +-- must start with @/@ (v6/v7/v8). When 'False', the slash is optional (v9). +parseAtKey :: Bool -> Text -> Maybe (Text, Text) +parseAtKey slashRequired pkgKey = + case Text.stripPrefix "/" pkgKey of + Nothing | slashRequired -> Nothing + Nothing -> Just pkgKey + Just txt -> Just txt + >>= \txt -> do + let (nameAndVersion, peerDepInfo) = Text.breakOn "(" txt + let (nameWithSlash, version) = Text.breakOnEnd "@" nameAndVersion + case (Text.stripSuffix "@" nameWithSlash, version) of + (Just name, v) -> Just (name, v <> peerDepInfo) + _ -> Nothing + +-- | Parse a v6/v7/v8-style key: @\/name@version@ (slash required). +-- +-- >> getPkgNameVersionV6 "" = Nothing +-- >> getPkgNameVersionV6 "/pkg-a@1.0.0" = Just ("pkg-a", "1.0.0") +-- >> getPkgNameVersionV6 "/@angular/core@1.0.0(babel@1.0.0)" = Just ("@angular/core", "1.0.0(babel@1.0.0)") +getPkgNameVersionV6 :: Text -> Maybe (Text, Text) +getPkgNameVersionV6 = parseAtKey True + +-- | Parse a v9-style key: @name@version@ (slash optional). +-- +-- >> getPkgNameVersionV9 "@angular/core@1.0.0(babel@1.0.0)" = Just ("@angular/core", "1.0.0(babel@1.0.0)") +getPkgNameVersionV9 :: Text -> Maybe (Text, Text) +getPkgNameVersionV9 = parseAtKey False + +-- | Build a registry package key for v5 format: @\/name\/version@ +mkPkgKeyV5 :: Text -> Text -> Text +mkPkgKeyV5 name version = "/" <> name <> "/" <> version + +-- | Build a registry package key for v6/v7/v8 format: @\/name@version@ +mkPkgKeyV6 :: Text -> Text -> Text +mkPkgKeyV6 name version = "/" <> name <> "@" <> version + +-- | Build a registry package key for v9 format: @name@version@ (no leading slash) +mkPkgKeyV9 :: Text -> Text -> Text +mkPkgKeyV9 name version = name <> "@" <> version + +-- +-- Version-specific environment resolvers +-- + +-- | For v4/v5/v6/v7/v8: derive environment directly from @dev@ field. +toEnvInline :: Bool -> Set.Set DepEnvironment +toEnvInline isDev = Set.singleton (if isDev then EnvDevelopment else EnvProduction) + +-- | For v9: start with empty environments; labels set them later. +toEnvEmpty :: Bool -> Set.Set DepEnvironment +toEnvEmpty _ = mempty + +-- +-- Resolved dependency lookup +-- + +-- | Resolve a dependency name and version to a 'Dependency' by looking it up +-- in the packages map. +-- +-- Non-registry resolvers (tarball, git, directory) use the version value +-- directly as the @packages@ key. Registry resolvers use a constructed key. +toResolvedDependency + :: (Bool -> Set.Set DepEnvironment) -- ^ toEnv for this version + -> Map Text PackageData + -> (Text -> Text -> Text) -- ^ mkPkgKey for this version + -> Text -- ^ dependency name + -> Text -- ^ dependency version + -> Maybe Dependency +toResolvedDependency toEnv pkgs mkPkg depName depVersion = do + -- Some versions of the lockfile remove the peer dep suffix. + -- Others do not which is why it tries both. + let strippedVersion = withoutPeerDepSuffix depVersion + let maybeNonRegistrySrcPackage = + Map.lookup strippedVersion pkgs + <|> Map.lookup depVersion pkgs + let maybeRegistrySrcPackage = + fmap (strippedVersion,) (Map.lookup (mkPkg depName strippedVersion) pkgs) + <|> fmap (depVersion,) (Map.lookup (mkPkg depName depVersion) pkgs) + case (maybeNonRegistrySrcPackage, maybeRegistrySrcPackage) of + (Nothing, Nothing) -> Nothing + (Just nonRegistryPkg, _) -> + Just $ toDependency toEnv depName Nothing nonRegistryPkg + (Nothing, Just (version, registryPkg)) -> + Just $ toDependency toEnv depName (Just version) registryPkg + +-- +-- Shared graph-building loop +-- + +-- | Whether to label direct dependencies so that 'hydrateDepEnvs' +-- propagates environments through the graph. +-- +-- V9 lockfiles start with empty environments and rely on label +-- propagation. Older versions set environments inline from the @dev@ field. +data LabelingMode = LabelingOff | LabelingOn + deriving (Show, Eq, Ord) + +-- | Core graph-building logic shared across all lockfile versions. +-- +-- Parameters control version-specific behavior: +-- +-- - 'getPkgNameVersion': parse (name, version) from a package key +-- - 'mkPkgKey': build a registry package key from (name, version) +-- - 'toEnv': derive environment from @dev@ field (or ignore it for v9) +-- - 'LabelingMode': whether to label direct deps for hydrateDepEnvs propagation +-- - 'snapshotEdges': additional edges from v9 snapshots (empty for older versions) +buildGraphCore + :: (Text -> Maybe (Text, Text)) -- ^ getPkgNameVersion + -> (Text -> Text -> Text) -- ^ mkPkgKey + -> (Bool -> Set.Set DepEnvironment) -- ^ toEnv + -> LabelingMode -- ^ labeling mode + -> [(SnapshotDepName, [(SnapshotDepName, SnapShotDepRev)])] -- ^ snapshotEdges + -> PnpmLockfile + -> Graphing Dependency +buildGraphCore getPkgNameVersion mkPkgKey toEnv labelingMode snapshotEdges lockFile = + withoutLocalPackages . hydrateDepEnvs $ + run . withLabeling applyLabels $ do + -- Direct dependencies from each importer (workspace package). + for_ (toList lockFile.importers) $ \(_, projectImporters) -> do + for_ (Map.toList $ directDependencies projectImporters) $ \(depName, ProjectMapDepMetadata depVersion) -> + let resolvedVersion = resolveCatalogVersion lockFile.lockFileCatalogs depName depVersion + in for_ (toResolvedDependency toEnv pkgs mkPkgKey depName resolvedVersion) $ \dep -> do + direct dep + case labelingMode of + LabelingOn -> label dep (PnpmEnv EnvProduction) + LabelingOff -> pure () + + for_ (Map.toList $ directDevDependencies projectImporters) $ \(depName, ProjectMapDepMetadata depVersion) -> + let resolvedVersion = resolveCatalogVersion lockFile.lockFileCatalogs depName depVersion + in for_ (toResolvedDependency toEnv pkgs mkPkgKey depName resolvedVersion) $ \dep -> do + direct dep + case labelingMode of + LabelingOn -> label dep (PnpmEnv EnvDevelopment) + LabelingOff -> pure () + + -- Deep dependencies and edges from the packages section. + for_ (toList pkgs) $ \(pkgKey, pkgMeta) -> do + let deepDependencies = + Map.toList (dependencies pkgMeta) + <> Map.toList (peerDependencies pkgMeta) + <> fromMaybe mempty (HashMap.lookup pkgKey snapshotEdgesHM) + + let (depName, depVersion) = case getPkgNameVersion pkgKey of + Nothing -> (pkgKey, Nothing) + Just (name, version) -> (name, Just version) + let parentDep = toDependency toEnv depName depVersion pkgMeta + + -- 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 toEnv pkgs mkPkgKey deepName deepVersion) + where + pkgs = packages lockFile + snapshotEdgesHM = HashMap.fromList snapshotEdges + +-- +-- Per-version graph builders +-- + +-- | Shared builder for v4 through v8: environment from @dev@ field, +-- no label propagation, no snapshot edges. +buildGraphPreV9 + :: (Text -> Maybe (Text, Text)) -- ^ getPkgNameVersion + -> (Text -> Text -> Text) -- ^ mkPkgKey + -> PnpmLockfile + -> Graphing Dependency +buildGraphPreV9 getPkgNameVersion mkPkgKey = + buildGraphCore getPkgNameVersion mkPkgKey toEnvInline LabelingOff mempty + +-- | Build graph for lockfile v4/v5. +-- +-- v5 uses @\/name\/version@ keys and derives environment from @dev@ field. +buildGraphV4or5 :: PnpmLockfile -> Graphing Dependency +buildGraphV4or5 = buildGraphPreV9 getPkgNameVersionV5 mkPkgKeyV5 + +-- | Build graph for lockfile v6/v7/v8. +-- +-- v6+ uses @\/name@version@ keys and derives environment from @dev@ field. +buildGraphV678 :: PnpmLockfile -> Graphing Dependency +buildGraphV678 = buildGraphPreV9 getPkgNameVersionV6 mkPkgKeyV6 + +-- | Build graph for lockfile v9. +-- +-- v9 uses @name@version@ keys (no leading slash), derives environment via +-- label propagation, and uses snapshots for transitive dependency edges. +buildGraphV9 :: PnpmLockfile -> Graphing Dependency +buildGraphV9 lockFile = + buildGraphCore + getPkgNameVersionV9 + mkPkgKeyV9 + toEnvEmpty + LabelingOn + (HashMap.toList lockFile.lockFileSnapshots.snapshots) + lockFile + +-- +-- Top-level dispatch +-- + +-- | Build the dependency graph, labeling direct deps with their environment +-- (prod\/dev). hydrateDepEnvs then propagates those environments to all +-- transitive successors. +buildGraph :: PnpmLockfile -> Graphing Dependency +buildGraph lockFile = case lockFileVersion lockFile of + PnpmLockLt4 _ -> buildGraphV4or5 lockFile + PnpmLock4Or5 -> buildGraphV4or5 lockFile + PnpmLockV678 _ -> buildGraphV678 lockFile + PnpmLockV9 -> buildGraphV9 lockFile + 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 +analyze file = context "Analyzing Pnpm Lockfile" $ do pnpmLockFile <- context "Parsing pnpm-lock file" $ readContentsYaml file case lockFileVersion pnpmLockFile of @@ -339,207 +612,6 @@ analyze file = context "Analyzing Npm Lockfile (v3)" $ do context "Building dependency graph" $ pure $ buildGraph pnpmLockFile --- Build the dependency graph, labeling direct deps with their environment --- (prod/dev). hydrateDepEnvs then propagates those environments to all --- transitive successors. -buildGraph :: PnpmLockfile -> Graphing Dependency -buildGraph lockFile = withoutLocalPackages . hydrateDepEnvs $ - run . withLabeling applyLabels $ do - for_ (toList lockFile.importers) $ \(_, projectImporters) -> do - for_ (Map.toList $ directDependencies projectImporters) $ \(depName, ProjectMapDepMetadata depVersion) -> - let resolvedVersion = resolveCatalogVersion lockFile.lockFileCatalogs depName depVersion - in for_ (toResolvedDependency depName resolvedVersion) $ \dep -> do - direct dep - when isV9 $ label dep (PnpmEnv EnvProduction) - - for_ (Map.toList $ directDevDependencies projectImporters) $ \(depName, ProjectMapDepMetadata depVersion) -> - let resolvedVersion = resolveCatalogVersion lockFile.lockFileCatalogs depName depVersion - in for_ (toResolvedDependency depName resolvedVersion) $ \dep -> do - direct dep - when isV9 $ label dep (PnpmEnv EnvDevelopment) - - -- Add edges and deep dependencies by iterating over all packages. - -- - -- Use `dev` to infer if this is production or non-production dependency. - -- Use `dependencies` to infer the edge from this dependency (aws-sdk@2.1148.0) - -- to its children. If the child entry cannot be found in `packages`, - -- do not provision an edge. - -- - -- @ - -- > packages: - -- > - -- > /aws-sdk/2.1148.0: - -- > resolution: {integrity: sha512-FUYAyveKmS5eq..==} - -- > engines: {node: '>= 10.0.0'} - -- > dependencies: - -- > buffer: 4.9.2 - -- > events: 1.1.1 - -- > dev: false - -- @ - for_ (toList lockFile.packages) $ \(pkgKey, pkgMeta) -> do - let deepDependencies = - Map.toList (dependencies pkgMeta) - <> Map.toList (peerDependencies pkgMeta) - <> fromMaybe mempty (HashMap.lookup pkgKey lockFile.lockFileSnapshots.snapshots) - - let (depName, depVersion) = case getPkgNameVersion pkgKey of - Nothing -> (pkgKey, Nothing) - Just (name, version) -> (name, Just version) - let parentDep = toDependency depName depVersion pkgMeta - - -- 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) - where - getPkgNameVersion :: Text -> Maybe (Text, Text) - getPkgNameVersion = case lockFileVersion lockFile of - PnpmLock4Or5 -> getPkgNameVersionV5 - PnpmLockLt4 _ -> getPkgNameVersionV5 -- v3 or below are deprecated and are not used in practice, fallback to closest - PnpmLockV678 _ -> getPkgNameVersionV6 -- at the time of writing there is no v7, so default to closest - PnpmLockV9 -> getPkgNameVersionV9 - - -- Gets package name and version from package's key. - -- - -- >> getPkgNameVersionV6 "" = Nothing - -- >> getPkgNameVersionV6 "github.com/something" = Nothing - -- >> getPkgNameVersionV6 "/pkg-a@1.0.0" = Just ("pkg-a", "1.0.0") - -- >> getPkgNameVersionV6 "/@angular/core@1.0.0" = Just ("@angular/core", "1.0.0") - -- >> getPkgNameVersionV6 "/@angular/core@1.0.0(babel@1.0.0)" = Just ("@angular/core", "1.0.0(babel@1.0.0)") - getPkgNameVersionV6 :: Text -> Maybe (Text, Text) - getPkgNameVersionV6 pkgKey = case (Text.stripPrefix "/" pkgKey) of - Nothing -> Nothing - Just txt -> do - let (nameAndVersion, peerDepInfo) = Text.breakOn "(" txt - let (nameWithSlash, version) = Text.breakOnEnd "@" nameAndVersion - 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. - -- - -- >> getPkgNameVersionV9 "@angular/core@1.0.0(babel@1.0.0) = Just ("@angular/core", "1.0.0(babel@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. - -- - -- >> getPkgNameVersionV5 "" = Nothing - -- >> getPkgNameVersionV5 "github.com/something" = Nothing - -- >> getPkgNameVersionV5 "/pkg-a/1.0.0" = Just ("pkg-a", "1.0.0") - -- >> getPkgNameVersionV5 "/@angular/core/1.0.0" = Just ("@angular/core", "1.0.0") - getPkgNameVersionV5 :: Text -> Maybe (Text, Text) - getPkgNameVersionV5 pkgKey = case (Text.stripPrefix "/" pkgKey) of - Nothing -> Nothing - Just txt -> do - let (nameWithSlash, version) = Text.breakOnEnd "/" txt - case (Text.stripSuffix "/" nameWithSlash, version) of - (Just name, v) -> Just (name, v) - _ -> Nothing - - -- Non-registry resolvers (tarball, git, directory) use non-version identifier - -- as version value in dependencies map, as well as for it's `packages` key. - -- - -- @ - -- > dependencies: - -- > chokidar: 1.0.0 # resolved with registry - -- > some-other-project: file:../local-package # resolved with non-registry resolver - -- @ - -- - - -- For any dependency resolved via registry resolver, it will use - -- the following format for its `packages` key: - -- - -- - /${depName}/${depVersion} -- for v5 fmt - -- - /${depName}@${depVersion} -- for v6 fmt - -- - -- For dependency resolved via non-registry resolvers, - -- it will use the dependency's version value for its `packages` key: - -- - -- e.g. - -- file:../local-package - -- - toResolvedDependency :: Text -> Text -> Maybe Dependency - toResolvedDependency depName depVersion = do - -- Some versions of the lockfile remove the peer dep suffix. - -- Others do not which is why it tries both. - let strippedVersion = withoutPeerDepSuffix depVersion - let maybeNonRegistrySrcPackage = - Map.lookup strippedVersion (packages lockFile) - <|> Map.lookup depVersion (packages lockFile) - let maybeRegistrySrcPackage = - fmap (strippedVersion,) (Map.lookup (mkPkgKey depName strippedVersion) (packages lockFile)) - <|> fmap (depVersion,) (Map.lookup (mkPkgKey depName depVersion) (packages lockFile)) - case (maybeNonRegistrySrcPackage, maybeRegistrySrcPackage) of - (Nothing, Nothing) -> Nothing - (Just nonRegistryPkg, _) -> Just $ toDependency depName Nothing nonRegistryPkg - (Nothing, Just (version, registryPkg)) -> Just $ toDependency depName (Just version) registryPkg - - -- 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 :: Text -> Text -> Text - mkPkgKey name version = case lockFileVersion lockFile of - PnpmLock4Or5 -> "/" <> name <> "/" <> version - -- 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 - PnpmLockV678 _ -> "/" <> name <> "@" <> version - PnpmLockV9 -> 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 - - -- Sometimes package versions include symlinked paths - -- of sibling dependencies used for resolution. - -- - -- >> withoutSymConstraint "1.2.0" = "1.2.0" - -- >> withoutSymConstraint "1.2.0_vue@3.0" = "1.2.0" - withoutSymConstraint :: Text -> Text - withoutSymConstraint version = fst $ Text.breakOn "_" version - - toDep :: DepType -> Text -> Maybe Text -> Bool -> Dependency - toDep depType name version isDev = Dependency depType name (CEq <$> version) mempty (toEnv isDev) mempty - - -- For v9, environments start empty and are set later via labels - -- during graph construction, then propagated by hydrateDepEnvs. - -- For older versions, isDev from PackageData is reliable and - -- environments are set inline. - toEnv :: Bool -> Set.Set DepEnvironment - toEnv isNotRequired = - if isV9 - then mempty - else Set.singleton (if isNotRequired then EnvDevelopment else EnvProduction) - - isV9 :: Bool - isV9 = lockFile.lockFileVersion == PnpmLockV9 - - applyLabels :: Dependency -> Set.Set PnpmLabel -> Dependency - applyLabels = foldr applyLabel - where - applyLabel (PnpmEnv env) = insertEnvironment env - - withoutLocalPackages :: Graphing Dependency -> Graphing Dependency - withoutLocalPackages = Graphing.shrink (\dep -> dependencyType dep /= UserType) - -- Sometimes package versions include resolved peer dependency version -- in parentheses. This is used by pnpm for dependency resolution, we do -- not care about them, as they do not represent package version. From ee1e13e634b8b074fc58cb264d346fa939ecefcd Mon Sep 17 00:00:00 2001 From: Christopher Sasarak Date: Tue, 19 May 2026 17:12:18 -0500 Subject: [PATCH 03/14] chore: stop tracking TODO.md in git --- TODO.md | 43 ----------------- src/Strategy/Node/Pnpm/PnpmLock.hs | 74 +++++++++++++++++------------- 2 files changed, 41 insertions(+), 76 deletions(-) delete mode 100644 TODO.md diff --git a/TODO.md b/TODO.md deleted file mode 100644 index 532981750..000000000 --- a/TODO.md +++ /dev/null @@ -1,43 +0,0 @@ -# TODO - -## Goal -Refactor `PnpmLock.hs` so each lockfile version (v4/v5, v6/v7/v8, v9) has its own discrete graph builder, with version dispatch only at the top level of `buildGraph`. - -## Tasks - -### 1. Lift shared helpers out of `buildGraph` where-clause -- [x] Move `toDependency`, `toDep`, `withoutSymConstraint`, `withoutPeerDepSuffix`, `applyLabels`, `withoutLocalPackages`, `PnpmLabel` to top-level definitions. - -### 2. Create version-specific helper functions at top level -- [x] Promote `getPkgNameVersionV5`, `getPkgNameVersionV6`, `getPkgNameVersionV9` to top-level. -- [x] Create `mkPkgKeyV5`, `mkPkgKeyV6`, `mkPkgKeyV9` as top-level functions. -- [x] Create `toResolvedDependency` as a top-level function parameterized by the package map, key-maker, and `toEnv` callback. - -### 3. Factor shared graph-building loop -- [x] Extract the common loop body into `buildGraphCore` that takes callbacks for version-specific behavior (key parsing, key making, env resolution, label usage, snapshot edges). - -### 4. Create per-version `buildGraph` entry points -- [x] `buildGraphV4or5` — `getPkgNameVersionV5`, `mkPkgKeyV5`, `toEnvInline`, no labels. -- [x] `buildGraphV678` — `getPkgNameVersionV6`, `mkPkgKeyV6`, `toEnvInline`, no labels. -- [x] `buildGraphV9` — `getPkgNameVersionV9`, `mkPkgKeyV9`, `toEnvEmpty`, labels enabled, snapshot edges. - -### 5. Top-level dispatch in `buildGraph` -- [x] Simple `case lockFileVersion of` delegating to the three builders above. - -### 6. Clean up and verify -- [x] Remove `isV9` local, `getPkgNameVersion` dispatcher, `mkPkgKey` dispatcher, `toEnv` version-check, and `when isV9` guards. -- [x] `cabal build` — clean, zero warnings. -- [x] `cabal test unit-tests` — 1374 examples, 0 failures. - -### 7. Follow-up refinements -- [x] Replace `Bool useLabels` with `LabelingMode` sum type (`LabelingOff`/`LabelingOn`). -- [x] Share `getPkgNameVersionV6`/`V9` via common `parseAtKey :: Bool -> Text -> Maybe (Text, Text)`. -- [x] Extract `buildGraphPreV9` to eliminate duplicate `buildGraphV4or5`/`V678` bodies. -- [x] Fix context string "Npm Lockfile" → "Pnpm Lockfile". -- [x] Remove unused `Control.Monad (when)` import. -- [x] `cabal test unit-tests` — 1374 examples, 0 failures. - -## Notes -- The `PnpmLockfile` data type and its `FromJSON` instance stay as-is — the refactor targets graph construction only. -- `ProjectMapDepMetadata` parser handles both v5/v6 formats via `Yaml.Value` pattern matching — acceptable as a leaf parser. -- `resolveCatalogVersion` was already top-level and shared — no change needed. diff --git a/src/Strategy/Node/Pnpm/PnpmLock.hs b/src/Strategy/Node/Pnpm/PnpmLock.hs index 8a53d1d9a..7dd4e0843 100644 --- a/src/Strategy/Node/Pnpm/PnpmLock.hs +++ b/src/Strategy/Node/Pnpm/PnpmLock.hs @@ -488,41 +488,43 @@ toResolvedDependency toEnv pkgs mkPkg depName depVersion = do data LabelingMode = LabelingOff | LabelingOn deriving (Show, Eq, Ord) +-- | Configuration for 'buildGraphCore'. +-- +-- Each field controls version-specific behavior: +-- +-- - 'bgcGetPkgNameVersion': parse (name, version) from a package key +-- - 'bgcMkPkgKey': build a registry package key from (name, version) +-- - 'bgcToEnv': derive environment from @dev@ field (or ignore it for v9) +-- - 'bgcLabelingMode': whether to label direct deps for hydrateDepEnvs propagation +-- - 'bgcSnapshotEdges': additional edges from v9 snapshots (empty for older versions) +data BuildGraphConfig = BuildGraphConfig + { bgcGetPkgNameVersion :: Text -> Maybe (Text, Text) + , bgcMkPkgKey :: Text -> Text -> Text + , bgcToEnv :: Bool -> Set.Set DepEnvironment + , bgcLabelingMode :: LabelingMode + , bgcSnapshotEdges :: [(SnapshotDepName, [(SnapshotDepName, SnapShotDepRev)])] + } + -- | Core graph-building logic shared across all lockfile versions. --- --- Parameters control version-specific behavior: --- --- - 'getPkgNameVersion': parse (name, version) from a package key --- - 'mkPkgKey': build a registry package key from (name, version) --- - 'toEnv': derive environment from @dev@ field (or ignore it for v9) --- - 'LabelingMode': whether to label direct deps for hydrateDepEnvs propagation --- - 'snapshotEdges': additional edges from v9 snapshots (empty for older versions) -buildGraphCore - :: (Text -> Maybe (Text, Text)) -- ^ getPkgNameVersion - -> (Text -> Text -> Text) -- ^ mkPkgKey - -> (Bool -> Set.Set DepEnvironment) -- ^ toEnv - -> LabelingMode -- ^ labeling mode - -> [(SnapshotDepName, [(SnapshotDepName, SnapShotDepRev)])] -- ^ snapshotEdges - -> PnpmLockfile - -> Graphing Dependency -buildGraphCore getPkgNameVersion mkPkgKey toEnv labelingMode snapshotEdges lockFile = +buildGraphCore :: BuildGraphConfig -> PnpmLockfile -> Graphing Dependency +buildGraphCore cfg lockFile = withoutLocalPackages . hydrateDepEnvs $ run . withLabeling applyLabels $ do -- Direct dependencies from each importer (workspace package). for_ (toList lockFile.importers) $ \(_, projectImporters) -> do for_ (Map.toList $ directDependencies projectImporters) $ \(depName, ProjectMapDepMetadata depVersion) -> let resolvedVersion = resolveCatalogVersion lockFile.lockFileCatalogs depName depVersion - in for_ (toResolvedDependency toEnv pkgs mkPkgKey depName resolvedVersion) $ \dep -> do + in for_ (toResolvedDependency (bgcToEnv cfg) pkgs (bgcMkPkgKey cfg) depName resolvedVersion) $ \dep -> do direct dep - case labelingMode of + case bgcLabelingMode cfg of LabelingOn -> label dep (PnpmEnv EnvProduction) LabelingOff -> pure () for_ (Map.toList $ directDevDependencies projectImporters) $ \(depName, ProjectMapDepMetadata depVersion) -> let resolvedVersion = resolveCatalogVersion lockFile.lockFileCatalogs depName depVersion - in for_ (toResolvedDependency toEnv pkgs mkPkgKey depName resolvedVersion) $ \dep -> do + in for_ (toResolvedDependency (bgcToEnv cfg) pkgs (bgcMkPkgKey cfg) depName resolvedVersion) $ \dep -> do direct dep - case labelingMode of + case bgcLabelingMode cfg of LabelingOn -> label dep (PnpmEnv EnvDevelopment) LabelingOff -> pure () @@ -533,20 +535,20 @@ buildGraphCore getPkgNameVersion mkPkgKey toEnv labelingMode snapshotEdges lockF <> Map.toList (peerDependencies pkgMeta) <> fromMaybe mempty (HashMap.lookup pkgKey snapshotEdgesHM) - let (depName, depVersion) = case getPkgNameVersion pkgKey of + let (depName, depVersion) = case bgcGetPkgNameVersion cfg pkgKey of Nothing -> (pkgKey, Nothing) Just (name, version) -> (name, Just version) - let parentDep = toDependency toEnv depName depVersion pkgMeta + let parentDep = toDependency (bgcToEnv cfg) depName depVersion pkgMeta -- 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 toEnv pkgs mkPkgKey deepName deepVersion) + maybe (pure ()) (edge parentDep) (toResolvedDependency (bgcToEnv cfg) pkgs (bgcMkPkgKey cfg) deepName deepVersion) where pkgs = packages lockFile - snapshotEdgesHM = HashMap.fromList snapshotEdges + snapshotEdgesHM = HashMap.fromList (bgcSnapshotEdges cfg) -- -- Per-version graph builders @@ -560,7 +562,13 @@ buildGraphPreV9 -> PnpmLockfile -> Graphing Dependency buildGraphPreV9 getPkgNameVersion mkPkgKey = - buildGraphCore getPkgNameVersion mkPkgKey toEnvInline LabelingOff mempty + buildGraphCore (BuildGraphConfig + { bgcGetPkgNameVersion = getPkgNameVersion + , bgcMkPkgKey = mkPkgKey + , bgcToEnv = toEnvInline + , bgcLabelingMode = LabelingOff + , bgcSnapshotEdges = mempty + }) -- | Build graph for lockfile v4/v5. -- @@ -580,13 +588,13 @@ buildGraphV678 = buildGraphPreV9 getPkgNameVersionV6 mkPkgKeyV6 -- label propagation, and uses snapshots for transitive dependency edges. buildGraphV9 :: PnpmLockfile -> Graphing Dependency buildGraphV9 lockFile = - buildGraphCore - getPkgNameVersionV9 - mkPkgKeyV9 - toEnvEmpty - LabelingOn - (HashMap.toList lockFile.lockFileSnapshots.snapshots) - lockFile + buildGraphCore (BuildGraphConfig + { bgcGetPkgNameVersion = getPkgNameVersionV9 + , bgcMkPkgKey = mkPkgKeyV9 + , bgcToEnv = toEnvEmpty + , bgcLabelingMode = LabelingOn + , bgcSnapshotEdges = HashMap.toList lockFile.lockFileSnapshots.snapshots + }) lockFile -- -- Top-level dispatch From a7823329fe93105b3655423f20d59d96ceabff7f Mon Sep 17 00:00:00 2001 From: Christopher Sasarak Date: Tue, 19 May 2026 19:13:58 -0500 Subject: [PATCH 04/14] Name the buildgraph config --- src/Strategy/Node/Pnpm/PnpmLock.hs | 59 +++++++++++++++++------------- 1 file changed, 34 insertions(+), 25 deletions(-) diff --git a/src/Strategy/Node/Pnpm/PnpmLock.hs b/src/Strategy/Node/Pnpm/PnpmLock.hs index 7dd4e0843..4b878df3d 100644 --- a/src/Strategy/Node/Pnpm/PnpmLock.hs +++ b/src/Strategy/Node/Pnpm/PnpmLock.hs @@ -9,6 +9,7 @@ module Strategy.Node.Pnpm.PnpmLock ( where import Control.Applicative ((<|>)) + import Control.Effect.Diagnostics (Diagnostics, Has, context) import Data.Aeson (FromJSON (..), withObject) import Data.Aeson.Extra (TextLike (..)) @@ -554,47 +555,55 @@ buildGraphCore cfg lockFile = -- Per-version graph builders -- --- | Shared builder for v4 through v8: environment from @dev@ field, --- no label propagation, no snapshot edges. -buildGraphPreV9 - :: (Text -> Maybe (Text, Text)) -- ^ getPkgNameVersion - -> (Text -> Text -> Text) -- ^ mkPkgKey - -> PnpmLockfile - -> Graphing Dependency -buildGraphPreV9 getPkgNameVersion mkPkgKey = - buildGraphCore (BuildGraphConfig - { bgcGetPkgNameVersion = getPkgNameVersion - , bgcMkPkgKey = mkPkgKey - , bgcToEnv = toEnvInline - , bgcLabelingMode = LabelingOff - , bgcSnapshotEdges = mempty - }) +-- | Config for lockfile versions 4/5. +buildGraphConfigV4or5 :: BuildGraphConfig +buildGraphConfigV4or5 = BuildGraphConfig + { bgcGetPkgNameVersion = getPkgNameVersionV5 + , bgcMkPkgKey = mkPkgKeyV5 + , bgcToEnv = toEnvInline + , bgcLabelingMode = LabelingOff + , bgcSnapshotEdges = mempty + } + +-- | Config for lockfile versions 6/7/8. +buildGraphConfigV678 :: BuildGraphConfig +buildGraphConfigV678 = BuildGraphConfig + { bgcGetPkgNameVersion = getPkgNameVersionV6 + , bgcMkPkgKey = mkPkgKeyV6 + , bgcToEnv = toEnvInline + , bgcLabelingMode = LabelingOff + , bgcSnapshotEdges = mempty + } + +-- | Config for lockfile version 9. +-- Snapshot edges come from the lockfile itself, so this is a function. +buildGraphConfigV9 :: PnpmLockfile -> BuildGraphConfig +buildGraphConfigV9 lockFile = BuildGraphConfig + { bgcGetPkgNameVersion = getPkgNameVersionV9 + , bgcMkPkgKey = mkPkgKeyV9 + , bgcToEnv = toEnvEmpty + , bgcLabelingMode = LabelingOn + , bgcSnapshotEdges = HashMap.toList lockFile.lockFileSnapshots.snapshots + } -- | Build graph for lockfile v4/v5. -- -- v5 uses @\/name\/version@ keys and derives environment from @dev@ field. buildGraphV4or5 :: PnpmLockfile -> Graphing Dependency -buildGraphV4or5 = buildGraphPreV9 getPkgNameVersionV5 mkPkgKeyV5 +buildGraphV4or5 = buildGraphCore buildGraphConfigV4or5 -- | Build graph for lockfile v6/v7/v8. -- -- v6+ uses @\/name@version@ keys and derives environment from @dev@ field. buildGraphV678 :: PnpmLockfile -> Graphing Dependency -buildGraphV678 = buildGraphPreV9 getPkgNameVersionV6 mkPkgKeyV6 +buildGraphV678 = buildGraphCore buildGraphConfigV678 -- | Build graph for lockfile v9. -- -- v9 uses @name@version@ keys (no leading slash), derives environment via -- label propagation, and uses snapshots for transitive dependency edges. buildGraphV9 :: PnpmLockfile -> Graphing Dependency -buildGraphV9 lockFile = - buildGraphCore (BuildGraphConfig - { bgcGetPkgNameVersion = getPkgNameVersionV9 - , bgcMkPkgKey = mkPkgKeyV9 - , bgcToEnv = toEnvEmpty - , bgcLabelingMode = LabelingOn - , bgcSnapshotEdges = HashMap.toList lockFile.lockFileSnapshots.snapshots - }) lockFile +buildGraphV9 lockFile = buildGraphCore (buildGraphConfigV9 lockFile) lockFile -- -- Top-level dispatch From ba2e4a88871dfd77eb7aee26160e54b8a9c8e4ef Mon Sep 17 00:00:00 2001 From: Christopher Sasarak Date: Thu, 28 May 2026 22:50:11 -0500 Subject: [PATCH 05/14] fix: use Text.uncons instead of Text.head, add inline Haddock docs for BuildGraphConfig --- src/Strategy/Node/Pnpm/PnpmLock.hs | 214 ++++++++++++++++------------- 1 file changed, 120 insertions(+), 94 deletions(-) diff --git a/src/Strategy/Node/Pnpm/PnpmLock.hs b/src/Strategy/Node/Pnpm/PnpmLock.hs index 4b878df3d..1e3ce5613 100644 --- a/src/Strategy/Node/Pnpm/PnpmLock.hs +++ b/src/Strategy/Node/Pnpm/PnpmLock.hs @@ -19,7 +19,6 @@ import Data.HashMap.Strict qualified as HashMap import Data.Map (Map, toList) import Data.Map qualified as Map import Data.Maybe (fromMaybe, listToMaybe) -import Data.Maybe qualified as Maybe import Data.Set qualified as Set import Data.String.Conversion (toString) import Data.Text (Text) @@ -136,17 +135,41 @@ newtype PnpmLabel = PnpmEnv DepEnvironment -- - [pnpm](https://pnpm.io/) -- - [pnpm-lockfile](https://github.com/pnpm/pnpm/blob/5cfd6d01946edcce86f62580bddc788d02f93ed6/packages/lockfile-types/src/index.ts) -- - [pnpm-lockfile-v6](https://github.com/pnpm/pnpm/pull/5810/files) -data PnpmLockfile = PnpmLockfile - { importers :: Map Text ProjectMap - , packages :: Map Text PackageData - , lockFileVersion :: PnpmLockFileVersion - , lockFileSnapshots :: PnpmLockFileSnapshots - -- ^ Dependency graph in lockfile version > 9 - , lockFileCatalogs :: PnpmCatalogs - -- ^ Catalog definitions in lockfile version >= 9 +-- | Shared fields present in all lockfile versions. +data PnpmLockfileBase = PnpmLockfileBase + { lockfileImporters :: Map Text ProjectMap + , lockfilePackages :: Map Text PackageData + , lockfileRawVersion :: Text + -- ^ Raw lockfileVersion string, used for warning about unsupported versions. } deriving (Show, Eq, Ord) +-- | Version-specific extension for v4/v5 lockfiles. +newtype PnpmLockfileV4Or5 = PnpmLockfileV4Or5 PnpmLockfileBase + deriving (Show, Eq, Ord) + +-- | Version-specific extension for v6/v7/v8 lockfiles. +newtype PnpmLockfileV678 = PnpmLockfileV678 PnpmLockfileBase + deriving (Show, Eq, Ord) + +-- | Version-specific extension for v9+ lockfiles. +data PnpmLockfileV9 = PnpmLockfileV9 + { lockfileBase :: PnpmLockfileBase + , lockfileSnapshots :: PnpmLockFileSnapshots + , lockfileCatalogs :: PnpmCatalogs + } + deriving (Show, Eq, Ord) + +-- | Pnpm lockfile, parameterized by version. +-- +-- The type constructor encodes the version, so that each variant +-- carries only the data relevant to its format. +data PnpmLockfile + = LockfileV4Or5 PnpmLockfileV4Or5 + | LockfileV678 PnpmLockfileV678 + | LockfileV9 PnpmLockfileV9 + deriving (Show, Eq, Ord) + -- | Catalogs parsed from lockfile. Maps catalog name to (package name -> resolved version). -- See: https://pnpm.io/catalogs newtype PnpmCatalogs = PnpmCatalogs @@ -209,51 +232,68 @@ instance FromJSON PnpmLockFileSnapshots where pure $ PnpmLockFileSnapshots{snapshots = snapshots'} -data PnpmLockFileVersion - = PnpmLockLt4 Text - | PnpmLock4Or5 - | PnpmLockV678 Text - | PnpmLockV9 +-- | Internal version classifier used during JSON parsing. +data VersionClassifier + = VersionV4Or5 + | VersionV678 + | VersionV9 deriving (Show, Eq, Ord) +-- | Classify the lockfile version string. +classifyVersion :: TextLike -> Parser VersionClassifier +classifyVersion (TextLike ver) = case listToMaybe (toString ver) of + Just '1' -> pure VersionV4Or5 + Just '2' -> pure VersionV4Or5 + Just '3' -> pure VersionV4Or5 + Just '4' -> pure VersionV4Or5 + Just '5' -> pure VersionV4Or5 + Just x | x `elem` ['6', '7', '8'] -> pure VersionV678 + Just '9' -> pure VersionV9 + _ -> fail $ "expected numeric lockfileVersion, got: " <> show ver + +-- | Parse the shared base fields (importers + packages) common to all versions. +parseBaseLockfile :: TextLike -> Object -> Parser PnpmLockfileBase +parseBaseLockfile (TextLike rawVer) obj = do + -- Map pnpm non-workspace lockfile format to pnpm workspace lockfile format. + -- + -- For lockfile without workspaces, the 'importers' field is not included in + -- the lockfile. And 'dependencies' and 'devDependencies' are instead shown + -- at the root level. + -- + -- A project without a workspace is the same as having a single workspace at + -- the path of ".". + importers <- obj .:? "importers" .!= mempty + packages <- obj .:? "packages" .!= mempty + dependencies <- obj .:? "dependencies" .!= mempty + devDependencies <- obj .:? "devDependencies" .!= mempty + let virtualRootWs = ProjectMap dependencies devDependencies + let refinedImporters = + if Map.null importers + then Map.insert "." virtualRootWs importers + else importers + pure $ PnpmLockfileBase + { lockfileImporters = refinedImporters + , lockfilePackages = packages + , lockfileRawVersion = rawVer + } + instance FromJSON PnpmLockfile where parseJSON = Yaml.withObject "pnpm-lock content" $ \obj -> do - rawLockFileVersion <- getVersion =<< obj .:? "lockfileVersion" .!= (TextLike mempty) - importers <- obj .:? "importers" .!= mempty - packages <- obj .:? "packages" .!= mempty - -- PNPM 9 snapshots - snapshots <- obj .:? "snapshots" .!= mempty - -- PNPM 9 catalogs - catalogs <- obj .:? "catalogs" .!= mempty - - -- Map pnpm non-workspace lockfile format to pnpm workspace lockfile format. - -- - -- For lockfile without workspaces, the 'importers' field is not included in - -- the lockfile. And 'dependencies' and 'devDependencies' are instead shown - -- at the root level. - -- - -- A project without a workspace is the same as having a single workspace at - -- the path of ".". - - dependencies <- obj .:? "dependencies" .!= mempty - devDependencies <- obj .:? "devDependencies" .!= mempty - let virtualRootWs = ProjectMap dependencies devDependencies - let refinedImporters = - if Map.null importers - then Map.insert "." virtualRootWs importers - else importers - - pure $ PnpmLockfile{importers = refinedImporters, packages = packages, lockFileVersion = rawLockFileVersion, lockFileSnapshots = snapshots, lockFileCatalogs = catalogs} - where - getVersion (TextLike ver) = case (listToMaybe . toString $ ver) of - (Just '1') -> pure $ PnpmLockLt4 ver - (Just '2') -> pure $ PnpmLockLt4 ver - (Just '3') -> pure $ PnpmLockLt4 ver - (Just '4') -> pure PnpmLock4Or5 - (Just '5') -> pure PnpmLock4Or5 - (Just x) | x `elem` ['6', '7', '8'] -> pure $ PnpmLockV678 ver - (Just '9') -> pure PnpmLockV9 - _ -> fail ("expected numeric lockfileVersion, got: " <> show ver) + rawVer <- obj .:? "lockfileVersion" .!= (TextLike mempty) + base <- parseBaseLockfile rawVer obj + + versionClass <- classifyVersion rawVer + case versionClass of + VersionV4Or5 -> pure $ LockfileV4Or5 $ PnpmLockfileV4Or5 base + VersionV678 -> pure $ LockfileV678 $ PnpmLockfileV678 base + VersionV9 -> do + snapshots <- obj .:? "snapshots" .!= mempty + catalogs <- obj .:? "catalogs" .!= mempty + pure $ LockfileV9 $ PnpmLockfileV9 + { lockfileBase = base + , lockfileSnapshots = snapshots + , lockfileCatalogs = catalogs + } data ProjectMap = ProjectMap { directDependencies :: Map Text ProjectMapDepMetadata @@ -498,23 +538,25 @@ data LabelingMode = LabelingOff | LabelingOn -- - 'bgcToEnv': derive environment from @dev@ field (or ignore it for v9) -- - 'bgcLabelingMode': whether to label direct deps for hydrateDepEnvs propagation -- - 'bgcSnapshotEdges': additional edges from v9 snapshots (empty for older versions) +-- - 'bgcCatalogs': catalog name -> (package name -> resolved version) mappings data BuildGraphConfig = BuildGraphConfig - { bgcGetPkgNameVersion :: Text -> Maybe (Text, Text) - , bgcMkPkgKey :: Text -> Text -> Text - , bgcToEnv :: Bool -> Set.Set DepEnvironment - , bgcLabelingMode :: LabelingMode - , bgcSnapshotEdges :: [(SnapshotDepName, [(SnapshotDepName, SnapShotDepRev)])] + { bgcGetPkgNameVersion :: Text -> Maybe (Text, Text) -- ^ Parse (name, version) from a package key + , bgcMkPkgKey :: Text -> Text -> Text -- ^ Build a registry package key from (name, version) + , bgcToEnv :: Bool -> Set.Set DepEnvironment -- ^ Derive environment from @dev@ field (or ignore for v9) + , bgcLabelingMode :: LabelingMode -- ^ Whether to label direct deps for hydrateDepEnvs propagation + , bgcSnapshotEdges :: [(SnapshotDepName, [(SnapshotDepName, SnapShotDepRev)])] -- ^ Additional edges from v9 snapshots + , bgcCatalogs :: PnpmCatalogs -- ^ Catalog name -> (package name -> resolved version) mappings } -- | Core graph-building logic shared across all lockfile versions. -buildGraphCore :: BuildGraphConfig -> PnpmLockfile -> Graphing Dependency -buildGraphCore cfg lockFile = +buildGraphCore :: BuildGraphConfig -> PnpmLockfileBase -> Graphing Dependency +buildGraphCore cfg base = withoutLocalPackages . hydrateDepEnvs $ run . withLabeling applyLabels $ do -- Direct dependencies from each importer (workspace package). - for_ (toList lockFile.importers) $ \(_, projectImporters) -> do + for_ (toList (lockfileImporters base)) $ \(_, projectImporters) -> do for_ (Map.toList $ directDependencies projectImporters) $ \(depName, ProjectMapDepMetadata depVersion) -> - let resolvedVersion = resolveCatalogVersion lockFile.lockFileCatalogs depName depVersion + let resolvedVersion = resolveCatalogVersion (bgcCatalogs cfg) depName depVersion in for_ (toResolvedDependency (bgcToEnv cfg) pkgs (bgcMkPkgKey cfg) depName resolvedVersion) $ \dep -> do direct dep case bgcLabelingMode cfg of @@ -522,7 +564,7 @@ buildGraphCore cfg lockFile = LabelingOff -> pure () for_ (Map.toList $ directDevDependencies projectImporters) $ \(depName, ProjectMapDepMetadata depVersion) -> - let resolvedVersion = resolveCatalogVersion lockFile.lockFileCatalogs depName depVersion + let resolvedVersion = resolveCatalogVersion (bgcCatalogs cfg) depName depVersion in for_ (toResolvedDependency (bgcToEnv cfg) pkgs (bgcMkPkgKey cfg) depName resolvedVersion) $ \dep -> do direct dep case bgcLabelingMode cfg of @@ -548,7 +590,7 @@ buildGraphCore cfg lockFile = for_ deepDependencies $ \(deepName, deepVersion) -> do maybe (pure ()) (edge parentDep) (toResolvedDependency (bgcToEnv cfg) pkgs (bgcMkPkgKey cfg) deepName deepVersion) where - pkgs = packages lockFile + pkgs = lockfilePackages base snapshotEdgesHM = HashMap.fromList (bgcSnapshotEdges cfg) -- @@ -563,9 +605,8 @@ buildGraphConfigV4or5 = BuildGraphConfig , bgcToEnv = toEnvInline , bgcLabelingMode = LabelingOff , bgcSnapshotEdges = mempty + , bgcCatalogs = mempty } - --- | Config for lockfile versions 6/7/8. buildGraphConfigV678 :: BuildGraphConfig buildGraphConfigV678 = BuildGraphConfig { bgcGetPkgNameVersion = getPkgNameVersionV6 @@ -573,38 +614,19 @@ buildGraphConfigV678 = BuildGraphConfig , bgcToEnv = toEnvInline , bgcLabelingMode = LabelingOff , bgcSnapshotEdges = mempty + , bgcCatalogs = mempty } - --- | Config for lockfile version 9. -- Snapshot edges come from the lockfile itself, so this is a function. -buildGraphConfigV9 :: PnpmLockfile -> BuildGraphConfig +buildGraphConfigV9 :: PnpmLockfileV9 -> BuildGraphConfig buildGraphConfigV9 lockFile = BuildGraphConfig { bgcGetPkgNameVersion = getPkgNameVersionV9 , bgcMkPkgKey = mkPkgKeyV9 , bgcToEnv = toEnvEmpty , bgcLabelingMode = LabelingOn - , bgcSnapshotEdges = HashMap.toList lockFile.lockFileSnapshots.snapshots + , bgcSnapshotEdges = HashMap.toList lockFile.lockfileSnapshots.snapshots + , bgcCatalogs = lockFile.lockfileCatalogs } --- | Build graph for lockfile v4/v5. --- --- v5 uses @\/name\/version@ keys and derives environment from @dev@ field. -buildGraphV4or5 :: PnpmLockfile -> Graphing Dependency -buildGraphV4or5 = buildGraphCore buildGraphConfigV4or5 - --- | Build graph for lockfile v6/v7/v8. --- --- v6+ uses @\/name@version@ keys and derives environment from @dev@ field. -buildGraphV678 :: PnpmLockfile -> Graphing Dependency -buildGraphV678 = buildGraphCore buildGraphConfigV678 - --- | Build graph for lockfile v9. --- --- v9 uses @name@version@ keys (no leading slash), derives environment via --- label propagation, and uses snapshots for transitive dependency edges. -buildGraphV9 :: PnpmLockfile -> Graphing Dependency -buildGraphV9 lockFile = buildGraphCore (buildGraphConfigV9 lockFile) lockFile - -- -- Top-level dispatch -- @@ -613,19 +635,23 @@ buildGraphV9 lockFile = buildGraphCore (buildGraphConfigV9 lockFile) lockFile -- (prod\/dev). hydrateDepEnvs then propagates those environments to all -- transitive successors. buildGraph :: PnpmLockfile -> Graphing Dependency -buildGraph lockFile = case lockFileVersion lockFile of - PnpmLockLt4 _ -> buildGraphV4or5 lockFile - PnpmLock4Or5 -> buildGraphV4or5 lockFile - PnpmLockV678 _ -> buildGraphV678 lockFile - PnpmLockV9 -> buildGraphV9 lockFile +buildGraph (LockfileV4Or5 (PnpmLockfileV4Or5 base)) = buildGraphCore buildGraphConfigV4or5 base +buildGraph (LockfileV678 (PnpmLockfileV678 base)) = buildGraphCore buildGraphConfigV678 base +buildGraph (LockfileV9 v) = buildGraphCore (buildGraphConfigV9 v) (lockfileBase v) analyze :: (Has ReadFS sig m, Has Logger sig m, Has Diagnostics sig m) => Path Abs File -> m (Graphing Dependency) analyze file = context "Analyzing Pnpm Lockfile" $ do pnpmLockFile <- context "Parsing pnpm-lock file" $ readContentsYaml file - case lockFileVersion pnpmLockFile of - PnpmLockLt4 raw -> logWarn . pretty $ "pnpm-lock file is using older lockFileVersion: " <> raw <> " of, which is not officially supported!" - _ -> pure () + -- Warn about unsupported versions (v1-v3). + case pnpmLockFile of + LockfileV4Or5 (PnpmLockfileV4Or5 base) -> + case Text.uncons (lockfileRawVersion base) of + Just (c, _) | c `elem` ['1', '2', '3'] -> + logWarn . pretty $ "pnpm-lock file is using older lockFileVersion: " <> lockfileRawVersion base <> ", which is not officially supported!" + _ -> pure () + LockfileV678 _ -> pure () + LockfileV9 _ -> pure () context "Building dependency graph" $ pure $ buildGraph pnpmLockFile From 1c00f63cb817b845239fa1abd922cb6da602ef43 Mon Sep 17 00:00:00 2001 From: Christopher Sasarak Date: Mon, 1 Jun 2026 21:29:06 -0500 Subject: [PATCH 06/14] Reorganize modules. --- CLAUDE.md | 3 +- spectrometer.cabal | 3 + src/Strategy/Node/Pnpm/PnpmLock.hs | 535 +++-------------------------- src/Strategy/Node/Pnpm/Types.hs | 456 ++++++++++++++++++++++++ src/Strategy/Node/Pnpm/V4_8.hs | 119 +++++++ src/Strategy/Node/Pnpm/V9.hs | 70 ++++ 6 files changed, 697 insertions(+), 489 deletions(-) create mode 100644 src/Strategy/Node/Pnpm/Types.hs create mode 100644 src/Strategy/Node/Pnpm/V4_8.hs create mode 100644 src/Strategy/Node/Pnpm/V9.hs diff --git a/CLAUDE.md b/CLAUDE.md index ddb33d803..2a0089682 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -24,6 +24,7 @@ - Types: Prefer `newtype`, use `Text` instead of `String` - Functions: Avoid partial functions, list comprehensions, match guards - Error handling: Never use `error` or `undefined` +- **Tests**: Partial functions (`head`, `tail`, `!!`, etc.) are acceptable in test code. ## Code Style Guidelines - Rust - Format with `rustfmt` via `cargo fmt` @@ -31,4 +32,4 @@ - Follow standard Rust idioms including error handling - Use the Rust embedded tools within the Haskell code via the extlib directory -For complete guidelines, see `docs/contributing/STYLE-GUIDE.md` \ No newline at end of file +For complete guidelines, see `docs/contributing/STYLE-GUIDE.md` diff --git a/spectrometer.cabal b/spectrometer.cabal index d735bebd1..55f363fcd 100644 --- a/spectrometer.cabal +++ b/spectrometer.cabal @@ -487,6 +487,9 @@ library Strategy.Node.Npm.PackageLockV3 Strategy.Node.PackageJson Strategy.Node.Pnpm.PnpmLock + Strategy.Node.Pnpm.Types + Strategy.Node.Pnpm.V4_8 + Strategy.Node.Pnpm.V9 Strategy.Node.Pnpm.Workspace Strategy.Node.YarnV1.YarnLock Strategy.Node.YarnV2.Lockfile diff --git a/src/Strategy/Node/Pnpm/PnpmLock.hs b/src/Strategy/Node/Pnpm/PnpmLock.hs index 1e3ce5613..fd104efe3 100644 --- a/src/Strategy/Node/Pnpm/PnpmLock.hs +++ b/src/Strategy/Node/Pnpm/PnpmLock.hs @@ -5,26 +5,18 @@ module Strategy.Node.Pnpm.PnpmLock ( -- * for testing buildGraph, -) -where +) where import Control.Applicative ((<|>)) - import Control.Effect.Diagnostics (Diagnostics, Has, context) -import Data.Aeson (FromJSON (..), withObject) -import Data.Aeson.Extra (TextLike (..)) -import Data.Aeson.KeyMap (toHashMapText) +import Data.Maybe (fromMaybe) import Data.Foldable (for_) import Data.HashMap.Strict qualified as HashMap import Data.Map (Map, toList) import Data.Map qualified as Map -import Data.Maybe (fromMaybe, listToMaybe) import Data.Set qualified as Set -import Data.String.Conversion (toString) import Data.Text (Text) import Data.Text qualified as Text -import Data.Yaml (Object, Parser, (.!=), (.:), (.:?)) -import Data.Yaml qualified as Yaml import DepTypes ( DepEnvironment (EnvDevelopment, EnvProduction), DepType (GitType, NodeJSType, URLType, UserType), @@ -32,17 +24,41 @@ import DepTypes ( VerConstraint (CEq), hydrateDepEnvs, insertEnvironment, - ) + ) import Effect.Grapher (deep, direct, edge, label, run, withLabeling) import Effect.Logger ( Logger, logWarn, pretty, - ) + ) import Effect.ReadFS (ReadFS, readContentsYaml) import Graphing (Graphing) import Graphing qualified import Path (Abs, File, Path) +import Strategy.Node.Pnpm.Types ( + BuildGraphConfig (..), + GitResolution (..), + LabelingMode (..), + PackageData (..), + PnpmLockfile (..), + PnpmLockfileBase (..), + PnpmLockfileV4Or5 (..), + PnpmLockfileV678 (..), + PnpmLockfileV9 (..), + ProjectMap (..), + ProjectMapDepMetadata (..), + Resolution (..), + TarballResolution (..), + SnapshotDepName, + SnapShotDepRev, + resolveCatalogVersion, + withoutPeerDepSuffix, + ) +import Strategy.Node.Pnpm.V4_8 ( + buildGraphConfigV4or5, + buildGraphConfigV678, + ) +import Strategy.Node.Pnpm.V9 (buildGraphConfigV9) -- | Label attached to direct dependencies so that hydrateDepEnvs can -- propagate environments to transitive successors. Used only for v9 @@ -50,328 +66,6 @@ import Path (Abs, File, Path) newtype PnpmLabel = PnpmEnv DepEnvironment deriving (Eq, Ord) --- | Pnpm Lockfile --- --- Pnpm lockfile (v5) (in yaml) has the following shape (irrelevant fields omitted): --- --- @ --- > lockFileVersion: 5.4 --- > importers: --- > .: --- > specifiers: --- > aws-sdk: ^2.0.0 --- > dependencies: --- > aws-sdk: 2.1148.0 --- > devDependencies: --- > react: 18.1.0 --- > --- > packages/a: --- > specifiers: --- > commander: 9.2.0 --- > dependencies: --- > commander: 9.2.0 --- > --- > packages: --- > /aws-sdk/2.1148.0: --- > dev: false --- > peerDependencies: --- > ... --- > dependencies: --- > buffer: 4.9.2 --- > --- > /react/18.1.0: --- > dev: true --- > --- > /buffer/4.9.2: --- > dev: false --- @ --- --- In this file, --- * `importers`: refers to configurations imported/specified via package.json. --- * Key of `importers` (e.g. ".") refers to package.json filepath. --- * `specifier`: refers to version constraint specified in package.json. --- * `dependencies`: refer to direct and resolved production dependencies. --- * `devDependencies`: refer to direct and resolved development dependencies, --- --- * `packages`: lists all resolved dependencies (it does not include root level workspace package, or root package itself) --- * Key of `packages` refer (e.g. "/buffer/4.9.2:") denotes name of dependency and resolved version. --- - For dependency resolved via registry resolver, format is: "/${dependencyName}/${resolvedVersion}". --- - For dependency resolved via tarball resolver, format is: "${Url}". --- - For dependency resolved via git resolver, format is: "${Url}". --- - For dependency resolved via directory resolver, format is: "file:${relativePath}". --- --- --- Pnpm lockfile (v6) differs (v5), in following manner: --- ----------------------------------------------------- --- --- * `importers` shape merges specifiers and version, in singular object: --- @ --- > importers: --- > dependencies: --- > aws-sdk: --- > specifier: 2.1148.0 --- > version: 2.1148.0 --- @ --- --- * Key of `packages` refer (e.g. "/buffer@4.9.2") denotes name of dependency and resolved version using '@' separator --- - For dependency resolved via registry resolver, format is: "/${dependencyName}@${resolvedVersion}${peerDepsInParenthesis}". --- @ --- > /ieee754@1.1.13: --- > resolution: {integrity: sha512...} --- > dev: false --- > --- > /@clerk/nextjs@4.22.1(next@13.4.10)(react-dom@18.2.0)(react@18.2.0): --- > resolution: {integrity: sha512...} --- @ --- --- * If project has set peerDependencies to be not auto installed, pnpm --- by default, does not include them in the lockfile. So, no additional --- work is required for newly introduced `settings.autoInstallPeers` field. --- This means, that if user has chosen, not to install peerDependencies, they --- won't be included in the lock-file, so no additional work is required by fossa-cli. --- Note that, fossa-cli by default includes peer dependencies. --- --- References: --- - [pnpm](https://pnpm.io/) --- - [pnpm-lockfile](https://github.com/pnpm/pnpm/blob/5cfd6d01946edcce86f62580bddc788d02f93ed6/packages/lockfile-types/src/index.ts) --- - [pnpm-lockfile-v6](https://github.com/pnpm/pnpm/pull/5810/files) --- | Shared fields present in all lockfile versions. -data PnpmLockfileBase = PnpmLockfileBase - { lockfileImporters :: Map Text ProjectMap - , lockfilePackages :: Map Text PackageData - , lockfileRawVersion :: Text - -- ^ Raw lockfileVersion string, used for warning about unsupported versions. - } - deriving (Show, Eq, Ord) - --- | Version-specific extension for v4/v5 lockfiles. -newtype PnpmLockfileV4Or5 = PnpmLockfileV4Or5 PnpmLockfileBase - deriving (Show, Eq, Ord) - --- | Version-specific extension for v6/v7/v8 lockfiles. -newtype PnpmLockfileV678 = PnpmLockfileV678 PnpmLockfileBase - deriving (Show, Eq, Ord) - --- | Version-specific extension for v9+ lockfiles. -data PnpmLockfileV9 = PnpmLockfileV9 - { lockfileBase :: PnpmLockfileBase - , lockfileSnapshots :: PnpmLockFileSnapshots - , lockfileCatalogs :: PnpmCatalogs - } - deriving (Show, Eq, Ord) - --- | Pnpm lockfile, parameterized by version. --- --- The type constructor encodes the version, so that each variant --- carries only the data relevant to its format. -data PnpmLockfile - = LockfileV4Or5 PnpmLockfileV4Or5 - | LockfileV678 PnpmLockfileV678 - | LockfileV9 PnpmLockfileV9 - deriving (Show, Eq, Ord) - --- | Catalogs parsed from lockfile. Maps catalog name to (package name -> resolved version). --- See: https://pnpm.io/catalogs -newtype PnpmCatalogs = PnpmCatalogs - { catalogEntries :: Map Text (Map Text Text) - } - deriving (Show, Eq, Ord, Semigroup, Monoid) - -instance FromJSON PnpmCatalogs where - parseJSON = withObject "PnpmCatalogs" $ \o -> do - parsed <- traverse parseCatalog (toHashMapText o) - pure $ PnpmCatalogs (Map.fromList $ HashMap.toList parsed) - where - parseCatalog :: Yaml.Value -> Parser (Map Text Text) - parseCatalog = withObject "Catalog" $ \entries -> - (Map.fromList . HashMap.toList) - <$> traverse (withObject "CatalogEntry" (.: "version")) (toHashMapText entries) - --- | Resolve a @catalog:name@ version reference using the parsed catalogs section. --- @catalog:@ (empty name) maps to the @default@ catalog. --- @catalog:react19@ maps to the @react19@ catalog. --- If the catalog or package is not found, the original version string is returned. -resolveCatalogVersion :: PnpmCatalogs -> Text -> Text -> Text -resolveCatalogVersion (PnpmCatalogs cats) depName ver - | Just catalogName <- Text.stripPrefix "catalog:" ver = - let name = if Text.null catalogName then "default" else catalogName - in fromMaybe ver $ Map.lookup name cats >>= Map.lookup depName - | otherwise = ver - -type SnapshotDepName = Text - -type SnapShotDepRev = Text - --- | Lockfile versions > 9 use snapshots to represent the dependency graph. --- Example: --- snapshots: --- --- colorjs@0.1.9: {} --- --- punycode@2.3.1: {} --- --- uri-js@4.4.1: --- dependencies: --- punycode: 2.3.1 -newtype PnpmLockFileSnapshots = PnpmLockFileSnapshots - {snapshots :: HashMap.HashMap SnapshotDepName [(SnapshotDepName, SnapShotDepRev)]} - deriving (Show, Eq, Ord, Semigroup, Monoid) - -instance FromJSON PnpmLockFileSnapshots where - parseJSON = withObject "Read PnpmLockFileSnapshots" $ \o -> - do - let readTransitiveDepPairs = withObject "Parse dependencies" $ - \ds -> do - deps <- ds .:? "dependencies" .!= mempty - pure . HashMap.toList $ deps - snapshots <- traverse readTransitiveDepPairs o - - -- Remove the peer dependency suffix. It's present in the snapshot entry, but it's not present in packages - -- section which is where we look the dependency up. - let snapshots' = (HashMap.mapKeys withoutPeerDepSuffix) . toHashMapText $ snapshots - pure $ - PnpmLockFileSnapshots{snapshots = snapshots'} - --- | Internal version classifier used during JSON parsing. -data VersionClassifier - = VersionV4Or5 - | VersionV678 - | VersionV9 - deriving (Show, Eq, Ord) - --- | Classify the lockfile version string. -classifyVersion :: TextLike -> Parser VersionClassifier -classifyVersion (TextLike ver) = case listToMaybe (toString ver) of - Just '1' -> pure VersionV4Or5 - Just '2' -> pure VersionV4Or5 - Just '3' -> pure VersionV4Or5 - Just '4' -> pure VersionV4Or5 - Just '5' -> pure VersionV4Or5 - Just x | x `elem` ['6', '7', '8'] -> pure VersionV678 - Just '9' -> pure VersionV9 - _ -> fail $ "expected numeric lockfileVersion, got: " <> show ver - --- | Parse the shared base fields (importers + packages) common to all versions. -parseBaseLockfile :: TextLike -> Object -> Parser PnpmLockfileBase -parseBaseLockfile (TextLike rawVer) obj = do - -- Map pnpm non-workspace lockfile format to pnpm workspace lockfile format. - -- - -- For lockfile without workspaces, the 'importers' field is not included in - -- the lockfile. And 'dependencies' and 'devDependencies' are instead shown - -- at the root level. - -- - -- A project without a workspace is the same as having a single workspace at - -- the path of ".". - importers <- obj .:? "importers" .!= mempty - packages <- obj .:? "packages" .!= mempty - dependencies <- obj .:? "dependencies" .!= mempty - devDependencies <- obj .:? "devDependencies" .!= mempty - let virtualRootWs = ProjectMap dependencies devDependencies - let refinedImporters = - if Map.null importers - then Map.insert "." virtualRootWs importers - else importers - pure $ PnpmLockfileBase - { lockfileImporters = refinedImporters - , lockfilePackages = packages - , lockfileRawVersion = rawVer - } - -instance FromJSON PnpmLockfile where - parseJSON = Yaml.withObject "pnpm-lock content" $ \obj -> do - rawVer <- obj .:? "lockfileVersion" .!= (TextLike mempty) - base <- parseBaseLockfile rawVer obj - - versionClass <- classifyVersion rawVer - case versionClass of - VersionV4Or5 -> pure $ LockfileV4Or5 $ PnpmLockfileV4Or5 base - VersionV678 -> pure $ LockfileV678 $ PnpmLockfileV678 base - VersionV9 -> do - snapshots <- obj .:? "snapshots" .!= mempty - catalogs <- obj .:? "catalogs" .!= mempty - pure $ LockfileV9 $ PnpmLockfileV9 - { lockfileBase = base - , lockfileSnapshots = snapshots - , lockfileCatalogs = catalogs - } - -data ProjectMap = ProjectMap - { directDependencies :: Map Text ProjectMapDepMetadata - , directDevDependencies :: Map Text ProjectMapDepMetadata - } - deriving (Show, Eq, Ord) - -instance FromJSON ProjectMap where - parseJSON = Yaml.withObject "ProjectMap" $ \obj -> - ProjectMap - <$> obj .:? "dependencies" .!= mempty - <*> obj .:? "devDependencies" .!= mempty - -newtype ProjectMapDepMetadata = ProjectMapDepMetadata - { version :: Text - } - deriving (Show, Eq, Ord) - -instance FromJSON ProjectMapDepMetadata where - -- This is v5 lock format - parseJSON (Yaml.String r) = pure $ ProjectMapDepMetadata r - -- This is v6 lock format - parseJSON (Yaml.Object obj) = ProjectMapDepMetadata <$> obj .: "version" - parseJSON other = fail ("Invalid format; expected pure string or an object with a `version` field, got: " <> show other) - -data PackageData = PackageData - { isDev :: Bool - , name :: Maybe Text -- only provided when non-registry resolver is used - , resolution :: Resolution - , dependencies :: Map Text Text - , peerDependencies :: Map Text Text - } - deriving (Show, Eq, Ord) - -instance FromJSON PackageData where - parseJSON = Yaml.withObject "PackageData" $ \obj -> - PackageData - <$> (obj .:? "dev" .!= False) - <*> obj .:? "name" - <*> obj .: "resolution" - <*> (obj .:? "dependencies" .!= mempty) - <*> (obj .:? "peerDependencies" .!= mempty) - -data Resolution - = GitResolve GitResolution - | RegistryResolve RegistryResolution - | TarballResolve TarballResolution - | DirectoryResolve DirectoryResolution - deriving (Show, Eq, Ord) - -data GitResolution = GitResolution - { 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 - parseJSON = Yaml.withObject "Resolution" $ \obj -> - gitRes obj <|> tarballRes obj <|> directoryRes obj <|> registryRes obj - where - directoryRes :: Object -> Parser Resolution - directoryRes obj = DirectoryResolve . DirectoryResolution <$> obj .: "directory" - - registryRes :: Object -> Parser Resolution - registryRes obj = RegistryResolve . RegistryResolution <$> obj .: "integrity" - - tarballRes :: Object -> Parser Resolution - tarballRes obj = TarballResolve . TarballResolution <$> obj .: "tarball" - - gitRes :: Object -> Parser Resolution - gitRes obj = GitResolve <$> (GitResolution <$> obj .: "repo" <*> obj .: "commit") - -- -- Shared helpers (version-independent) -- @@ -414,76 +108,6 @@ applyLabels = foldr applyLabel withoutLocalPackages :: Graphing Dependency -> Graphing Dependency withoutLocalPackages = Graphing.shrink (\dep -> dependencyType dep /= UserType) --- --- Version-specific key parsers --- - --- | Parse a v5-style key: @\/name\/version@ (slash required). --- --- >> getPkgNameVersionV5 "" = Nothing --- >> getPkgNameVersionV5 "/pkg-a/1.0.0" = Just ("pkg-a", "1.0.0") -getPkgNameVersionV5 :: Text -> Maybe (Text, Text) -getPkgNameVersionV5 pkgKey = case Text.stripPrefix "/" pkgKey of - Nothing -> Nothing - Just txt -> do - let (nameWithSlash, version) = Text.breakOnEnd "/" txt - case (Text.stripSuffix "/" nameWithSlash, version) of - (Just name, v) -> Just (name, v) - _ -> Nothing - --- | Parse an @-style key (v6+). When @slashRequired@ is 'True', the key --- must start with @/@ (v6/v7/v8). When 'False', the slash is optional (v9). -parseAtKey :: Bool -> Text -> Maybe (Text, Text) -parseAtKey slashRequired pkgKey = - case Text.stripPrefix "/" pkgKey of - Nothing | slashRequired -> Nothing - Nothing -> Just pkgKey - Just txt -> Just txt - >>= \txt -> do - let (nameAndVersion, peerDepInfo) = Text.breakOn "(" txt - let (nameWithSlash, version) = Text.breakOnEnd "@" nameAndVersion - case (Text.stripSuffix "@" nameWithSlash, version) of - (Just name, v) -> Just (name, v <> peerDepInfo) - _ -> Nothing - --- | Parse a v6/v7/v8-style key: @\/name@version@ (slash required). --- --- >> getPkgNameVersionV6 "" = Nothing --- >> getPkgNameVersionV6 "/pkg-a@1.0.0" = Just ("pkg-a", "1.0.0") --- >> getPkgNameVersionV6 "/@angular/core@1.0.0(babel@1.0.0)" = Just ("@angular/core", "1.0.0(babel@1.0.0)") -getPkgNameVersionV6 :: Text -> Maybe (Text, Text) -getPkgNameVersionV6 = parseAtKey True - --- | Parse a v9-style key: @name@version@ (slash optional). --- --- >> getPkgNameVersionV9 "@angular/core@1.0.0(babel@1.0.0)" = Just ("@angular/core", "1.0.0(babel@1.0.0)") -getPkgNameVersionV9 :: Text -> Maybe (Text, Text) -getPkgNameVersionV9 = parseAtKey False - --- | Build a registry package key for v5 format: @\/name\/version@ -mkPkgKeyV5 :: Text -> Text -> Text -mkPkgKeyV5 name version = "/" <> name <> "/" <> version - --- | Build a registry package key for v6/v7/v8 format: @\/name@version@ -mkPkgKeyV6 :: Text -> Text -> Text -mkPkgKeyV6 name version = "/" <> name <> "@" <> version - --- | Build a registry package key for v9 format: @name@version@ (no leading slash) -mkPkgKeyV9 :: Text -> Text -> Text -mkPkgKeyV9 name version = name <> "@" <> version - --- --- Version-specific environment resolvers --- - --- | For v4/v5/v6/v7/v8: derive environment directly from @dev@ field. -toEnvInline :: Bool -> Set.Set DepEnvironment -toEnvInline isDev = Set.singleton (if isDev then EnvDevelopment else EnvProduction) - --- | For v9: start with empty environments; labels set them later. -toEnvEmpty :: Bool -> Set.Set DepEnvironment -toEnvEmpty _ = mempty - -- -- Resolved dependency lookup -- @@ -521,53 +145,34 @@ toResolvedDependency toEnv pkgs mkPkg depName depVersion = do -- Shared graph-building loop -- --- | Whether to label direct dependencies so that 'hydrateDepEnvs' --- propagates environments through the graph. --- --- V9 lockfiles start with empty environments and rely on label --- propagation. Older versions set environments inline from the @dev@ field. -data LabelingMode = LabelingOff | LabelingOn - deriving (Show, Eq, Ord) - --- | Configuration for 'buildGraphCore'. --- --- Each field controls version-specific behavior: --- --- - 'bgcGetPkgNameVersion': parse (name, version) from a package key --- - 'bgcMkPkgKey': build a registry package key from (name, version) --- - 'bgcToEnv': derive environment from @dev@ field (or ignore it for v9) --- - 'bgcLabelingMode': whether to label direct deps for hydrateDepEnvs propagation --- - 'bgcSnapshotEdges': additional edges from v9 snapshots (empty for older versions) --- - 'bgcCatalogs': catalog name -> (package name -> resolved version) mappings -data BuildGraphConfig = BuildGraphConfig - { bgcGetPkgNameVersion :: Text -> Maybe (Text, Text) -- ^ Parse (name, version) from a package key - , bgcMkPkgKey :: Text -> Text -> Text -- ^ Build a registry package key from (name, version) - , bgcToEnv :: Bool -> Set.Set DepEnvironment -- ^ Derive environment from @dev@ field (or ignore for v9) - , bgcLabelingMode :: LabelingMode -- ^ Whether to label direct deps for hydrateDepEnvs propagation - , bgcSnapshotEdges :: [(SnapshotDepName, [(SnapshotDepName, SnapShotDepRev)])] -- ^ Additional edges from v9 snapshots - , bgcCatalogs :: PnpmCatalogs -- ^ Catalog name -> (package name -> resolved version) mappings - } - -- | Core graph-building logic shared across all lockfile versions. buildGraphCore :: BuildGraphConfig -> PnpmLockfileBase -> Graphing Dependency -buildGraphCore cfg base = - withoutLocalPackages . hydrateDepEnvs $ +buildGraphCore BuildGraphConfig{bgcGetPkgNameVersion, bgcMkPkgKey, bgcToEnv, bgcLabelingMode, bgcSnapshotEdges, bgcCatalogs} base = + let getPkgNameVersion = bgcGetPkgNameVersion + mkPkgKey = bgcMkPkgKey + toEnv = bgcToEnv + labelingMode = bgcLabelingMode + snapshotEdges = bgcSnapshotEdges + catalogs = bgcCatalogs + pkgs = lockfilePackages base + snapshotEdgesHM = HashMap.fromList snapshotEdges + in withoutLocalPackages . hydrateDepEnvs $ run . withLabeling applyLabels $ do -- Direct dependencies from each importer (workspace package). for_ (toList (lockfileImporters base)) $ \(_, projectImporters) -> do for_ (Map.toList $ directDependencies projectImporters) $ \(depName, ProjectMapDepMetadata depVersion) -> - let resolvedVersion = resolveCatalogVersion (bgcCatalogs cfg) depName depVersion - in for_ (toResolvedDependency (bgcToEnv cfg) pkgs (bgcMkPkgKey cfg) depName resolvedVersion) $ \dep -> do + let resolvedVersion = resolveCatalogVersion catalogs depName depVersion + in for_ (toResolvedDependency toEnv pkgs mkPkgKey depName resolvedVersion) $ \dep -> do direct dep - case bgcLabelingMode cfg of + case labelingMode of LabelingOn -> label dep (PnpmEnv EnvProduction) LabelingOff -> pure () for_ (Map.toList $ directDevDependencies projectImporters) $ \(depName, ProjectMapDepMetadata depVersion) -> - let resolvedVersion = resolveCatalogVersion (bgcCatalogs cfg) depName depVersion - in for_ (toResolvedDependency (bgcToEnv cfg) pkgs (bgcMkPkgKey cfg) depName resolvedVersion) $ \dep -> do + let resolvedVersion = resolveCatalogVersion catalogs depName depVersion + in for_ (toResolvedDependency toEnv pkgs mkPkgKey depName resolvedVersion) $ \dep -> do direct dep - case bgcLabelingMode cfg of + case labelingMode of LabelingOn -> label dep (PnpmEnv EnvDevelopment) LabelingOff -> pure () @@ -578,54 +183,17 @@ buildGraphCore cfg base = <> Map.toList (peerDependencies pkgMeta) <> fromMaybe mempty (HashMap.lookup pkgKey snapshotEdgesHM) - let (depName, depVersion) = case bgcGetPkgNameVersion cfg pkgKey of + let (depName, depVersion) = case getPkgNameVersion pkgKey of Nothing -> (pkgKey, Nothing) Just (name, version) -> (name, Just version) - let parentDep = toDependency (bgcToEnv cfg) depName depVersion pkgMeta + let parentDep = toDependency toEnv depName depVersion pkgMeta -- 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 (bgcToEnv cfg) pkgs (bgcMkPkgKey cfg) deepName deepVersion) - where - pkgs = lockfilePackages base - snapshotEdgesHM = HashMap.fromList (bgcSnapshotEdges cfg) - --- --- Per-version graph builders --- - --- | Config for lockfile versions 4/5. -buildGraphConfigV4or5 :: BuildGraphConfig -buildGraphConfigV4or5 = BuildGraphConfig - { bgcGetPkgNameVersion = getPkgNameVersionV5 - , bgcMkPkgKey = mkPkgKeyV5 - , bgcToEnv = toEnvInline - , bgcLabelingMode = LabelingOff - , bgcSnapshotEdges = mempty - , bgcCatalogs = mempty - } -buildGraphConfigV678 :: BuildGraphConfig -buildGraphConfigV678 = BuildGraphConfig - { bgcGetPkgNameVersion = getPkgNameVersionV6 - , bgcMkPkgKey = mkPkgKeyV6 - , bgcToEnv = toEnvInline - , bgcLabelingMode = LabelingOff - , bgcSnapshotEdges = mempty - , bgcCatalogs = mempty - } --- Snapshot edges come from the lockfile itself, so this is a function. -buildGraphConfigV9 :: PnpmLockfileV9 -> BuildGraphConfig -buildGraphConfigV9 lockFile = BuildGraphConfig - { bgcGetPkgNameVersion = getPkgNameVersionV9 - , bgcMkPkgKey = mkPkgKeyV9 - , bgcToEnv = toEnvEmpty - , bgcLabelingMode = LabelingOn - , bgcSnapshotEdges = HashMap.toList lockFile.lockfileSnapshots.snapshots - , bgcCatalogs = lockFile.lockfileCatalogs - } + maybe (pure ()) (edge parentDep) (toResolvedDependency toEnv pkgs mkPkgKey deepName deepVersion) -- -- Top-level dispatch @@ -654,12 +222,3 @@ analyze file = context "Analyzing Pnpm Lockfile" $ do LockfileV9 _ -> pure () context "Building dependency graph" $ pure $ buildGraph pnpmLockFile - --- Sometimes package versions include resolved peer dependency version --- in parentheses. This is used by pnpm for dependency resolution, we do --- not care about them, as they do not represent package version. --- --- >> withoutPeerDepSuffix "1.2.0" = "1.2.0" --- >> withoutPeerDepSuffix "1.2.0(babel@1.0.0)" = "1.2.0" -withoutPeerDepSuffix :: Text -> Text -withoutPeerDepSuffix = fst . Text.breakOn "(" diff --git a/src/Strategy/Node/Pnpm/Types.hs b/src/Strategy/Node/Pnpm/Types.hs new file mode 100644 index 000000000..153d81aac --- /dev/null +++ b/src/Strategy/Node/Pnpm/Types.hs @@ -0,0 +1,456 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module Strategy.Node.Pnpm.Types ( + -- * Lockfile types + PnpmLockfileBase (..), + PnpmLockfileV4Or5 (..), + PnpmLockfileV678 (..), + PnpmLockfileV9 (..), + PnpmLockfile (..), + + -- * Catalogs + PnpmCatalogs (..), + resolveCatalogVersion, + + -- * Snapshots + SnapshotDepName, + SnapShotDepRev, + PnpmLockFileSnapshots (..), + + -- * Project map + ProjectMap (..), + ProjectMapDepMetadata (..), + + -- * Package data + PackageData (..), + Resolution (..), + GitResolution (..), + TarballResolution (..), + RegistryResolution (..), + DirectoryResolution (..), + + -- * Version classification + VersionClassifier (..), + classifyVersion, + parseBaseLockfile, + + -- * Graph configuration + LabelingMode (..), + BuildGraphConfig (..), + + -- * Helpers + withoutPeerDepSuffix, +) where + +import Control.Applicative ((<|>)) + +import Data.Aeson (FromJSON (..), withObject) +import Data.Aeson.Extra (TextLike (..)) +import Data.Aeson.KeyMap (toHashMapText) +import DepTypes (DepEnvironment) +import Data.HashMap.Strict qualified as HashMap +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Set qualified as Set +import Data.String.Conversion (toString) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Yaml (Object, Parser, (.!=), (.:), (.:?)) +import Data.Yaml qualified as Yaml + +-- | Pnpm Lockfile +-- +-- Pnpm lockfile (v5) (in yaml) has the following shape (irrelevant fields omitted): +-- +-- @ +-- > lockFileVersion: 5.4 +-- > importers: +-- > .: +-- > specifiers: +-- > aws-sdk: ^2.0.0 +-- > dependencies: +-- > aws-sdk: 2.1148.0 +-- > devDependencies: +-- > react: 18.1.0 +-- > +-- > packages/a: +-- > specifiers: +-- > commander: 9.2.0 +-- > dependencies: +-- > commander: 9.2.0 +-- > +-- > packages: +-- > /aws-sdk/2.1148.0: +-- > dev: false +-- > peerDependencies: +-- > ... +-- > dependencies: +-- > buffer: 4.9.2 +-- > +-- > /react/18.1.0: +-- > dev: true +-- > +-- > /buffer/4.9.2: +-- > dev: false +-- @ +-- +-- In this file, +-- * 'importers': refers to configurations imported\/specified via package.json. +-- * Key of 'importers' (e.g. \".\") refers to package.json filepath. +-- * 'specifier': refers to version constraint specified in package.json. +-- * 'dependencies': refer to direct and resolved production dependencies. +-- * 'devDependencies': refer to direct and resolved development dependencies, +-- +-- * 'packages': lists all resolved dependencies (it does not include root level workspace package, or root package itself) +-- * Key of 'packages' refer (e.g. \"/buffer\/4.9.2:\") denotes name of dependency and resolved version. +-- - For dependency resolved via registry resolver, format is: \"/${dependencyName}\/${resolvedVersion}\". +-- - For dependency resolved via tarball resolver, format is: \"${Url}\". +-- - For dependency resolved via git resolver, format is: \"${Url}\". +-- - For dependency resolved via directory resolver, format is: \"file:${relativePath}\". +-- +-- +-- Pnpm lockfile (v6) differs (v5), in following manner: +-- ----------------------------------------------------- +-- +-- * 'importers' shape merges specifiers and version, in singular object: +-- @ +-- > importers: +-- > dependencies: +-- > aws-sdk: +-- > specifier: 2.1148.0 +-- > version: 2.1148.0 +-- @ +-- +-- * Key of 'packages' refer (e.g. \"/buffer@4.9.2\") denotes name of dependency and resolved version using '@' separator +-- - For dependency resolved via registry resolver, format is: \"/${dependencyName}@${resolvedVersion}${peerDepsInParenthesis}\". +-- @ +-- > /ieee754@1.1.13: +-- > resolution: {integrity: sha512...} +-- > dev: false +-- > +-- > /@clerk/nextjs@4.22.1(next@13.4.10)(react-dom@18.2.0)(react@18.2.0): +-- > resolution: {integrity: sha512...} +-- @ +-- +-- * If project has set peerDependencies to be not auto installed, pnpm +-- by default, does not include them in the lockfile. So, no additional +-- work is required for newly introduced 'settings.autoInstallPeers' field. +-- This means, that if user has chosen, not to install peerDependencies, they +-- won't be included in the lock-file, so no additional work is required by fossa-cli. +-- Note that, fossa-cli by default includes peer dependencies. +-- +-- References: +-- - [pnpm](https://pnpm.io/) +-- - [pnpm-lockfile](https://github.com/pnpm/pnpm/blob/5cfd6d01946edcce86f62580bddc788d02f93ed6/packages/lockfile-types/src/index.ts) +-- - [pnpm-lockfile-v6](https://github.com/pnpm/pnpm/pull/5810/files) + +-- +-- Lockfile types +-- + +-- | Shared fields present in all lockfile versions. +data PnpmLockfileBase = PnpmLockfileBase + { lockfileImporters :: Map Text ProjectMap + , lockfilePackages :: Map Text PackageData + , lockfileRawVersion :: Text + -- ^ Raw lockfileVersion string, used for warning about unsupported versions. + } + deriving (Show, Eq, Ord) + +-- | Version-specific extension for v4\/v5 lockfiles. +newtype PnpmLockfileV4Or5 = PnpmLockfileV4Or5 PnpmLockfileBase + deriving (Show, Eq, Ord) + +-- | Version-specific extension for v6\/v7\/v8 lockfiles. +newtype PnpmLockfileV678 = PnpmLockfileV678 PnpmLockfileBase + deriving (Show, Eq, Ord) + +-- | Version-specific extension for v9+ lockfiles. +data PnpmLockfileV9 = PnpmLockfileV9 + { lockfileBase :: PnpmLockfileBase + , lockfileSnapshots :: PnpmLockFileSnapshots + , lockfileCatalogs :: PnpmCatalogs + } + deriving (Show, Eq, Ord) + +-- | Pnpm lockfile, parameterized by version. +-- +-- The type constructor encodes the version, so that each variant +-- carries only the data relevant to its format. +data PnpmLockfile + = LockfileV4Or5 PnpmLockfileV4Or5 + | LockfileV678 PnpmLockfileV678 + | LockfileV9 PnpmLockfileV9 + deriving (Show, Eq, Ord) + +-- +-- Catalogs +-- + +-- | Catalogs parsed from lockfile. Maps catalog name to (package name -> resolved version). +-- See: https://pnpm.io/catalogs +newtype PnpmCatalogs = PnpmCatalogs + { catalogEntries :: Map Text (Map Text Text) + } + deriving (Show, Eq, Ord, Semigroup, Monoid) + +instance FromJSON PnpmCatalogs where + parseJSON = withObject "PnpmCatalogs" $ \o -> do + parsed <- traverse parseCatalog (toHashMapText o) + pure $ PnpmCatalogs (Map.fromList $ HashMap.toList parsed) + where + parseCatalog :: Yaml.Value -> Parser (Map Text Text) + parseCatalog = withObject "Catalog" $ \entries -> + (Map.fromList . HashMap.toList) + <$> traverse (withObject "CatalogEntry" (.: "version")) (toHashMapText entries) + +-- | Resolve a @catalog:name@ version reference using the parsed catalogs section. +-- @catalog:@ (empty name) maps to the @default@ catalog. +-- @catalog:react19@ maps to the @react19@ catalog. +-- If the catalog or package is not found, the original version string is returned. +resolveCatalogVersion :: PnpmCatalogs -> Text -> Text -> Text +resolveCatalogVersion (PnpmCatalogs cats) depName ver + | Just catalogName <- Text.stripPrefix "catalog:" ver = + let name = if Text.null catalogName then "default" else catalogName + in fromMaybe ver $ Map.lookup name cats >>= Map.lookup depName + | otherwise = ver + +-- +-- Snapshots +-- + +type SnapshotDepName = Text + +type SnapShotDepRev = Text + +-- | Lockfile versions > 9 use snapshots to represent the dependency graph. +-- Example: +-- snapshots: +-- +-- colorjs@0.1.9: {} +-- +-- punycode@2.3.1: {} +-- +-- uri-js@4.4.1: +-- dependencies: +-- punycode: 2.3.1 +newtype PnpmLockFileSnapshots = PnpmLockFileSnapshots + {snapshots :: HashMap.HashMap SnapshotDepName [(SnapshotDepName, SnapShotDepRev)]} + deriving (Show, Eq, Ord, Semigroup, Monoid) + +instance FromJSON PnpmLockFileSnapshots where + parseJSON = withObject "Read PnpmLockFileSnapshots" $ \o -> + do + let readTransitiveDepPairs = withObject "Parse dependencies" $ + \ds -> do + deps <- ds .:? "dependencies" .!= mempty + pure . HashMap.toList $ deps + snapshots <- traverse readTransitiveDepPairs o + + -- Remove the peer dependency suffix. It's present in the snapshot entry, but it's not present in packages + -- section which is where we look the dependency up. + let snapshots' = (HashMap.mapKeys withoutPeerDepSuffix) . toHashMapText $ snapshots + pure $ + PnpmLockFileSnapshots{snapshots = snapshots'} + +-- +-- Project map +-- + +data ProjectMap = ProjectMap + { directDependencies :: Map Text ProjectMapDepMetadata + , directDevDependencies :: Map Text ProjectMapDepMetadata + } + deriving (Show, Eq, Ord) + +instance FromJSON ProjectMap where + parseJSON = Yaml.withObject "ProjectMap" $ \obj -> + ProjectMap + <$> obj .:? "dependencies" .!= mempty + <*> obj .:? "devDependencies" .!= mempty + +newtype ProjectMapDepMetadata = ProjectMapDepMetadata + { version :: Text + } + deriving (Show, Eq, Ord) + +instance FromJSON ProjectMapDepMetadata where + -- This is v5 lock format + parseJSON (Yaml.String r) = pure $ ProjectMapDepMetadata r + -- This is v6 lock format + parseJSON (Yaml.Object obj) = ProjectMapDepMetadata <$> obj .: "version" + parseJSON other = fail ("Invalid format; expected pure string or an object with a `version` field, got: " <> show other) + +-- +-- Package data +-- + +data PackageData = PackageData + { isDev :: Bool + , name :: Maybe Text -- only provided when non-registry resolver is used + , resolution :: Resolution + , dependencies :: Map Text Text + , peerDependencies :: Map Text Text + } + deriving (Show, Eq, Ord) + +instance FromJSON PackageData where + parseJSON = Yaml.withObject "PackageData" $ \obj -> + PackageData + <$> (obj .:? "dev" .!= False) + <*> obj .:? "name" + <*> obj .: "resolution" + <*> (obj .:? "dependencies" .!= mempty) + <*> (obj .:? "peerDependencies" .!= mempty) + +data Resolution + = GitResolve GitResolution + | RegistryResolve RegistryResolution + | TarballResolve TarballResolution + | DirectoryResolve DirectoryResolution + deriving (Show, Eq, Ord) + +data GitResolution = GitResolution + { 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 + parseJSON = Yaml.withObject "Resolution" $ \obj -> + gitRes obj <|> tarballRes obj <|> directoryRes obj <|> registryRes obj + where + directoryRes :: Object -> Parser Resolution + directoryRes obj = DirectoryResolve . DirectoryResolution <$> obj .: "directory" + + registryRes :: Object -> Parser Resolution + registryRes obj = RegistryResolve . RegistryResolution <$> obj .: "integrity" + + tarballRes :: Object -> Parser Resolution + tarballRes obj = TarballResolve . TarballResolution <$> obj .: "tarball" + + gitRes :: Object -> Parser Resolution + gitRes obj = GitResolve <$> (GitResolution <$> obj .: "repo" <*> obj .: "commit") + +-- +-- Version classification +-- + +-- | Internal version classifier used during JSON parsing. +data VersionClassifier + = VersionV4Or5 + | VersionV678 + | VersionV9 + deriving (Show, Eq, Ord) + +-- | Classify the lockfile version string. +classifyVersion :: TextLike -> Parser VersionClassifier +classifyVersion (TextLike ver) = case listToMaybe (toString ver) of + Just '1' -> pure VersionV4Or5 + Just '2' -> pure VersionV4Or5 + Just '3' -> pure VersionV4Or5 + Just '4' -> pure VersionV4Or5 + Just '5' -> pure VersionV4Or5 + Just x | x `elem` ['6', '7', '8'] -> pure VersionV678 + Just '9' -> pure VersionV9 + _ -> fail $ "expected numeric lockfileVersion, got: " <> show ver + +-- | Parse the shared base fields (importers + packages) common to all versions. +parseBaseLockfile :: TextLike -> Object -> Parser PnpmLockfileBase +parseBaseLockfile (TextLike rawVer) obj = do + -- Map pnpm non-workspace lockfile format to pnpm workspace lockfile format. + -- + -- For lockfile without workspaces, the 'importers' field is not included in + -- the lockfile. And 'dependencies' and 'devDependencies' are instead shown + -- at the root level. + -- + -- A project without a workspace is the same as having a single workspace at + -- the path of \".\". + importers <- obj .:? "importers" .!= mempty + packages <- obj .:? "packages" .!= mempty + dependencies <- obj .:? "dependencies" .!= mempty + devDependencies <- obj .:? "devDependencies" .!= mempty + let virtualRootWs = ProjectMap dependencies devDependencies + let refinedImporters = + if Map.null importers + then Map.insert "." virtualRootWs importers + else importers + pure $ PnpmLockfileBase + { lockfileImporters = refinedImporters + , lockfilePackages = packages + , lockfileRawVersion = rawVer + } + +-- | FromJSON for the sum type — reads 'lockfileVersion' and dispatches. +instance FromJSON PnpmLockfile where + parseJSON = Yaml.withObject "pnpm-lock content" $ \obj -> do + rawVer <- obj .:? "lockfileVersion" .!= (TextLike mempty) + base <- parseBaseLockfile rawVer obj + + versionClass <- classifyVersion rawVer + case versionClass of + VersionV4Or5 -> pure $ LockfileV4Or5 $ PnpmLockfileV4Or5 base + VersionV678 -> pure $ LockfileV678 $ PnpmLockfileV678 base + VersionV9 -> do + snapshots <- obj .:? "snapshots" .!= mempty + catalogs <- obj .:? "catalogs" .!= mempty + pure $ LockfileV9 $ PnpmLockfileV9 + { lockfileBase = base + , lockfileSnapshots = snapshots + , lockfileCatalogs = catalogs + } + +-- +-- Graph configuration +-- + +-- | Whether to label direct dependencies so that 'hydrateDepEnvs' +-- propagates environments through the graph. +-- +-- V9 lockfiles start with empty environments and rely on label +-- propagation. Older versions set environments inline from the @dev@ field. +data LabelingMode = LabelingOff | LabelingOn + deriving (Show, Eq, Ord) + +-- | Configuration for graph building. +-- +-- Each field controls version-specific behavior: +-- +-- - 'bgcGetPkgNameVersion': parse (name, version) from a package key +-- - 'bgcMkPkgKey': build a registry package key from (name, version) +-- - 'bgcToEnv': derive environment from @dev@ field (or ignore it for v9) +-- - 'bgcLabelingMode': whether to label direct deps for hydrateDepEnvs propagation +-- - 'bgcSnapshotEdges': additional edges from v9 snapshots (empty for older versions) +-- - 'bgcCatalogs': catalog name -> (package name -> resolved version) mappings +data BuildGraphConfig = BuildGraphConfig + { bgcGetPkgNameVersion :: Text -> Maybe (Text, Text) + -- ^ Parse (name, version) from a package key + , bgcMkPkgKey :: Text -> Text -> Text + -- ^ Build a registry package key from (name, version) + , bgcToEnv :: Bool -> Set.Set DepEnvironment + -- ^ Derive environment from @dev@ field (or ignore for v9) + , bgcLabelingMode :: LabelingMode + -- ^ Whether to label direct deps for hydrateDepEnvs propagation + , bgcSnapshotEdges :: [(SnapshotDepName, [(SnapshotDepName, SnapShotDepRev)])] + -- ^ Additional edges from v9 snapshots + , bgcCatalogs :: PnpmCatalogs + -- ^ Catalog name -> (package name -> resolved version) mappings + } + +-- +-- Helpers +-- + +-- | Strip peer dependency suffix from version strings. +-- +-- >> withoutPeerDepSuffix "1.2.0" = "1.2.0" +-- >> withoutPeerDepSuffix "1.2.0(babel@1.0.0)" = "1.2.0" +withoutPeerDepSuffix :: Text -> Text +withoutPeerDepSuffix = fst . Text.breakOn "(" diff --git a/src/Strategy/Node/Pnpm/V4_8.hs b/src/Strategy/Node/Pnpm/V4_8.hs new file mode 100644 index 000000000..65860a595 --- /dev/null +++ b/src/Strategy/Node/Pnpm/V4_8.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module Strategy.Node.Pnpm.V4_8 ( + -- * Key parsers + getPkgNameVersionV5, + getPkgNameVersionV6, + parseAtKey, + + -- * Key builders + mkPkgKeyV5, + mkPkgKeyV6, + + -- * Environment resolver + toEnvInline, + + -- * Configs + buildGraphConfigV4or5, + buildGraphConfigV678, +) where + +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as Text +import DepTypes (DepEnvironment (EnvDevelopment, EnvProduction)) +import Strategy.Node.Pnpm.Types (BuildGraphConfig (..), LabelingMode (LabelingOff)) + +-- +-- Key parsing utilities +-- + +-- | Parse an @-style key. When @slashRequired@ is 'True', the key +-- must start with @/@ (v6/v7/v8). When 'False', the slash is optional (v9). +-- +-- >> parseAtKey True "/pkg-a@1.0.0" = Just ("pkg-a", "1.0.0") +-- >> parseAtKey False "pkg-a@1.0.0" = Just ("pkg-a", "1.0.0") +-- >> parseAtKey True "pkg-a@1.0.0" = Nothing +parseAtKey :: Bool -> Text -> Maybe (Text, Text) +parseAtKey slashRequired pkgKey = + case Text.stripPrefix "/" pkgKey of + Nothing | slashRequired -> Nothing + Nothing -> Just pkgKey + Just txt -> Just txt + >>= \txt -> do + let (nameAndVersion, peerDepInfo) = Text.breakOn "(" txt + let (nameWithSlash, version) = Text.breakOnEnd "@" nameAndVersion + case (Text.stripSuffix "@" nameWithSlash, version) of + (Just name, v) -> Just (name, v <> peerDepInfo) + _ -> Nothing + +-- +-- Key parsers +-- + +-- | Parse a v5-style key: @/name/version@ (slash required). +-- +-- >> getPkgNameVersionV5 "" = Nothing +-- >> getPkgNameVersionV5 "/pkg-a/1.0.0" = Just ("pkg-a", "1.0.0") +getPkgNameVersionV5 :: Text -> Maybe (Text, Text) +getPkgNameVersionV5 pkgKey = case Text.stripPrefix "/" pkgKey of + Nothing -> Nothing + Just txt -> do + let (nameWithSlash, version) = Text.breakOnEnd "/" txt + case (Text.stripSuffix "/" nameWithSlash, version) of + (Just name, v) -> Just (name, v) + _ -> Nothing + +-- | Parse a v6/v7/v8-style key: @/name@version@ (slash required). +-- +-- >> getPkgNameVersionV6 "" = Nothing +-- >> getPkgNameVersionV6 "/pkg-a@1.0.0" = Just ("pkg-a", "1.0.0") +-- >> getPkgNameVersionV6 "/@angular/core@1.0.0(babel@1.0.0)" = Just ("@angular/core", "1.0.0(babel@1.0.0)") +getPkgNameVersionV6 :: Text -> Maybe (Text, Text) +getPkgNameVersionV6 = parseAtKey True + +-- +-- Key builders +-- + +-- | Build a registry package key for v5 format: @/name/version@ +mkPkgKeyV5 :: Text -> Text -> Text +mkPkgKeyV5 name version = "/" <> name <> "/" <> version + +-- | Build a registry package key for v6/v7/v8 format: @/name@version@ +mkPkgKeyV6 :: Text -> Text -> Text +mkPkgKeyV6 name version = "/" <> name <> "@" <> version + +-- +-- Environment resolver +-- + +-- | For v4/v5/v6/v7/v8: derive environment directly from @dev@ field. +toEnvInline :: Bool -> Set.Set DepEnvironment +toEnvInline isDev = Set.singleton (if isDev then EnvDevelopment else EnvProduction) + +-- +-- Per-version configs +-- + +-- | Config for lockfile versions 4/5. +buildGraphConfigV4or5 :: BuildGraphConfig +buildGraphConfigV4or5 = BuildGraphConfig + { bgcGetPkgNameVersion = getPkgNameVersionV5 + , bgcMkPkgKey = mkPkgKeyV5 + , bgcToEnv = toEnvInline + , bgcLabelingMode = LabelingOff + , bgcSnapshotEdges = mempty + , bgcCatalogs = mempty + } + +-- | Config for lockfile versions 6/7/8. +buildGraphConfigV678 :: BuildGraphConfig +buildGraphConfigV678 = BuildGraphConfig + { bgcGetPkgNameVersion = getPkgNameVersionV6 + , bgcMkPkgKey = mkPkgKeyV6 + , bgcToEnv = toEnvInline + , bgcLabelingMode = LabelingOff + , bgcSnapshotEdges = mempty + , bgcCatalogs = mempty + } diff --git a/src/Strategy/Node/Pnpm/V9.hs b/src/Strategy/Node/Pnpm/V9.hs new file mode 100644 index 000000000..894682cdc --- /dev/null +++ b/src/Strategy/Node/Pnpm/V9.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module Strategy.Node.Pnpm.V9 ( + -- * Key parsers + getPkgNameVersionV9, + + -- * Key builders + mkPkgKeyV9, + + -- * Environment resolver + toEnvEmpty, + + -- * Config + buildGraphConfigV9, +) where + +import Data.HashMap.Strict qualified as HashMap +import Data.Set qualified as Set +import Data.Text (Text) +import DepTypes (DepEnvironment) +import Strategy.Node.Pnpm.Types ( + BuildGraphConfig (..), + LabelingMode (LabelingOn), + PnpmLockfileV9 (..), + PnpmLockFileSnapshots (snapshots), + ) +import Strategy.Node.Pnpm.V4_8 (parseAtKey) + +-- +-- Key parsers +-- + +-- | Parse a v9-style key: @name@version@ (slash optional). +-- +-- >> getPkgNameVersionV9 "@angular/core@1.0.0(babel@1.0.0)" = Just ("@angular/core", "1.0.0(babel@1.0.0)") +getPkgNameVersionV9 :: Text -> Maybe (Text, Text) +getPkgNameVersionV9 = parseAtKey False + +-- +-- Key builders +-- + +-- | Build a registry package key for v9 format: @name@version@ (no leading slash) +mkPkgKeyV9 :: Text -> Text -> Text +mkPkgKeyV9 name version = name <> "@" <> version + +-- +-- Environment resolver +-- + +-- | For v9: start with empty environments; labels set them later. +toEnvEmpty :: Bool -> Set.Set DepEnvironment +toEnvEmpty _ = mempty + +-- +-- Config +-- + +-- | Config for lockfile version 9. +-- +-- Snapshot edges come from the lockfile itself, so this is a function. +buildGraphConfigV9 :: PnpmLockfileV9 -> BuildGraphConfig +buildGraphConfigV9 lockFile = BuildGraphConfig + { bgcGetPkgNameVersion = getPkgNameVersionV9 + , bgcMkPkgKey = mkPkgKeyV9 + , bgcToEnv = toEnvEmpty + , bgcLabelingMode = LabelingOn + , bgcSnapshotEdges = HashMap.toList lockFile.lockfileSnapshots.snapshots + , bgcCatalogs = lockFile.lockfileCatalogs + } From 226754316b41dbb2d0105548ab462a799da88830 Mon Sep 17 00:00:00 2001 From: Christopher Sasarak Date: Mon, 1 Jun 2026 21:59:34 -0500 Subject: [PATCH 07/14] More cleanup --- src/Strategy/Node/Pnpm/PnpmLock.hs | 13 ++++++++++++- src/Strategy/Node/Pnpm/Types.hs | 14 -------------- 2 files changed, 12 insertions(+), 15 deletions(-) diff --git a/src/Strategy/Node/Pnpm/PnpmLock.hs b/src/Strategy/Node/Pnpm/PnpmLock.hs index fd104efe3..34d3280b7 100644 --- a/src/Strategy/Node/Pnpm/PnpmLock.hs +++ b/src/Strategy/Node/Pnpm/PnpmLock.hs @@ -40,6 +40,7 @@ import Strategy.Node.Pnpm.Types ( GitResolution (..), LabelingMode (..), PackageData (..), + PnpmCatalogs (..), PnpmLockfile (..), PnpmLockfileBase (..), PnpmLockfileV4Or5 (..), @@ -51,7 +52,6 @@ import Strategy.Node.Pnpm.Types ( TarballResolution (..), SnapshotDepName, SnapShotDepRev, - resolveCatalogVersion, withoutPeerDepSuffix, ) import Strategy.Node.Pnpm.V4_8 ( @@ -98,6 +98,17 @@ toDep toEnv depType name version isDev = withoutSymConstraint :: Text -> Text withoutSymConstraint version = fst $ Text.breakOn "_" version +-- | Resolve a catalog reference to its actual version. +-- +-- If the version is a @catalog:name@ reference, looks up the package +-- in the catalog map. Otherwise returns the version unchanged. +resolveCatalogVersion :: PnpmCatalogs -> Text -> Text -> Text +resolveCatalogVersion (PnpmCatalogs cats) depName ver + | Just catalogName <- Text.stripPrefix "catalog:" ver = + let name = if Text.null catalogName then "default" else catalogName + in fromMaybe ver $ Map.lookup name cats >>= Map.lookup depName + | otherwise = ver + -- | Apply accumulated labels to transform a graph node. applyLabels :: Dependency -> Set.Set PnpmLabel -> Dependency applyLabels = foldr applyLabel diff --git a/src/Strategy/Node/Pnpm/Types.hs b/src/Strategy/Node/Pnpm/Types.hs index 153d81aac..f5c8e2b78 100644 --- a/src/Strategy/Node/Pnpm/Types.hs +++ b/src/Strategy/Node/Pnpm/Types.hs @@ -10,7 +10,6 @@ module Strategy.Node.Pnpm.Types ( -- * Catalogs PnpmCatalogs (..), - resolveCatalogVersion, -- * Snapshots SnapshotDepName, @@ -29,11 +28,6 @@ module Strategy.Node.Pnpm.Types ( RegistryResolution (..), DirectoryResolution (..), - -- * Version classification - VersionClassifier (..), - classifyVersion, - parseBaseLockfile, - -- * Graph configuration LabelingMode (..), BuildGraphConfig (..), @@ -208,14 +202,6 @@ instance FromJSON PnpmCatalogs where -- | Resolve a @catalog:name@ version reference using the parsed catalogs section. -- @catalog:@ (empty name) maps to the @default@ catalog. -- @catalog:react19@ maps to the @react19@ catalog. --- If the catalog or package is not found, the original version string is returned. -resolveCatalogVersion :: PnpmCatalogs -> Text -> Text -> Text -resolveCatalogVersion (PnpmCatalogs cats) depName ver - | Just catalogName <- Text.stripPrefix "catalog:" ver = - let name = if Text.null catalogName then "default" else catalogName - in fromMaybe ver $ Map.lookup name cats >>= Map.lookup depName - | otherwise = ver - -- -- Snapshots -- From 778ca5f6c78486cdff55ab2015c6e52f19fccd5e Mon Sep 17 00:00:00 2001 From: Christopher Sasarak Date: Tue, 2 Jun 2026 18:22:48 -0500 Subject: [PATCH 08/14] Remove makefile changes --- Makefile | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/Makefile b/Makefile index af8781fbe..9e63a0a20 100644 --- a/Makefile +++ b/Makefile @@ -9,7 +9,6 @@ MOUNTED_DEV_TOOLS_OPTS := --rm MOUNTED_DEV_TOOLS_OPTS += --mount "type=bind,source=${current_dir},target=/fossa-cli" MOUNTED_DEV_TOOLS_OPTS += --workdir "/fossa-cli" MOUNTED_DEV_TOOLS := ${MOUNTED_DEV_TOOLS_OPTS} ${DEV_TOOLS} -CONTAINER_CMD ?= docker SHELL := bash build-cli: build-cargo @@ -161,29 +160,29 @@ check-links: # Run the formatter from within a docker image, with the project mounted as a volume fmt-ci: - @${CONTAINER_CMD} pull ${DEV_TOOLS} - @${CONTAINER_CMD} run ${MOUNTED_DEV_TOOLS} make fmt-haskell + docker pull ${DEV_TOOLS} + docker run ${MOUNTED_DEV_TOOLS} make fmt-haskell # Run the fast-lint target with the CI docker container fast-lint-ci: - @${CONTAINER_CMD} pull ${DEV_TOOLS} - @${CONTAINER_CMD} run ${MOUNTED_DEV_TOOLS} make fast-lint-haskell + docker pull ${DEV_TOOLS} + docker run ${MOUNTED_DEV_TOOLS} make fast-lint-haskell # Docker doesn't always check for new versions during build, so pulling ensures # that we always have the latest. check-ci: - @${CONTAINER_CMD} pull ${DEV_TOOLS} - @${CONTAINER_CMD} run ${MOUNTED_DEV_TOOLS} make check-haskell + docker pull ${DEV_TOOLS} + docker run ${MOUNTED_DEV_TOOLS} make check-haskell # Run the fast-check target with the CI docker container fast-check-ci: - @${CONTAINER_CMD} pull ${DEV_TOOLS} - @${CONTAINER_CMD} run ${MOUNTED_DEV_TOOLS} make fast-check + docker pull ${DEV_TOOLS} + docker run ${MOUNTED_DEV_TOOLS} make fast-check # Run bash in the CI edocker container. Useful for debugging make with CI tools. ci-shell: - @${CONTAINER_CMD} pull ${DEV_TOOLS} - @${CONTAINER_CMD} run -it ${MOUNTED_DEV_TOOLS} bash + docker pull ${DEV_TOOLS} + docker run -it ${MOUNTED_DEV_TOOLS} bash # Runs benchmarks bench: From d6afecddd7242c548bd37e95f1c37a931c284e70 Mon Sep 17 00:00:00 2001 From: Christopher Sasarak Date: Tue, 2 Jun 2026 18:36:20 -0500 Subject: [PATCH 09/14] Address compiler warnings --- src/Strategy/Node/Pnpm/PnpmLock.hs | 4 ---- src/Strategy/Node/Pnpm/Types.hs | 2 +- 2 files changed, 1 insertion(+), 5 deletions(-) diff --git a/src/Strategy/Node/Pnpm/PnpmLock.hs b/src/Strategy/Node/Pnpm/PnpmLock.hs index 34d3280b7..83f5e6ac6 100644 --- a/src/Strategy/Node/Pnpm/PnpmLock.hs +++ b/src/Strategy/Node/Pnpm/PnpmLock.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedRecordDot #-} - module Strategy.Node.Pnpm.PnpmLock ( analyze, @@ -50,8 +48,6 @@ import Strategy.Node.Pnpm.Types ( ProjectMapDepMetadata (..), Resolution (..), TarballResolution (..), - SnapshotDepName, - SnapShotDepRev, withoutPeerDepSuffix, ) import Strategy.Node.Pnpm.V4_8 ( diff --git a/src/Strategy/Node/Pnpm/Types.hs b/src/Strategy/Node/Pnpm/Types.hs index f5c8e2b78..88a697ad1 100644 --- a/src/Strategy/Node/Pnpm/Types.hs +++ b/src/Strategy/Node/Pnpm/Types.hs @@ -45,7 +45,7 @@ import DepTypes (DepEnvironment) import Data.HashMap.Strict qualified as HashMap import Data.Map (Map) import Data.Map qualified as Map -import Data.Maybe (fromMaybe, listToMaybe) +import Data.Maybe (listToMaybe) import Data.Set qualified as Set import Data.String.Conversion (toString) import Data.Text (Text) From 8f957b6d48cfbd56187eccc62131b138322ef831 Mon Sep 17 00:00:00 2001 From: Christopher Sasarak Date: Tue, 2 Jun 2026 18:45:38 -0500 Subject: [PATCH 10/14] cleanup --- src/Strategy/Node/Pnpm/Types.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Strategy/Node/Pnpm/Types.hs b/src/Strategy/Node/Pnpm/Types.hs index 88a697ad1..d5f669892 100644 --- a/src/Strategy/Node/Pnpm/Types.hs +++ b/src/Strategy/Node/Pnpm/Types.hs @@ -199,9 +199,6 @@ instance FromJSON PnpmCatalogs where (Map.fromList . HashMap.toList) <$> traverse (withObject "CatalogEntry" (.: "version")) (toHashMapText entries) --- | Resolve a @catalog:name@ version reference using the parsed catalogs section. --- @catalog:@ (empty name) maps to the @default@ catalog. --- @catalog:react19@ maps to the @react19@ catalog. -- -- Snapshots -- From dbcf86a1e7143cadee7fd67430f3937f8819a0e3 Mon Sep 17 00:00:00 2001 From: Christopher Sasarak Date: Wed, 3 Jun 2026 00:13:02 -0500 Subject: [PATCH 11/14] Lint stuff. --- src/Strategy/Node/Pnpm/PnpmLock.hs | 6 +-- src/Strategy/Node/Pnpm/Types.hs | 66 +++++++++++++++--------------- src/Strategy/Node/Pnpm/V4_8.hs | 1 - src/Strategy/Node/Pnpm/V9.hs | 19 +++++---- 4 files changed, 47 insertions(+), 45 deletions(-) diff --git a/src/Strategy/Node/Pnpm/PnpmLock.hs b/src/Strategy/Node/Pnpm/PnpmLock.hs index 83f5e6ac6..85f1b3525 100644 --- a/src/Strategy/Node/Pnpm/PnpmLock.hs +++ b/src/Strategy/Node/Pnpm/PnpmLock.hs @@ -211,8 +211,8 @@ buildGraphCore BuildGraphConfig{bgcGetPkgNameVersion, bgcMkPkgKey, bgcToEnv, bgc -- transitive successors. buildGraph :: PnpmLockfile -> Graphing Dependency buildGraph (LockfileV4Or5 (PnpmLockfileV4Or5 base)) = buildGraphCore buildGraphConfigV4or5 base -buildGraph (LockfileV678 (PnpmLockfileV678 base)) = buildGraphCore buildGraphConfigV678 base -buildGraph (LockfileV9 v) = buildGraphCore (buildGraphConfigV9 v) (lockfileBase v) +buildGraph (LockfileV678 (PnpmLockfileV678 base)) = buildGraphCore buildGraphConfigV678 base +buildGraph (LockfileV9 v) = buildGraphCore (buildGraphConfigV9 v) (lockfileBase v) analyze :: (Has ReadFS sig m, Has Logger sig m, Has Diagnostics sig m) => Path Abs File -> m (Graphing Dependency) analyze file = context "Analyzing Pnpm Lockfile" $ do @@ -226,6 +226,6 @@ analyze file = context "Analyzing Pnpm Lockfile" $ do logWarn . pretty $ "pnpm-lock file is using older lockFileVersion: " <> lockfileRawVersion base <> ", which is not officially supported!" _ -> pure () LockfileV678 _ -> pure () - LockfileV9 _ -> pure () + LockfileV9 _ -> pure () context "Building dependency graph" $ pure $ buildGraph pnpmLockFile diff --git a/src/Strategy/Node/Pnpm/Types.hs b/src/Strategy/Node/Pnpm/Types.hs index d5f669892..f660df6eb 100644 --- a/src/Strategy/Node/Pnpm/Types.hs +++ b/src/Strategy/Node/Pnpm/Types.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedRecordDot #-} module Strategy.Node.Pnpm.Types ( -- * Lockfile types @@ -41,7 +40,6 @@ import Control.Applicative ((<|>)) import Data.Aeson (FromJSON (..), withObject) import Data.Aeson.Extra (TextLike (..)) import Data.Aeson.KeyMap (toHashMapText) -import DepTypes (DepEnvironment) import Data.HashMap.Strict qualified as HashMap import Data.Map (Map) import Data.Map qualified as Map @@ -52,6 +50,7 @@ import Data.Text (Text) import Data.Text qualified as Text import Data.Yaml (Object, Parser, (.!=), (.:), (.:?)) import Data.Yaml qualified as Yaml +import DepTypes (DepEnvironment) -- | Pnpm Lockfile -- @@ -146,7 +145,7 @@ import Data.Yaml qualified as Yaml -- | Shared fields present in all lockfile versions. data PnpmLockfileBase = PnpmLockfileBase { lockfileImporters :: Map Text ProjectMap - , lockfilePackages :: Map Text PackageData + , lockfilePackages :: Map Text PackageData , lockfileRawVersion :: Text -- ^ Raw lockfileVersion string, used for warning about unsupported versions. } @@ -162,9 +161,9 @@ newtype PnpmLockfileV678 = PnpmLockfileV678 PnpmLockfileBase -- | Version-specific extension for v9+ lockfiles. data PnpmLockfileV9 = PnpmLockfileV9 - { lockfileBase :: PnpmLockfileBase + { lockfileBase :: PnpmLockfileBase , lockfileSnapshots :: PnpmLockFileSnapshots - , lockfileCatalogs :: PnpmCatalogs + , lockfileCatalogs :: PnpmCatalogs } deriving (Show, Eq, Ord) @@ -174,8 +173,8 @@ data PnpmLockfileV9 = PnpmLockfileV9 -- carries only the data relevant to its format. data PnpmLockfile = LockfileV4Or5 PnpmLockfileV4Or5 - | LockfileV678 PnpmLockfileV678 - | LockfileV9 PnpmLockfileV9 + | LockfileV678 PnpmLockfileV678 + | LockfileV9 PnpmLockfileV9 deriving (Show, Eq, Ord) -- @@ -341,9 +340,9 @@ classifyVersion (TextLike ver) = case listToMaybe (toString ver) of Just '3' -> pure VersionV4Or5 Just '4' -> pure VersionV4Or5 Just '5' -> pure VersionV4Or5 - Just x | x `elem` ['6', '7', '8'] -> pure VersionV678 + Just x | x `elem` ['6', '7', '8'] -> pure VersionV678 Just '9' -> pure VersionV9 - _ -> fail $ "expected numeric lockfileVersion, got: " <> show ver + _ -> fail $ "expected numeric lockfileVersion, got: " <> show ver -- | Parse the shared base fields (importers + packages) common to all versions. parseBaseLockfile :: TextLike -> Object -> Parser PnpmLockfileBase @@ -357,38 +356,41 @@ parseBaseLockfile (TextLike rawVer) obj = do -- A project without a workspace is the same as having a single workspace at -- the path of \".\". importers <- obj .:? "importers" .!= mempty - packages <- obj .:? "packages" .!= mempty - dependencies <- obj .:? "dependencies" .!= mempty - devDependencies <- obj .:? "devDependencies" .!= mempty + packages <- obj .:? "packages" .!= mempty + dependencies <- obj .:? "dependencies" .!= mempty + devDependencies <- obj .:? "devDependencies" .!= mempty let virtualRootWs = ProjectMap dependencies devDependencies let refinedImporters = if Map.null importers then Map.insert "." virtualRootWs importers else importers - pure $ PnpmLockfileBase - { lockfileImporters = refinedImporters - , lockfilePackages = packages - , lockfileRawVersion = rawVer - } + pure $ + PnpmLockfileBase + { lockfileImporters = refinedImporters + , lockfilePackages = packages + , lockfileRawVersion = rawVer + } -- | FromJSON for the sum type — reads 'lockfileVersion' and dispatches. instance FromJSON PnpmLockfile where parseJSON = Yaml.withObject "pnpm-lock content" $ \obj -> do rawVer <- obj .:? "lockfileVersion" .!= (TextLike mempty) - base <- parseBaseLockfile rawVer obj + base <- parseBaseLockfile rawVer obj versionClass <- classifyVersion rawVer case versionClass of VersionV4Or5 -> pure $ LockfileV4Or5 $ PnpmLockfileV4Or5 base - VersionV678 -> pure $ LockfileV678 $ PnpmLockfileV678 base - VersionV9 -> do + VersionV678 -> pure $ LockfileV678 $ PnpmLockfileV678 base + VersionV9 -> do snapshots <- obj .:? "snapshots" .!= mempty - catalogs <- obj .:? "catalogs" .!= mempty - pure $ LockfileV9 $ PnpmLockfileV9 - { lockfileBase = base - , lockfileSnapshots = snapshots - , lockfileCatalogs = catalogs - } + catalogs <- obj .:? "catalogs" .!= mempty + pure $ + LockfileV9 $ + PnpmLockfileV9 + { lockfileBase = base + , lockfileSnapshots = snapshots + , lockfileCatalogs = catalogs + } -- -- Graph configuration @@ -414,17 +416,17 @@ data LabelingMode = LabelingOff | LabelingOn -- - 'bgcCatalogs': catalog name -> (package name -> resolved version) mappings data BuildGraphConfig = BuildGraphConfig { bgcGetPkgNameVersion :: Text -> Maybe (Text, Text) - -- ^ Parse (name, version) from a package key + -- ^ Parse (name, version) from a package key , bgcMkPkgKey :: Text -> Text -> Text - -- ^ Build a registry package key from (name, version) + -- ^ Build a registry package key from (name, version) , bgcToEnv :: Bool -> Set.Set DepEnvironment - -- ^ Derive environment from @dev@ field (or ignore for v9) + -- ^ Derive environment from @dev@ field (or ignore for v9) , bgcLabelingMode :: LabelingMode - -- ^ Whether to label direct deps for hydrateDepEnvs propagation + -- ^ Whether to label direct deps for hydrateDepEnvs propagation , bgcSnapshotEdges :: [(SnapshotDepName, [(SnapshotDepName, SnapShotDepRev)])] - -- ^ Additional edges from v9 snapshots + -- ^ Additional edges from v9 snapshots , bgcCatalogs :: PnpmCatalogs - -- ^ Catalog name -> (package name -> resolved version) mappings + -- ^ Catalog name -> (package name -> resolved version) mappings } -- diff --git a/src/Strategy/Node/Pnpm/V4_8.hs b/src/Strategy/Node/Pnpm/V4_8.hs index 65860a595..76bec59df 100644 --- a/src/Strategy/Node/Pnpm/V4_8.hs +++ b/src/Strategy/Node/Pnpm/V4_8.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedRecordDot #-} module Strategy.Node.Pnpm.V4_8 ( -- * Key parsers diff --git a/src/Strategy/Node/Pnpm/V9.hs b/src/Strategy/Node/Pnpm/V9.hs index 894682cdc..000af1b45 100644 --- a/src/Strategy/Node/Pnpm/V9.hs +++ b/src/Strategy/Node/Pnpm/V9.hs @@ -21,8 +21,8 @@ import DepTypes (DepEnvironment) import Strategy.Node.Pnpm.Types ( BuildGraphConfig (..), LabelingMode (LabelingOn), - PnpmLockfileV9 (..), PnpmLockFileSnapshots (snapshots), + PnpmLockfileV9 (..), ) import Strategy.Node.Pnpm.V4_8 (parseAtKey) @@ -60,11 +60,12 @@ toEnvEmpty _ = mempty -- -- Snapshot edges come from the lockfile itself, so this is a function. buildGraphConfigV9 :: PnpmLockfileV9 -> BuildGraphConfig -buildGraphConfigV9 lockFile = BuildGraphConfig - { bgcGetPkgNameVersion = getPkgNameVersionV9 - , bgcMkPkgKey = mkPkgKeyV9 - , bgcToEnv = toEnvEmpty - , bgcLabelingMode = LabelingOn - , bgcSnapshotEdges = HashMap.toList lockFile.lockfileSnapshots.snapshots - , bgcCatalogs = lockFile.lockfileCatalogs - } +buildGraphConfigV9 lockFile = + BuildGraphConfig + { bgcGetPkgNameVersion = getPkgNameVersionV9 + , bgcMkPkgKey = mkPkgKeyV9 + , bgcToEnv = toEnvEmpty + , bgcLabelingMode = LabelingOn + , bgcSnapshotEdges = HashMap.toList lockFile.lockfileSnapshots.snapshots + , bgcCatalogs = lockFile.lockfileCatalogs + } From 6414877cd6058ba8aa50bbef3a373f6867e7c6cc Mon Sep 17 00:00:00 2001 From: Christopher Sasarak Date: Mon, 22 Jun 2026 16:35:08 -0500 Subject: [PATCH 12/14] Fix formatting, I hope. --- src/Strategy/Node/Pnpm/PnpmLock.hs | 126 ++++++++++++++++------------- src/Strategy/Node/Pnpm/Types.hs | 1 - src/Strategy/Node/Pnpm/V4_8.hs | 47 +++++------ src/Strategy/Node/Pnpm/V9.hs | 2 +- 4 files changed, 95 insertions(+), 81 deletions(-) diff --git a/src/Strategy/Node/Pnpm/PnpmLock.hs b/src/Strategy/Node/Pnpm/PnpmLock.hs index 85f1b3525..817199662 100644 --- a/src/Strategy/Node/Pnpm/PnpmLock.hs +++ b/src/Strategy/Node/Pnpm/PnpmLock.hs @@ -7,11 +7,11 @@ module Strategy.Node.Pnpm.PnpmLock ( import Control.Applicative ((<|>)) import Control.Effect.Diagnostics (Diagnostics, Has, context) -import Data.Maybe (fromMaybe) import Data.Foldable (for_) import Data.HashMap.Strict qualified as HashMap import Data.Map (Map, toList) import Data.Map qualified as Map +import Data.Maybe (fromMaybe) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as Text @@ -22,13 +22,13 @@ import DepTypes ( VerConstraint (CEq), hydrateDepEnvs, insertEnvironment, - ) + ) import Effect.Grapher (deep, direct, edge, label, run, withLabeling) import Effect.Logger ( Logger, logWarn, pretty, - ) + ) import Effect.ReadFS (ReadFS, readContentsYaml) import Graphing (Graphing) import Graphing qualified @@ -49,11 +49,11 @@ import Strategy.Node.Pnpm.Types ( Resolution (..), TarballResolution (..), withoutPeerDepSuffix, - ) + ) import Strategy.Node.Pnpm.V4_8 ( buildGraphConfigV4or5, buildGraphConfigV678, - ) + ) import Strategy.Node.Pnpm.V9 (buildGraphConfigV9) -- | Label attached to direct dependencies so that hydrateDepEnvs can @@ -67,8 +67,12 @@ newtype PnpmLabel = PnpmEnv DepEnvironment -- -- | Convert a resolved package into a 'Dependency' node. -toDependency :: (Bool -> Set.Set DepEnvironment) - -> Text -> Maybe Text -> PackageData -> Dependency +toDependency :: + (Bool -> Set.Set DepEnvironment) -> + Text -> + Maybe Text -> + PackageData -> + Dependency toDependency toEnv name maybeVersion (PackageData isDev _ (RegistryResolve _) _ _) = toDep toEnv NodeJSType name (withoutPeerDepSuffix . withoutSymConstraint <$> maybeVersion) isDev toDependency toEnv _ _ (PackageData isDev _ (GitResolve (GitResolution url rev)) _ _) = @@ -81,8 +85,13 @@ toDependency toEnv name _ (PackageData isDev Nothing (DirectoryResolve _) _ _) = toDep toEnv UserType name Nothing isDev -- | Construct a 'Dependency' from its components. -toDep :: (Bool -> Set.Set DepEnvironment) - -> DepType -> Text -> Maybe Text -> Bool -> Dependency +toDep :: + (Bool -> Set.Set DepEnvironment) -> + DepType -> + Text -> + Maybe Text -> + Bool -> + Dependency toDep toEnv depType name version isDev = Dependency depType name (CEq <$> version) mempty (toEnv isDev) mempty @@ -124,13 +133,17 @@ withoutLocalPackages = Graphing.shrink (\dep -> dependencyType dep /= UserType) -- -- Non-registry resolvers (tarball, git, directory) use the version value -- directly as the @packages@ key. Registry resolvers use a constructed key. -toResolvedDependency - :: (Bool -> Set.Set DepEnvironment) -- ^ toEnv for this version - -> Map Text PackageData - -> (Text -> Text -> Text) -- ^ mkPkgKey for this version - -> Text -- ^ dependency name - -> Text -- ^ dependency version - -> Maybe Dependency +toResolvedDependency :: + -- | toEnv for this version + (Bool -> Set.Set DepEnvironment) -> + Map Text PackageData -> + -- | mkPkgKey for this version + (Text -> Text -> Text) -> + -- | dependency name + Text -> + -- | dependency version + Text -> + Maybe Dependency toResolvedDependency toEnv pkgs mkPkg depName depVersion = do -- Some versions of the lockfile remove the peer dep suffix. -- Others do not which is why it tries both. @@ -163,44 +176,44 @@ buildGraphCore BuildGraphConfig{bgcGetPkgNameVersion, bgcMkPkgKey, bgcToEnv, bgc catalogs = bgcCatalogs pkgs = lockfilePackages base snapshotEdgesHM = HashMap.fromList snapshotEdges - in withoutLocalPackages . hydrateDepEnvs $ - run . withLabeling applyLabels $ do - -- Direct dependencies from each importer (workspace package). - for_ (toList (lockfileImporters base)) $ \(_, projectImporters) -> do - for_ (Map.toList $ directDependencies projectImporters) $ \(depName, ProjectMapDepMetadata depVersion) -> - let resolvedVersion = resolveCatalogVersion catalogs depName depVersion - in for_ (toResolvedDependency toEnv pkgs mkPkgKey depName resolvedVersion) $ \dep -> do - direct dep - case labelingMode of - LabelingOn -> label dep (PnpmEnv EnvProduction) - LabelingOff -> pure () - - for_ (Map.toList $ directDevDependencies projectImporters) $ \(depName, ProjectMapDepMetadata depVersion) -> - let resolvedVersion = resolveCatalogVersion catalogs depName depVersion - in for_ (toResolvedDependency toEnv pkgs mkPkgKey depName resolvedVersion) $ \dep -> do - direct dep - case labelingMode of - LabelingOn -> label dep (PnpmEnv EnvDevelopment) - LabelingOff -> pure () - - -- Deep dependencies and edges from the packages section. - for_ (toList pkgs) $ \(pkgKey, pkgMeta) -> do - let deepDependencies = - Map.toList (dependencies pkgMeta) - <> Map.toList (peerDependencies pkgMeta) - <> fromMaybe mempty (HashMap.lookup pkgKey snapshotEdgesHM) - - let (depName, depVersion) = case getPkgNameVersion pkgKey of - Nothing -> (pkgKey, Nothing) - Just (name, version) -> (name, Just version) - let parentDep = toDependency toEnv depName depVersion pkgMeta - - -- 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 toEnv pkgs mkPkgKey deepName deepVersion) + in withoutLocalPackages . hydrateDepEnvs $ + run . withLabeling applyLabels $ do + -- Direct dependencies from each importer (workspace package). + for_ (toList (lockfileImporters base)) $ \(_, projectImporters) -> do + for_ (Map.toList $ directDependencies projectImporters) $ \(depName, ProjectMapDepMetadata depVersion) -> + let resolvedVersion = resolveCatalogVersion catalogs depName depVersion + in for_ (toResolvedDependency toEnv pkgs mkPkgKey depName resolvedVersion) $ \dep -> do + direct dep + case labelingMode of + LabelingOn -> label dep (PnpmEnv EnvProduction) + LabelingOff -> pure () + + for_ (Map.toList $ directDevDependencies projectImporters) $ \(depName, ProjectMapDepMetadata depVersion) -> + let resolvedVersion = resolveCatalogVersion catalogs depName depVersion + in for_ (toResolvedDependency toEnv pkgs mkPkgKey depName resolvedVersion) $ \dep -> do + direct dep + case labelingMode of + LabelingOn -> label dep (PnpmEnv EnvDevelopment) + LabelingOff -> pure () + + -- Deep dependencies and edges from the packages section. + for_ (toList pkgs) $ \(pkgKey, pkgMeta) -> do + let deepDependencies = + Map.toList (dependencies pkgMeta) + <> Map.toList (peerDependencies pkgMeta) + <> fromMaybe mempty (HashMap.lookup pkgKey snapshotEdgesHM) + + let (depName, depVersion) = case getPkgNameVersion pkgKey of + Nothing -> (pkgKey, Nothing) + Just (name, version) -> (name, Just version) + let parentDep = toDependency toEnv depName depVersion pkgMeta + + -- 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 toEnv pkgs mkPkgKey deepName deepVersion) -- -- Top-level dispatch @@ -222,8 +235,9 @@ analyze file = context "Analyzing Pnpm Lockfile" $ do case pnpmLockFile of LockfileV4Or5 (PnpmLockfileV4Or5 base) -> case Text.uncons (lockfileRawVersion base) of - Just (c, _) | c `elem` ['1', '2', '3'] -> - logWarn . pretty $ "pnpm-lock file is using older lockFileVersion: " <> lockfileRawVersion base <> ", which is not officially supported!" + Just (c, _) + | c `elem` ['1', '2', '3'] -> + logWarn . pretty $ "pnpm-lock file is using older lockFileVersion: " <> lockfileRawVersion base <> ", which is not officially supported!" _ -> pure () LockfileV678 _ -> pure () LockfileV9 _ -> pure () diff --git a/src/Strategy/Node/Pnpm/Types.hs b/src/Strategy/Node/Pnpm/Types.hs index f660df6eb..9b15b8d68 100644 --- a/src/Strategy/Node/Pnpm/Types.hs +++ b/src/Strategy/Node/Pnpm/Types.hs @@ -1,4 +1,3 @@ - module Strategy.Node.Pnpm.Types ( -- * Lockfile types PnpmLockfileBase (..), diff --git a/src/Strategy/Node/Pnpm/V4_8.hs b/src/Strategy/Node/Pnpm/V4_8.hs index 76bec59df..a4c9d53f7 100644 --- a/src/Strategy/Node/Pnpm/V4_8.hs +++ b/src/Strategy/Node/Pnpm/V4_8.hs @@ -1,4 +1,3 @@ - module Strategy.Node.Pnpm.V4_8 ( -- * Key parsers getPkgNameVersionV5, @@ -39,12 +38,12 @@ parseAtKey slashRequired pkgKey = Nothing | slashRequired -> Nothing Nothing -> Just pkgKey Just txt -> Just txt - >>= \txt -> do - let (nameAndVersion, peerDepInfo) = Text.breakOn "(" txt - let (nameWithSlash, version) = Text.breakOnEnd "@" nameAndVersion - case (Text.stripSuffix "@" nameWithSlash, version) of - (Just name, v) -> Just (name, v <> peerDepInfo) - _ -> Nothing + >>= \txt -> do + let (nameAndVersion, peerDepInfo) = Text.breakOn "(" txt + let (nameWithSlash, version) = Text.breakOnEnd "@" nameAndVersion + case (Text.stripSuffix "@" nameWithSlash, version) of + (Just name, v) -> Just (name, v <> peerDepInfo) + _ -> Nothing -- -- Key parsers @@ -97,22 +96,24 @@ toEnvInline isDev = Set.singleton (if isDev then EnvDevelopment else EnvProducti -- | Config for lockfile versions 4/5. buildGraphConfigV4or5 :: BuildGraphConfig -buildGraphConfigV4or5 = BuildGraphConfig - { bgcGetPkgNameVersion = getPkgNameVersionV5 - , bgcMkPkgKey = mkPkgKeyV5 - , bgcToEnv = toEnvInline - , bgcLabelingMode = LabelingOff - , bgcSnapshotEdges = mempty - , bgcCatalogs = mempty - } +buildGraphConfigV4or5 = + BuildGraphConfig + { bgcGetPkgNameVersion = getPkgNameVersionV5 + , bgcMkPkgKey = mkPkgKeyV5 + , bgcToEnv = toEnvInline + , bgcLabelingMode = LabelingOff + , bgcSnapshotEdges = mempty + , bgcCatalogs = mempty + } -- | Config for lockfile versions 6/7/8. buildGraphConfigV678 :: BuildGraphConfig -buildGraphConfigV678 = BuildGraphConfig - { bgcGetPkgNameVersion = getPkgNameVersionV6 - , bgcMkPkgKey = mkPkgKeyV6 - , bgcToEnv = toEnvInline - , bgcLabelingMode = LabelingOff - , bgcSnapshotEdges = mempty - , bgcCatalogs = mempty - } +buildGraphConfigV678 = + BuildGraphConfig + { bgcGetPkgNameVersion = getPkgNameVersionV6 + , bgcMkPkgKey = mkPkgKeyV6 + , bgcToEnv = toEnvInline + , bgcLabelingMode = LabelingOff + , bgcSnapshotEdges = mempty + , bgcCatalogs = mempty + } diff --git a/src/Strategy/Node/Pnpm/V9.hs b/src/Strategy/Node/Pnpm/V9.hs index 000af1b45..78ba4db3e 100644 --- a/src/Strategy/Node/Pnpm/V9.hs +++ b/src/Strategy/Node/Pnpm/V9.hs @@ -23,7 +23,7 @@ import Strategy.Node.Pnpm.Types ( LabelingMode (LabelingOn), PnpmLockFileSnapshots (snapshots), PnpmLockfileV9 (..), - ) + ) import Strategy.Node.Pnpm.V4_8 (parseAtKey) -- From a7c0156d52d19d6876383e9e735bcfed93c42e03 Mon Sep 17 00:00:00 2001 From: Christopher Sasarak Date: Mon, 29 Jun 2026 17:25:14 -0500 Subject: [PATCH 13/14] Address llm review. --- CLAUDE.md | 8 +++++++- src/Strategy/Node/Pnpm/PnpmLock.hs | 8 ++++---- src/Strategy/Node/Pnpm/Types.hs | 24 ++++++++++++++---------- src/Strategy/Node/Pnpm/V4_8.hs | 21 ++++++++++----------- 4 files changed, 35 insertions(+), 26 deletions(-) diff --git a/CLAUDE.md b/CLAUDE.md index 2a0089682..da1d9ffd1 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -1,6 +1,7 @@ # CLAUDE.md - Guidelines for Fossa CLI ## Build Commands + - Haskell: `cabal build`, `make build-cli` - Rust: `cargo build --release` - Full Build: `make build` (builds both) @@ -12,21 +13,26 @@ - Analyze Project: `make analyze` ## Code Quality Standards + - Compiler warnings should be treated as errors and fixed, not ignored - Linter warnings should be treated as errors and fixed, not ignored - All tests must pass before submitting code - Code should be thoroughly tested with appropriate unit tests ## Code Style Guidelines - Haskell + - GHC Version: 9.8 - Formatting: `fourmolu` with 2 spaces, leading commas - Imports: Use explicit imports, qualified with full names - Types: Prefer `newtype`, use `Text` instead of `String` - Functions: Avoid partial functions, list comprehensions, match guards - Error handling: Never use `error` or `undefined` -- **Tests**: Partial functions (`head`, `tail`, `!!`, etc.) are acceptable in test code. +- **Tests**: A narrow set of partial functions is allowed in `**.*Spec` modules + as configured in `.hlint.yaml` (`head`, `tail`, `last`, `!!`, + `Data.List.NonEmpty.fromList`). Use them sparingly and prefer safe alternatives. ## Code Style Guidelines - Rust + - Format with `rustfmt` via `cargo fmt` - Lint with Clippy via `cargo clippy` - Follow standard Rust idioms including error handling diff --git a/src/Strategy/Node/Pnpm/PnpmLock.hs b/src/Strategy/Node/Pnpm/PnpmLock.hs index 817199662..2fa7b3f96 100644 --- a/src/Strategy/Node/Pnpm/PnpmLock.hs +++ b/src/Strategy/Node/Pnpm/PnpmLock.hs @@ -149,11 +149,11 @@ toResolvedDependency toEnv pkgs mkPkg depName depVersion = do -- Others do not which is why it tries both. let strippedVersion = withoutPeerDepSuffix depVersion let maybeNonRegistrySrcPackage = - Map.lookup strippedVersion pkgs - <|> Map.lookup depVersion pkgs + Map.lookup depVersion pkgs + <|> Map.lookup strippedVersion pkgs let maybeRegistrySrcPackage = - fmap (strippedVersion,) (Map.lookup (mkPkg depName strippedVersion) pkgs) - <|> fmap (depVersion,) (Map.lookup (mkPkg depName depVersion) pkgs) + fmap (depVersion,) (Map.lookup (mkPkg depName depVersion) pkgs) + <|> fmap (strippedVersion,) (Map.lookup (mkPkg depName strippedVersion) pkgs) case (maybeNonRegistrySrcPackage, maybeRegistrySrcPackage) of (Nothing, Nothing) -> Nothing (Just nonRegistryPkg, _) -> diff --git a/src/Strategy/Node/Pnpm/Types.hs b/src/Strategy/Node/Pnpm/Types.hs index 9b15b8d68..c31139584 100644 --- a/src/Strategy/Node/Pnpm/Types.hs +++ b/src/Strategy/Node/Pnpm/Types.hs @@ -39,10 +39,11 @@ import Control.Applicative ((<|>)) import Data.Aeson (FromJSON (..), withObject) import Data.Aeson.Extra (TextLike (..)) import Data.Aeson.KeyMap (toHashMapText) +import Data.Char (isDigit) import Data.HashMap.Strict qualified as HashMap import Data.Map (Map) import Data.Map qualified as Map -import Data.Maybe (listToMaybe) +import Text.Read (readMaybe) import Data.Set qualified as Set import Data.String.Conversion (toString) import Data.Text (Text) @@ -332,16 +333,19 @@ data VersionClassifier deriving (Show, Eq, Ord) -- | Classify the lockfile version string. +-- +-- >> classifyVersion (TextLike "5.4") = VersionV4Or5 +-- >> classifyVersion (TextLike "9.0") = VersionV9 +-- >> classifyVersion (TextLike "10.0") = VersionV9 classifyVersion :: TextLike -> Parser VersionClassifier -classifyVersion (TextLike ver) = case listToMaybe (toString ver) of - Just '1' -> pure VersionV4Or5 - Just '2' -> pure VersionV4Or5 - Just '3' -> pure VersionV4Or5 - Just '4' -> pure VersionV4Or5 - Just '5' -> pure VersionV4Or5 - Just x | x `elem` ['6', '7', '8'] -> pure VersionV678 - Just '9' -> pure VersionV9 - _ -> fail $ "expected numeric lockfileVersion, got: " <> show ver +classifyVersion (TextLike ver) = + case readMaybe (toString (Text.takeWhile isDigit ver)) :: Maybe Int of + Nothing -> fail $ "expected numeric lockfileVersion, got: " <> show ver + Just v + | v >= 1 && v <= 5 -> pure VersionV4Or5 + | v >= 6 && v <= 8 -> pure VersionV678 + | v >= 9 -> pure VersionV9 + | otherwise -> fail $ "unsupported lockfileVersion: " <> show ver -- | Parse the shared base fields (importers + packages) common to all versions. parseBaseLockfile :: TextLike -> Object -> Parser PnpmLockfileBase diff --git a/src/Strategy/Node/Pnpm/V4_8.hs b/src/Strategy/Node/Pnpm/V4_8.hs index a4c9d53f7..7ef47be18 100644 --- a/src/Strategy/Node/Pnpm/V4_8.hs +++ b/src/Strategy/Node/Pnpm/V4_8.hs @@ -33,17 +33,16 @@ import Strategy.Node.Pnpm.Types (BuildGraphConfig (..), LabelingMode (LabelingOf -- >> parseAtKey False "pkg-a@1.0.0" = Just ("pkg-a", "1.0.0") -- >> parseAtKey True "pkg-a@1.0.0" = Nothing parseAtKey :: Bool -> Text -> Maybe (Text, Text) -parseAtKey slashRequired pkgKey = - case Text.stripPrefix "/" pkgKey of - Nothing | slashRequired -> Nothing - Nothing -> Just pkgKey - Just txt -> Just txt - >>= \txt -> do - let (nameAndVersion, peerDepInfo) = Text.breakOn "(" txt - let (nameWithSlash, version) = Text.breakOnEnd "@" nameAndVersion - case (Text.stripSuffix "@" nameWithSlash, version) of - (Just name, v) -> Just (name, v <> peerDepInfo) - _ -> Nothing +parseAtKey slashRequired pkgKey = do + txt <- case Text.stripPrefix "/" pkgKey of + Nothing | slashRequired -> Nothing + Nothing -> Just pkgKey + Just txt -> Just txt + let (nameAndVersion, peerDepInfo) = Text.breakOn "(" txt + let (nameWithSlash, version) = Text.breakOnEnd "@" nameAndVersion + case (Text.stripSuffix "@" nameWithSlash, version) of + (Just name, v) -> Just (name, v <> peerDepInfo) + _ -> Nothing -- -- Key parsers From 765569b2fa370098cb8554b2f9c80d11c33399d5 Mon Sep 17 00:00:00 2001 From: Christopher Sasarak Date: Tue, 30 Jun 2026 16:11:53 -0500 Subject: [PATCH 14/14] fmt --- src/Strategy/Node/Pnpm/Types.hs | 6 +++--- src/Strategy/Node/Pnpm/V4_8.hs | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Strategy/Node/Pnpm/Types.hs b/src/Strategy/Node/Pnpm/Types.hs index c31139584..a2a93e73d 100644 --- a/src/Strategy/Node/Pnpm/Types.hs +++ b/src/Strategy/Node/Pnpm/Types.hs @@ -43,7 +43,6 @@ import Data.Char (isDigit) import Data.HashMap.Strict qualified as HashMap import Data.Map (Map) import Data.Map qualified as Map -import Text.Read (readMaybe) import Data.Set qualified as Set import Data.String.Conversion (toString) import Data.Text (Text) @@ -51,6 +50,7 @@ import Data.Text qualified as Text import Data.Yaml (Object, Parser, (.!=), (.:), (.:?)) import Data.Yaml qualified as Yaml import DepTypes (DepEnvironment) +import Text.Read (readMaybe) -- | Pnpm Lockfile -- @@ -344,8 +344,8 @@ classifyVersion (TextLike ver) = Just v | v >= 1 && v <= 5 -> pure VersionV4Or5 | v >= 6 && v <= 8 -> pure VersionV678 - | v >= 9 -> pure VersionV9 - | otherwise -> fail $ "unsupported lockfileVersion: " <> show ver + | v >= 9 -> pure VersionV9 + | otherwise -> fail $ "unsupported lockfileVersion: " <> show ver -- | Parse the shared base fields (importers + packages) common to all versions. parseBaseLockfile :: TextLike -> Object -> Parser PnpmLockfileBase diff --git a/src/Strategy/Node/Pnpm/V4_8.hs b/src/Strategy/Node/Pnpm/V4_8.hs index 7ef47be18..5a71557ef 100644 --- a/src/Strategy/Node/Pnpm/V4_8.hs +++ b/src/Strategy/Node/Pnpm/V4_8.hs @@ -35,9 +35,9 @@ import Strategy.Node.Pnpm.Types (BuildGraphConfig (..), LabelingMode (LabelingOf parseAtKey :: Bool -> Text -> Maybe (Text, Text) parseAtKey slashRequired pkgKey = do txt <- case Text.stripPrefix "/" pkgKey of - Nothing | slashRequired -> Nothing - Nothing -> Just pkgKey - Just txt -> Just txt + Nothing | slashRequired -> Nothing + Nothing -> Just pkgKey + Just txt -> Just txt let (nameAndVersion, peerDepInfo) = Text.breakOn "(" txt let (nameWithSlash, version) = Text.breakOnEnd "@" nameAndVersion case (Text.stripSuffix "@" nameWithSlash, version) of