Replace fast-glob with custom fs.walk (#1210)

Fixes #1182

This implementation is using `micromatch` (a dependency of fast-glob)
and `fs.walk` to traverse the file system itself, instead of relying on fast-glob.
As opposed to the previous implementation (from #1209) This implementation takes
every .gitignore file into account, not just the root one.
The callbacks `entryFilter` and `deepFilter` are used to control which
directories to recurse into. When `entryFilter` encounters a .gitignore
file, it's patterns are parsed into micromatch compatible ones and every
subsequent call to these filter functions respect them.

package.json

@@ -41,6 +41,7 @@
     "fuse.js": "^6.5.3",
     "glob": "^7.1.6",
     "markdown-it": "^12.0.4",
+    "micromatch": "^4.0.5",
     "open": "^9.1.0",
     "punycode": "^2.3.0",
     "semver": "^7.3.5",

src/Spago/Config.purs

@@ -51,20 +51,19 @@ import Effect.Aff as Aff
 import Effect.Uncurried (EffectFn2, EffectFn3, runEffectFn2, runEffectFn3)
 import Foreign.Object as Foreign
 import Node.Path as Path
-import Registry.Foreign.FastGlob as Glob
 import Registry.Internal.Codec as Internal.Codec
 import Registry.PackageName as PackageName
 import Registry.PackageSet as Registry.PackageSet
 import Registry.Range as Range
 import Registry.Version as Version
 import Spago.Core.Config as Core
 import Spago.FS as FS
-import Spago.Git as Git
 import Spago.Lock (Lockfile, PackageSetInfo)
 import Spago.Lock as Lock
 import Spago.Paths as Paths
 import Spago.Registry as Registry
 import Spago.Yaml as Yaml
+import Spago.Glob as Glob
 
 type Workspace =
   { selected :: Maybe WorkspacePackage
@@ -163,31 +162,6 @@ type ReadWorkspaceOptions =
   , migrateConfig :: Boolean
   }
 
--- | Same as `Glob.match'` but if there is a .gitignore file in the same directory,
--- | then the `ignore` option will be filled accordingly.
--- | This function does not respect any .gitignore files in subdirectories.
--- | Translation of: https://github.com/sindresorhus/globby/issues/50#issuecomment-467897064
-gitIgnoringGlob :: String -> Array String -> Spago (LogEnv _) { failed :: Array String, succeeded :: Array String }
-gitIgnoringGlob dir patterns = do
-  gitignore <- try (liftAff $ FS.readTextFile $ Path.concat [ dir, ".gitignore" ]) >>= case _ of
-    Left err -> do
-      logDebug $ "Could not read .gitignore to exclude directories from globbing, error: " <> Aff.message err
-      pure ""
-    Right contents -> pure contents
-  let
-    isComment = isJust <<< String.stripPrefix (String.Pattern "#")
-    dropPrefixSlashes line = maybe line dropPrefixSlashes $ String.stripPrefix (String.Pattern "/") line
-    dropSuffixSlashes line = maybe line dropSuffixSlashes $ String.stripSuffix (String.Pattern "/") line
-
-    ignore :: Array String
-    ignore =
-      map (dropSuffixSlashes <<< dropPrefixSlashes)
-        $ Array.filter (not <<< or [ String.null, isComment ])
-        $ map String.trim
-        $ String.split (String.Pattern "\n")
-        $ gitignore
-  liftAff $ Glob.match' dir patterns { ignore: [ ".spago" ] <> ignore }
-
 -- | Reads all the configurations in the tree and builds up the Map of local
 -- | packages to be integrated in the package set
 readWorkspace :: ReadWorkspaceOptions -> Spago (Registry.RegistryEnv _) Workspace
@@ -222,23 +196,9 @@ readWorkspace { maybeSelectedPackage, pureBuild, migrateConfig } = do
       pure { workspace, package, workspaceDoc: doc }
 
   logDebug "Gathering all the spago configs in the tree..."
-  { succeeded: otherConfigPaths, failed, ignored } <- do
-    result <- gitIgnoringGlob Paths.cwd [ "**/spago.yaml" ]
-    -- If a file is gitignored then we don't include it as a package
-    let
-      filterGitignored path = do
-        Git.isIgnored path >>= case _ of
-          true -> pure $ Left path
-          false -> pure $ Right path
-    { right: newSucceeded, left: ignored } <- partitionMap identity
-      <$> parTraverseSpago filterGitignored result.succeeded
-    pure { succeeded: newSucceeded, failed: result.failed, ignored }
+  otherConfigPaths <- liftAff $ Glob.gitignoringGlob Paths.cwd [ "**/spago.yaml" ]
   unless (Array.null otherConfigPaths) do
     logDebug $ [ toDoc "Found packages at these paths:", Log.indent $ Log.lines (map toDoc otherConfigPaths) ]
-  unless (Array.null failed) do
-    logDebug $ "Failed to sanitise some of the glob matches: " <> show failed
-  unless (Array.null ignored) do
-    logDebug $ "Ignored some of the glob matches as they are gitignored: " <> show ignored
 
   -- We read all of them in, and only read the package section, if any.
   let

src/Spago/Glob.js

@@ -0,0 +1,16 @@
+import mm from 'micromatch';
+import * as fsWalk from '@nodelib/fs.walk';
+
+export const micromatch = options => patterns => mm.matcher(patterns, options);
+
+export const fsWalkImpl = Left => Right => respond => options => path => () => {
+  const entryFilter = entry => options.entryFilter(entry)();
+  const deepFilter = entry => options.deepFilter(entry)();
+  fsWalk.walk(path, { entryFilter, deepFilter }, (error, entries) => {
+    if (error !== null) return respond(Left(error))();
+    return respond(Right(entries))();
+  });
+};
+
+export const isFile = dirent => dirent.isFile();
+

src/Spago/Glob.purs

@@ -0,0 +1,116 @@
+module Spago.Glob (gitignoringGlob) where
+
+import Spago.Prelude
+
+import Data.Array as Array
+import Data.String as String
+import Effect.Aff as Aff
+import Effect.Ref as Ref
+import Node.FS.Sync as SyncFS
+import Node.Path as Path
+import Record as Record
+import Type.Proxy (Proxy(..))
+
+type MicroMatchOptions = { ignore :: Array String }
+
+foreign import micromatch :: MicroMatchOptions -> Array String -> String -> Boolean
+
+type Entry = { name :: String, path :: String, dirent :: DirEnt }
+type FsWalkOptions = { entryFilter :: Entry -> Effect Boolean, deepFilter :: Entry -> Effect Boolean }
+
+foreign import data DirEnt :: Type
+foreign import isFile :: DirEnt -> Boolean
+foreign import fsWalkImpl
+  :: (forall a b. a -> Either a b)
+  -> (forall a b. b -> Either a b)
+  -> (Either Error (Array Entry) -> Effect Unit)
+  -> FsWalkOptions
+  -> String
+  -> Effect Unit
+
+gitignoreToMicromatchPatterns :: String -> String -> { ignore :: Array String, patterns :: Array String }
+gitignoreToMicromatchPatterns base =
+  String.split (String.Pattern "\n")
+    >>> map String.trim
+    >>> Array.filter (not <<< or [ String.null, isComment ])
+    >>> partitionMap
+      ( \line -> do
+          let negated = isJust $ String.stripPrefix (String.Pattern "!") line
+          let pattern = Path.concat [ base, gitignorePatternToMicromatch line ]
+          if negated then Left pattern else Right pattern
+      )
+    >>> Record.rename (Proxy :: Proxy "left") (Proxy :: Proxy "ignore")
+    >>> Record.rename (Proxy :: Proxy "right") (Proxy :: Proxy "patterns")
+
+  where
+  isComment = isJust <<< String.stripPrefix (String.Pattern "#")
+  dropSuffixSlash str = fromMaybe str $ String.stripSuffix (String.Pattern "/") str
+  dropPrefixSlash str = fromMaybe str $ String.stripPrefix (String.Pattern "/") str
+
+  gitignorePatternToMicromatch :: String -> String
+  gitignorePatternToMicromatch pattern
+    -- Git matches every pattern that does not include a `/` by basename.
+    | not $ String.contains (String.Pattern "/") pattern = "**/" <> pattern
+    | otherwise =
+        -- Micromatch treats every pattern like git treats those starting with '/'.
+        dropPrefixSlash pattern
+          -- ".spago/" in a .gitignore is the same as ".spago". Micromatch does interpret them differently.
+          # dropSuffixSlash
+
+fsWalk :: String -> Array String -> Array String -> Aff (Array Entry)
+fsWalk cwd ignorePatterns includePatterns = Aff.makeAff \cb -> do
+  let includeMatcher = micromatch { ignore: [] } includePatterns -- The Stuff we are globbing for.
+
+  -- Pattern for directories which can be outright ignored.
+  -- This will be updated whenver a .gitignore is found.
+  ignoreMatcherRef <- Ref.new $ micromatch { ignore: [] } ignorePatterns
+
+  -- If this Ref contains `true` because this Aff has been canceled, then deepFilter will always return false.
+  canceled <- Ref.new false
+  let
+    -- Should `fsWalk` recurse into this directory?
+    deepFilter :: Entry -> Effect Boolean
+    deepFilter entry = Ref.read canceled >>=
+      if _ then
+        -- The Aff has been canceled, don't recurse into any further directories!
+        pure false
+      else do
+        matcher <- Ref.read ignoreMatcherRef
+        pure $ not $ matcher (Path.relative cwd entry.path)
+
+    -- Should `fsWalk` retain this entry for the result array?
+    entryFilter :: Entry -> Effect Boolean
+    entryFilter entry = do
+      when (isFile entry.dirent && entry.name == ".gitignore") do -- A .gitignore was encountered
+        let gitignorePath = entry.path
+
+        -- directory of this .gitignore relative to the directory being globbed
+        let base = Path.relative cwd (Path.dirname gitignorePath)
+
+        try (SyncFS.readTextFile UTF8 gitignorePath) >>= case _ of
+          Left _ -> pure unit
+          Right gitignore -> do
+            let { ignore, patterns } = gitignoreToMicromatchPatterns base gitignore
+            let matcherForThisGitignore = micromatch { ignore } patterns
+
+            -- Instead of composing the matcher functions, we could also keep a growing array of
+            -- patterns and regenerate the matcher on every append. I don't know which option is
+            -- more performant, but composing functions is more conventient.
+            let addMatcher currentMatcher = or [ currentMatcher, matcherForThisGitignore ]
+            void $ Ref.modify addMatcher ignoreMatcherRef
+
+      ignoreMatcher <- Ref.read ignoreMatcherRef
+      let path = Path.relative cwd entry.path
+      pure $ includeMatcher path && not (ignoreMatcher path)
+
+    options = { entryFilter, deepFilter }
+
+  fsWalkImpl Left Right cb options cwd
+
+  pure $ Aff.Canceler \_ ->
+    void $ liftEffect $ Ref.write true canceled
+
+gitignoringGlob :: String -> Array String -> Aff (Array String)
+gitignoringGlob dir patterns =
+  map (Path.relative dir <<< _.path)
+    <$> fsWalk dir [ ".git" ] patterns