diff --git a/CLAUDE.md b/CLAUDE.md index ddb33d803..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,23 +13,29 @@ - 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**: 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 - 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 7a98380da..2fa7b3f96 100644 --- a/src/Strategy/Node/Pnpm/PnpmLock.hs +++ b/src/Strategy/Node/Pnpm/PnpmLock.hs @@ -1,31 +1,20 @@ -{-# LANGUAGE OverloadedRecordDot #-} - module Strategy.Node.Pnpm.PnpmLock ( analyze, -- * for testing buildGraph, -) -where +) 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) 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.Maybe qualified as Maybe +import Data.Maybe (fromMaybe) 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), @@ -44,127 +33,80 @@ 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 (..), + PnpmCatalogs (..), + PnpmLockfile (..), + PnpmLockfileBase (..), + PnpmLockfileV4Or5 (..), + PnpmLockfileV678 (..), + PnpmLockfileV9 (..), + ProjectMap (..), + ProjectMapDepMetadata (..), + 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 +-- 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) --- | 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: --- ----------------------------------------------------- +-- Shared helpers (version-independent) -- --- * `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) -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 - } - 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) +-- | 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 --- | 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. +-- | 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 = @@ -172,379 +114,132 @@ resolveCatalogVersion (PnpmCatalogs cats) depName ver in fromMaybe ver $ Map.lookup name cats >>= Map.lookup depName | otherwise = ver -type SnapshotDepName = Text +-- | Apply accumulated labels to transform a graph node. +applyLabels :: Dependency -> Set.Set PnpmLabel -> Dependency +applyLabels = foldr applyLabel + where + applyLabel (PnpmEnv env) = insertEnvironment env -type SnapShotDepRev = Text +-- | Strip local (file:) packages from the final graph. +withoutLocalPackages :: Graphing Dependency -> Graphing Dependency +withoutLocalPackages = Graphing.shrink (\dep -> dependencyType dep /= UserType) --- | Lockfile versions > 9 use snapshots to represent the dependency graph. --- Example: --- snapshots: --- --- colorjs@0.1.9: {} -- --- punycode@2.3.1: {} +-- Resolved dependency lookup -- --- 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'} - -data PnpmLockFileVersion - = PnpmLockLt4 Text - | PnpmLock4Or5 - | PnpmLockV678 Text - | PnpmLockV9 - deriving (Show, Eq, Ord) - -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) - -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) +-- | 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 :: + -- | 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. + let strippedVersion = withoutPeerDepSuffix depVersion + let maybeNonRegistrySrcPackage = + Map.lookup depVersion pkgs + <|> Map.lookup strippedVersion pkgs + let maybeRegistrySrcPackage = + 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, _) -> + Just $ toDependency toEnv depName Nothing nonRegistryPkg + (Nothing, Just (version, registryPkg)) -> + Just $ toDependency toEnv depName (Just version) registryPkg -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" +-- +-- Shared graph-building loop +-- - registryRes :: Object -> Parser Resolution - registryRes obj = RegistryResolve . RegistryResolution <$> obj .: "integrity" +-- | Core graph-building logic shared across all lockfile versions. +buildGraphCore :: BuildGraphConfig -> PnpmLockfileBase -> Graphing Dependency +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 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) - tarballRes :: Object -> Parser Resolution - tarballRes obj = TarballResolve . TarballResolution <$> obj .: "tarball" +-- +-- Top-level dispatch +-- - gitRes :: Object -> Parser Resolution - gitRes obj = GitResolve <$> (GitResolution <$> obj .: "repo" <*> obj .: "commit") +-- | 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 (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 Npm Lockfile (v3)" $ do +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 - --- 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. --- --- >> 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..a2a93e73d --- /dev/null +++ b/src/Strategy/Node/Pnpm/Types.hs @@ -0,0 +1,444 @@ +module Strategy.Node.Pnpm.Types ( + -- * Lockfile types + PnpmLockfileBase (..), + PnpmLockfileV4Or5 (..), + PnpmLockfileV678 (..), + PnpmLockfileV9 (..), + PnpmLockfile (..), + + -- * Catalogs + PnpmCatalogs (..), + + -- * Snapshots + SnapshotDepName, + SnapShotDepRev, + PnpmLockFileSnapshots (..), + + -- * Project map + ProjectMap (..), + ProjectMapDepMetadata (..), + + -- * Package data + PackageData (..), + Resolution (..), + GitResolution (..), + TarballResolution (..), + RegistryResolution (..), + DirectoryResolution (..), + + -- * 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 Data.Char (isDigit) +import Data.HashMap.Strict qualified as HashMap +import Data.Map (Map) +import Data.Map qualified as Map +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) +import Text.Read (readMaybe) + +-- | 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) + +-- +-- 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 "5.4") = VersionV4Or5 +-- >> classifyVersion (TextLike "9.0") = VersionV9 +-- >> classifyVersion (TextLike "10.0") = VersionV9 +classifyVersion :: TextLike -> Parser VersionClassifier +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 +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..5a71557ef --- /dev/null +++ b/src/Strategy/Node/Pnpm/V4_8.hs @@ -0,0 +1,118 @@ +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 = 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 +-- + +-- | 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..78ba4db3e --- /dev/null +++ b/src/Strategy/Node/Pnpm/V9.hs @@ -0,0 +1,71 @@ +{-# 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), + PnpmLockFileSnapshots (snapshots), + PnpmLockfileV9 (..), + ) +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 + }