|
| 1 | +{-# LANGUAGE OverloadedRecordDot #-} |
| 2 | + |
| 3 | +module Strategy.Node.Bun.BunLock ( |
| 4 | + analyze, |
| 5 | + parseBunLock, |
| 6 | + buildGraph, |
| 7 | + BunLockFile (..), |
| 8 | + BunWorkspace (..), |
| 9 | + BunPackage (..), |
| 10 | +) |
| 11 | +where |
| 12 | + |
| 13 | +import Control.Algebra (run) |
| 14 | +import Control.Effect.Diagnostics (Diagnostics, Has, context, fatal) |
| 15 | +import Data.Aeson ( |
| 16 | + FromJSON (parseJSON), |
| 17 | + Result (..), |
| 18 | + Value (..), |
| 19 | + eitherDecodeStrict, |
| 20 | + fromJSON, |
| 21 | + withArray, |
| 22 | + withObject, |
| 23 | + (.!=), |
| 24 | + (.:), |
| 25 | + (.:?), |
| 26 | + ) |
| 27 | +import Data.Aeson.KeyMap qualified as KM |
| 28 | +import Data.Foldable (for_) |
| 29 | +import Data.Map (Map) |
| 30 | +import Data.Map qualified as Map |
| 31 | +import Data.Set qualified as Set |
| 32 | +import Data.String.Conversion (encodeUtf8, toText) |
| 33 | +import Data.Text (Text) |
| 34 | +import Data.Text qualified as Text |
| 35 | +import Data.Vector qualified as V |
| 36 | +import DepTypes (DepEnvironment (..), DepType (NodeJSType), Dependency (..), VerConstraint (CEq)) |
| 37 | +import Effect.Grapher (deep, direct, edge, evalGrapher) |
| 38 | +import Effect.ReadFS (ReadFS, ReadFSErr (FileParseError), readContentsText) |
| 39 | +import Graphing (Graphing) |
| 40 | +import Graphing qualified |
| 41 | +import Path (Abs, File, Path) |
| 42 | + |
| 43 | +-- | Bun Lockfile structure |
| 44 | +-- Bun lockfile (bun.lock) is a JSONC format with the following shape: |
| 45 | +-- |
| 46 | +-- @ |
| 47 | +-- > { |
| 48 | +-- > "lockfileVersion": 1, |
| 49 | +-- > "workspaces": { |
| 50 | +-- > "": { |
| 51 | +-- > "name": "my-project", |
| 52 | +-- > "dependencies": { |
| 53 | +-- > "lodash": "^4.17.21" |
| 54 | +-- > }, |
| 55 | +-- > "devDependencies": { |
| 56 | +-- > "typescript": "^5.0.0" |
| 57 | +-- > } |
| 58 | +-- > } |
| 59 | +-- > }, |
| 60 | +-- > "packages": { |
| 61 | +-- > "lodash": ["lodash@4.17.21", "", {}, "sha512-xxx"], |
| 62 | +-- > "typescript": ["typescript@5.3.3", "", {"bin": {"tsc": "bin/tsc"}}, "sha512-yyy"] |
| 63 | +-- > } |
| 64 | +-- > } |
| 65 | +-- @ |
| 66 | +-- |
| 67 | +-- In this file: |
| 68 | +-- * `lockfileVersion`: Version of the lockfile format |
| 69 | +-- * `workspaces`: Map of workspace configurations |
| 70 | +-- * Key (e.g. "") refers to workspace path |
| 71 | +-- * `name`: Workspace name |
| 72 | +-- * `dependencies`: Direct production dependencies |
| 73 | +-- * `devDependencies`: Direct development dependencies |
| 74 | +-- * `packages`: Map of all resolved packages |
| 75 | +-- * Key: Package name (e.g. "lodash") |
| 76 | +-- * Value: Array [resolution, registry, info, integrity] |
| 77 | +-- - resolution: Package@version string |
| 78 | +-- - registry: Registry URL (empty string for npm) |
| 79 | +-- - info: Object with optional bin, scripts, etc. |
| 80 | +-- - integrity: SHA512 hash |
| 81 | + |
| 82 | +data BunLockFile = BunLockFile |
| 83 | + { lockfileVersion :: Int |
| 84 | + , workspaces :: Map Text BunWorkspace |
| 85 | + , packages :: Map Text BunPackage |
| 86 | + } |
| 87 | + deriving (Show, Eq) |
| 88 | + |
| 89 | +data BunWorkspace = BunWorkspace |
| 90 | + { name :: Text |
| 91 | + , dependencies :: Map Text Text |
| 92 | + , devDependencies :: Map Text Text |
| 93 | + } |
| 94 | + deriving (Show, Eq, Ord) |
| 95 | + |
| 96 | +data BunPackage = BunPackage |
| 97 | + { resolution :: Text |
| 98 | + , registry :: Text |
| 99 | + , info :: Value |
| 100 | + , integrity :: Text |
| 101 | + } |
| 102 | + deriving (Show, Eq) |
| 103 | + |
| 104 | +-- | FromJSON instance for BunLockFile |
| 105 | +-- Parses the top-level bun.lock structure |
| 106 | +instance FromJSON BunLockFile where |
| 107 | + parseJSON = withObject "BunLockFile" $ \obj -> |
| 108 | + BunLockFile |
| 109 | + <$> obj .: "lockfileVersion" |
| 110 | + <*> obj .:? "workspaces" .!= mempty |
| 111 | + <*> obj .:? "packages" .!= mempty |
| 112 | + |
| 113 | +-- | FromJSON instance for BunWorkspace |
| 114 | +-- Parses workspace configuration |
| 115 | +instance FromJSON BunWorkspace where |
| 116 | + parseJSON = withObject "BunWorkspace" $ \obj -> |
| 117 | + BunWorkspace |
| 118 | + <$> obj .:? "name" .!= "" |
| 119 | + <*> obj .:? "dependencies" .!= mempty |
| 120 | + <*> obj .:? "devDependencies" .!= mempty |
| 121 | + |
| 122 | +-- | FromJSON instance for BunPackage |
| 123 | +-- Parses the array format: [resolution, registry, info, integrity] |
| 124 | +instance FromJSON BunPackage where |
| 125 | + parseJSON = withArray "BunPackage" $ \arr -> do |
| 126 | + let vec = V.toList arr |
| 127 | + case vec of |
| 128 | + [resVal, regVal, infoVal, integrityVal] -> do |
| 129 | + res <- parseJSON resVal |
| 130 | + reg <- parseJSON regVal |
| 131 | + info' <- parseJSON infoVal |
| 132 | + integrity' <- parseJSON integrityVal |
| 133 | + pure $ BunPackage res reg info' integrity' |
| 134 | + _ -> fail $ "Expected array with 4 elements, got " ++ show (length vec) |
| 135 | + |
| 136 | +-- | Parse a bun.lock file |
| 137 | +-- Bun lockfiles use JSONC format (JSON with comments) |
| 138 | +-- This function strips comments before parsing |
| 139 | +parseBunLock :: |
| 140 | + (Has ReadFS sig m, Has Diagnostics sig m) => |
| 141 | + Path Abs File -> |
| 142 | + m BunLockFile |
| 143 | +parseBunLock file = context ("Parsing bun.lock file '" <> toText (show file) <> "'") $ do |
| 144 | + contents <- readContentsText file |
| 145 | + let stripped = stripJsoncComments contents |
| 146 | + bs = encodeUtf8 stripped |
| 147 | + case eitherDecodeStrict bs of |
| 148 | + Left err -> fatal $ FileParseError (show file) (toText err) |
| 149 | + Right lockFile -> pure lockFile |
| 150 | + |
| 151 | +-- | Convert JSONC to valid JSON |
| 152 | +-- JSONC (JSON with Comments) allows: |
| 153 | +-- 1. Single-line comments starting with // |
| 154 | +-- 2. Trailing commas before } or ] |
| 155 | +-- |
| 156 | +-- This function strips both to produce valid JSON |
| 157 | +stripJsoncComments :: Text -> Text |
| 158 | +stripJsoncComments input = removeTrailingCommas $ Text.unlines $ map processLine $ Text.lines input |
| 159 | + where |
| 160 | + -- Process a single line: strip comments |
| 161 | + processLine :: Text -> Text |
| 162 | + processLine line = |
| 163 | + let stripped = Text.stripStart line |
| 164 | + in if "//" `Text.isPrefixOf` stripped |
| 165 | + then "" |
| 166 | + else stripInlineComment line |
| 167 | + |
| 168 | + -- Strip inline comments (// outside of strings) |
| 169 | + stripInlineComment :: Text -> Text |
| 170 | + stripInlineComment = go False |
| 171 | + where |
| 172 | + go :: Bool -> Text -> Text |
| 173 | + go _ t | Text.null t = t |
| 174 | + go inString t = |
| 175 | + case Text.uncons t of |
| 176 | + Nothing -> t |
| 177 | + Just ('"', rest) |
| 178 | + | not inString -> "\"" <> go True rest |
| 179 | + | otherwise -> "\"" <> go False rest |
| 180 | + Just ('\\', rest) |
| 181 | + | inString -> |
| 182 | + -- Escaped char in string, take next char too |
| 183 | + case Text.uncons rest of |
| 184 | + Just (c, rest') -> "\\" <> Text.singleton c <> go True rest' |
| 185 | + Nothing -> "\\" |
| 186 | + | otherwise -> "\\" <> go inString rest |
| 187 | + Just ('/', rest) |
| 188 | + | not inString -> |
| 189 | + case Text.uncons rest of |
| 190 | + Just ('/', _) -> "" -- Comment found, strip rest of line |
| 191 | + _ -> "/" <> go inString rest |
| 192 | + | otherwise -> "/" <> go inString rest |
| 193 | + Just (c, rest) -> Text.singleton c <> go inString rest |
| 194 | + |
| 195 | + -- Remove trailing commas before } or ] |
| 196 | + -- Pattern: comma followed by optional whitespace then } or ] |
| 197 | + removeTrailingCommas :: Text -> Text |
| 198 | + removeTrailingCommas = go False |
| 199 | + where |
| 200 | + go :: Bool -> Text -> Text |
| 201 | + go _ t | Text.null t = t |
| 202 | + go inString t = |
| 203 | + case Text.uncons t of |
| 204 | + Nothing -> t |
| 205 | + Just ('"', rest) |
| 206 | + | not inString -> "\"" <> go True rest |
| 207 | + | otherwise -> "\"" <> go False rest |
| 208 | + Just ('\\', rest) |
| 209 | + | inString -> |
| 210 | + case Text.uncons rest of |
| 211 | + Just (c, rest') -> "\\" <> Text.singleton c <> go True rest' |
| 212 | + Nothing -> "\\" |
| 213 | + | otherwise -> "\\" <> go inString rest |
| 214 | + Just (',', rest) |
| 215 | + | not inString -> |
| 216 | + -- Check if this comma is followed by whitespace then } or ] |
| 217 | + let afterWs = Text.dropWhile (`elem` [' ', '\t', '\n', '\r']) rest |
| 218 | + in case Text.uncons afterWs of |
| 219 | + Just ('}', _) -> go False rest -- Skip the comma |
| 220 | + Just (']', _) -> go False rest -- Skip the comma |
| 221 | + _ -> "," <> go False rest -- Keep the comma |
| 222 | + | otherwise -> "," <> go inString rest |
| 223 | + Just (c, rest) -> Text.singleton c <> go inString rest |
| 224 | + |
| 225 | +-- | Build a dependency graph from a parsed bun lockfile |
| 226 | +-- |
| 227 | +-- The graph building process: |
| 228 | +-- 1. Iterate over all workspaces to mark direct dependencies |
| 229 | +-- 2. For each workspace dependency, look up the resolved package and mark as direct |
| 230 | +-- 3. Dev dependencies are marked with EnvDevelopment, production with EnvProduction |
| 231 | +-- 4. Iterate over all packages to add deep dependencies and edges |
| 232 | +-- 5. Extract transitive dependencies from package info and create edges |
| 233 | +buildGraph :: BunLockFile -> Graphing Dependency |
| 234 | +buildGraph lockFile = run . evalGrapher $ do |
| 235 | + -- Collect all dev dependency names from all workspaces |
| 236 | + let devDepNames = Set.fromList $ concatMap (Map.keys . devDependencies) (Map.elems lockFile.workspaces) |
| 237 | + |
| 238 | + -- Process all workspaces for direct dependencies |
| 239 | + for_ (Map.elems lockFile.workspaces) $ \workspace -> do |
| 240 | + -- Production dependencies |
| 241 | + for_ (Map.keys workspace.dependencies) $ \depName -> do |
| 242 | + case Map.lookup depName lockFile.packages of |
| 243 | + Nothing -> pure () |
| 244 | + Just pkg -> direct $ packageToDep pkg False |
| 245 | + |
| 246 | + -- Dev dependencies |
| 247 | + for_ (Map.keys workspace.devDependencies) $ \depName -> do |
| 248 | + case Map.lookup depName lockFile.packages of |
| 249 | + Nothing -> pure () |
| 250 | + Just pkg -> direct $ packageToDep pkg True |
| 251 | + |
| 252 | + -- Process all packages for deep dependencies and edges |
| 253 | + for_ (Map.toList lockFile.packages) $ \(_, pkg) -> do |
| 254 | + let isDev = isDevDep devDepNames pkg |
| 255 | + parentDep = packageToDep pkg isDev |
| 256 | + |
| 257 | + -- Add as deep dependency |
| 258 | + deep parentDep |
| 259 | + |
| 260 | + -- Extract dependencies from info and create edges |
| 261 | + let pkgDeps = extractDependencies pkg.info |
| 262 | + for_ (Map.keys pkgDeps) $ \childName -> do |
| 263 | + case Map.lookup childName lockFile.packages of |
| 264 | + Nothing -> pure () |
| 265 | + Just childPkg -> do |
| 266 | + let childDep = packageToDep childPkg (isDevDep devDepNames childPkg) |
| 267 | + edge parentDep childDep |
| 268 | + where |
| 269 | + -- Check if a package is a dev dependency based on the collected dev dep names |
| 270 | + isDevDep :: Set.Set Text -> BunPackage -> Bool |
| 271 | + isDevDep devNames pkg = |
| 272 | + let (name, _) = parseResolution pkg.resolution |
| 273 | + in Set.member name devNames |
| 274 | + |
| 275 | +-- | Convert a BunPackage to a Dependency |
| 276 | +packageToDep :: BunPackage -> Bool -> Dependency |
| 277 | +packageToDep pkg isDev = |
| 278 | + let (name, version) = parseResolution pkg.resolution |
| 279 | + env = if isDev then EnvDevelopment else EnvProduction |
| 280 | + in Dependency |
| 281 | + { dependencyType = NodeJSType |
| 282 | + , dependencyName = name |
| 283 | + , dependencyVersion = Just (CEq version) |
| 284 | + , dependencyLocations = mempty |
| 285 | + , dependencyEnvironments = Set.singleton env |
| 286 | + , dependencyTags = mempty |
| 287 | + } |
| 288 | + |
| 289 | +-- | Parse resolution string "name@version" or "@scope/name@version" |
| 290 | +-- |
| 291 | +-- >>> parseResolution "lodash@4.17.21" |
| 292 | +-- ("lodash", "4.17.21") |
| 293 | +-- |
| 294 | +-- >>> parseResolution "@angular/core@16.0.0" |
| 295 | +-- ("@angular/core", "16.0.0") |
| 296 | +parseResolution :: Text -> (Text, Text) |
| 297 | +parseResolution res |
| 298 | + | "@" `Text.isPrefixOf` res = |
| 299 | + -- Scoped package: @scope/name@version |
| 300 | + let withoutAt = Text.drop 1 res |
| 301 | + (scopeAndName, rest) = Text.breakOn "@" withoutAt |
| 302 | + in ("@" <> scopeAndName, Text.drop 1 rest) |
| 303 | + | otherwise = |
| 304 | + -- Regular package: name@version |
| 305 | + let (name, rest) = Text.breakOn "@" res |
| 306 | + in (name, Text.drop 1 rest) |
| 307 | + |
| 308 | +-- | Extract dependencies map from package info Value |
| 309 | +-- The info object may contain a "dependencies" key with a map of dep name to version spec |
| 310 | +extractDependencies :: Value -> Map Text Text |
| 311 | +extractDependencies (Object obj) = |
| 312 | + case KM.lookup "dependencies" obj of |
| 313 | + Just depsVal -> |
| 314 | + case fromJSON depsVal of |
| 315 | + Success deps -> deps |
| 316 | + Error _ -> mempty |
| 317 | + Nothing -> mempty |
| 318 | +extractDependencies _ = mempty |
| 319 | + |
| 320 | +-- | Filter out workspace packages from the dependency graph |
| 321 | +-- Workspace packages are internal packages in a monorepo and should not be included |
| 322 | +-- in the final dependency graph |
| 323 | +filterWorkspaces :: BunLockFile -> Graphing Dependency -> Graphing Dependency |
| 324 | +filterWorkspaces lockFile = |
| 325 | + let workspaceNames = Set.fromList $ map name (Map.elems lockFile.workspaces) |
| 326 | + in Graphing.shrink (\dep -> not (Set.member (dependencyName dep) workspaceNames)) |
| 327 | + |
| 328 | +-- | Analyze a bun.lock file and produce a dependency graph |
| 329 | +analyze :: |
| 330 | + (Has ReadFS sig m, Has Diagnostics sig m) => |
| 331 | + Path Abs File -> |
| 332 | + m (Graphing Dependency) |
| 333 | +analyze file = do |
| 334 | + lockfile <- parseBunLock file |
| 335 | + pure $ filterWorkspaces lockfile $ buildGraph lockfile |
0 commit comments