diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,9 +1,25 @@ # Changelog for vcs-ignore +## v0.1.0.0 (2026-08-31) + +- Replace the eager repository scan and separate lazy matcher with one opaque, + lazy `GitRepository` session +- Add kind-aware ignore queries with consistent Git last-match and + ignored-parent semantics +- Add a constant-result-memory repository fold with caller pruning and global + early termination +- Never follow symbolic links during traversal and expose each entry's kind +- Support Git directories, gitfiles, linked worktrees, and common directories +- Hide pattern and raw filesystem implementation details from the public API +- Remove the `Repo` type class, `scanRepo`, eager `Git`, and the separate + `GitIgnoreMatcher` API +- Update the executable, documentation, tests, and benchmarks for the new API +- Document intentionally unsupported Git configuration (`core.excludesFile`, + `core.ignoreCase`, and conditional includes) and sparse-checkout index rules + ## v0.0.2.0 (2021-12-29) - minor fixes and improvements - Bump _LTS Haskell_ to `18.20` ## v0.0.1.0 (2021-05-10) - initial release - diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ BSD 3-Clause License -Copyright (c) 2020-2022, Vaclav Svejcar +Copyright (c) 2020-2026, Vaclav Svejcar All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,104 +1,202 @@ -![CI](https://github.com/vaclavsvejcar/vcs-ignore/workflows/CI/badge.svg) -[![Hackage version](http://img.shields.io/hackage/v/vcs-ignore.svg)](https://hackage.haskell.org/package/vcs-ignore) -[![Stackage version](https://www.stackage.org/package/vcs-ignore/badge/lts?label=Stackage)](https://www.stackage.org/package/vcs-ignore) - # vcs-ignore -`vcs-ignore` is small Haskell library used to find, check and process files ignored by selected _VCS_. -## 1. Table of Contents - +[![CI](https://github.com/xwinus/vcs-ignore/actions/workflows/ci.yml/badge.svg)](https://github.com/xwinus/vcs-ignore/actions/workflows/ci.yml) +[![Hackage version](https://img.shields.io/hackage/v/vcs-ignore.svg)](https://hackage.haskell.org/package/vcs-ignore) +[![Stackage version](https://www.stackage.org/package/vcs-ignore/badge/lts?label=Stackage)](https://www.stackage.org/package/vcs-ignore) -- [1. Table of Contents](#1-table-of-contents) -- [2. Use as Library](#2-use-as-library) - - [2.1. Listing all files/directories ignored by VCS](#21-listing-all-filesdirectories-ignored-by-vcs) - - [2.2. Walking files/directories ignored by VCS](#22-walking-filesdirectories-ignored-by-vcs) - - [2.3. Checking if path is ignored by VCS](#23-checking-if-path-is-ignored-by-vcs) -- [3. Use as Executable](#3-use-as-executable) - - [3.1. Checking if path is ignored by VCS](#31-checking-if-path-is-ignored-by-vcs) +`vcs-ignore` is a Haskell library for querying Git ignore rules and traversing +the visible part of a working tree. It uses one lazy repository session for +both operations: opening a repository never scans its working tree, and +per-directory `.gitignore` files are loaded only when a visible branch needs +them. - +## Contents +- [Opening a repository](#opening-a-repository) +- [Checking a path](#checking-a-path) +- [Listing visible entries](#listing-visible-entries) +- [Processing without building a list](#processing-without-building-a-list) +- [Pruning and stopping early](#pruning-and-stopping-early) +- [Traversal and cache semantics](#traversal-and-cache-semantics) +- [Migrating from 0.0.x](#migrating-from-00x) +- [Using the executable](#using-the-executable) -## 2. Use as Library -Because this library is really simple to use, following example should be enough to understand how to use it for your project. +## Opening a repository -### 2.1. Listing all files/directories ignored by VCS +Use `openGitRepository` when the working-tree root is already known: + ```haskell -{-# LANGUAGE TypeApplications #-} +import Data.VCS.Ignore -module Data.VCS.Test where +openProject :: IO GitRepository +openProject = openGitRepository "/path/to/project" +``` -import Data.VCS.Ignore ( Git, Repo(..), listRepo ) +Use `findGitRepository` to search from a file or directory towards its +parents. It returns `Nothing` when no enclosing Git worktree exists. -example :: IO [FilePath] -example = do - repo <- scanRepo @Git "path/to/repo" - listRepo repo +```haskell +import Data.VCS.Ignore + +findProject :: IO (Maybe GitRepository) +findProject = findGitRepository "/path/to/project/src/Main.hs" ``` -### 2.2. Walking files/directories ignored by VCS -```haskell -{-# LANGUAGE TypeApplications #-} +Both regular `.git` directories and gitfiles used by linked worktrees and +submodules are supported. -module Data.VCS.Test where +## Checking a path -import Data.Maybe ( catMaybes ) -import System.Directory ( doesFileExist ) -import Data.VCS.Ignore ( Git, Repo(..), walkRepo ) +Queries take a repository-relative path and an explicit `PathKind`. The path +does not need to exist, and the library never guesses its kind from the +filesystem or a trailing slash. -onlyFiles :: IO [FilePath] -onlyFiles = do - repo <- scanRepo @Git "path/to/repo" - catMaybes <$> walkRepo repo walkFn - where - walkFn path = do - file <- doesFileExist path - pure (if file then Just path else Nothing) +```haskell +import Data.VCS.Ignore +checkBuildDirectory :: IO Bool +checkBuildDirectory = do + repo <- openGitRepository "/path/to/project" + isIgnored repo Directory "dist" + +checkGeneratedFile :: IO Bool +checkGeneratedFile = do + repo <- openGitRepository "/path/to/project" + isIgnored repo RegularFile "generated/output.log" ``` -### 2.3. Checking if path is ignored by VCS +Absolute paths and paths containing a `..` component are rejected. `.` denotes +the repository root and is never ignored. + +## Listing visible entries + +`listRepo` returns non-ignored files and directories. Each path is relative to +the repository root, and the root itself is not included. + ```haskell -{-# LANGUAGE TypeApplications #-} +import Data.VCS.Ignore -module Data.VCS.Test where +listVisibleFiles :: IO [FilePath] +listVisibleFiles = do + repo <- openGitRepository "/path/to/project" + entries <- listRepo repo + pure + [ entryPath entry + | entry <- entries + , entryKind entry == RegularFile + ] +``` -import Data.VCS.Ignore ( Git, Repo(..) ) +`listRepo` intentionally materializes its result. Use `forRepo_` or `foldRepo` +for large repositories when a complete list is unnecessary. -checkIgnored :: IO Bool -checkIgnored = do - repo <- scanRepo @Git "path/to/repo" - isIgnored repo "/some/path/.DS_Store" +## Processing without building a list + +`forRepo_` performs an action for every non-ignored entry without accumulating +the results. + +```haskell +import Data.VCS.Ignore +import System.FilePath (()) + +printVisiblePaths :: IO () +printVisiblePaths = do + repo <- openGitRepository "/path/to/project" + forRepo_ repo $ \entry -> + putStrLn (repositoryRoot repo entryPath entry) ``` -## 3. Use as Executable -While `vcs-ignore` is mainly intended to be used as a library, it also comes with small executable called `ignore` that can be used standalone to verify whether given path is ignored or not. +The callback receives the kind already discovered by the walker. Directory +symlinks are reported as `SymbolicLink` and are never followed. +## Pruning and stopping early + +`foldRepo` is the underlying traversal primitive. `Prune` skips a visible +directory for caller-specific reasons, while `Stop` terminates the entire +traversal immediately. + +```haskell +import Data.VCS.Ignore +import System.FilePath (takeFileName) + +countAtMost :: Int -> GitRepository -> IO (WalkResult Int) +countAtMost limit repo = + foldRepo repo 0 $ \count entry -> + if entryKind entry == Directory + && takeFileName (entryPath entry) == ".cache" + then pure (count, Prune) + else + if count >= limit + then pure (count, Stop) + else pure (count + 1, Continue) ``` + +Traversal is depth-first and pre-order. Sibling order is intentionally +unspecified. `Prune` on a non-directory is equivalent to `Continue`. + +## Traversal and cache semantics + +- Ignored entries are not passed to callbacks. +- Ignored directories are never opened or scanned. +- Git metadata belonging to the opened repository is never emitted. +- The default XDG global ignore file and `info/exclude` are loaded when the + repository is opened. +- A visible directory's `.gitignore` is loaded on first use and at most once + per repository session. +- A nested `.gitignore` is never loaded below an ignored or caller-pruned + directory. +- Later rule changes become visible after opening a new `GitRepository`. +- Missing, symlinked, and non-regular `.gitignore` files are treated as empty. + Other I/O failures are reported instead of being silently ignored. + +These rules ensure that individual queries and traversal use the same Git +precedence and ignored-parent behavior. + +The current matcher intentionally does not evaluate Git configuration. In +particular, `core.excludesFile`, `core.ignoreCase`, conditional config includes, +and index-backed ignore files in sparse checkouts are not supported. It reads +the default `$XDG_CONFIG_HOME/git/ignore` (or its platform equivalent) and uses +case-sensitive matching. Paths use Haskell `FilePath`; exact round-tripping of +arbitrary byte-string filenames is not guaranteed. + +## Migrating from 0.0.x + +Version `0.1.0.0` replaces the eager and lazy APIs with one repository session: + +| Before | Now | +|---|---| +| `scanRepo @Git root` | `openGitRepository root` | +| `openGitIgnoreMatcher root` | `openGitRepository root` | +| `isIgnored repo path` | `isIgnored repo kind path` | +| `isIgnoredPath matcher kind path` | `isIgnored repo kind path` | +| `repoRoot repo` | `repositoryRoot repo` | +| `listRepo :: IO [FilePath]` | `listRepo :: IO [Entry]` | +| list-returning callback traversal | `foldRepo`, `walkRepo`, or `forRepo_` | + +The `Repo` type class, eager `Git` value, `scanRepo`, and public pattern and +filesystem helpers have been removed. Paths returned in `Entry` remain +repository-relative. + +## Using the executable + +The package includes an executable named `ignore`. Run it from inside a Git +working tree to check a path: + +```console $ ignore --help -vcs-ignore, v0.0.2.0 :: https://github.com/vaclavsvejcar/vcs-ignore +vcs-ignore, v0.1.0.0 :: https://github.com/xwinus/vcs-ignore Usage: ignore (-p|--path PATH) [--debug] [-v|--version] [--numeric-version] - library for handling files ignored by VCS systems - -Available options: - -p,--path PATH path to check - --debug produce more verbose output - -v,--version show version info - --numeric-version show only version number - -h,--help Show this help text ``` -### 3.1. Checking if path is ignored by VCS -To verify if path is ignored by _VCS_, just call the `ignore` executable with `-p` parameter inside the _VCS_ repository like this: +The command exits with status `0` when the path is ignored and status `1` when +it is visible or no repository is found. -``` -$ ignore -p .stack-work/some-file -Found repository at: /path/to/repo -Path '.stack-work/some-file' IS NOT ignored +```console +$ ignore -p generated/output.log +Found repository at: /path/to/project +Path 'generated/output.log' IS ignored $ echo $? -1 +0 ``` - -As you can see, `ignore` executable prints result in human readable form as well as it sets the exit code to `1` if the file is __not__ ignored. diff --git a/RELEASING.md b/RELEASING.md new file mode 100644 --- /dev/null +++ b/RELEASING.md @@ -0,0 +1,48 @@ +# Releasing vcs-ignore + +Releases use an annotated `vVERSION` tag. The tag workflow builds the Cabal +source distribution and executable archives for Linux, macOS, and Windows, +then creates a draft GitHub release. + +## Prepare + +1. Set the version in `package.yaml` and regenerate `vcs-ignore.cabal`. +2. Replace the changelog's development marker with the release date. +3. Merge the preparation pull request and wait for CI on `master`. +4. Confirm that `cabal check`, tests, Haddock, and `cabal sdist` pass. + +## Build the draft release + +Create and push the release tag from the tested `master` commit: + +```console +git switch master +git pull --ff-only +git tag -a vVERSION -m "Release vVERSION" +git push origin vVERSION +``` + +The release workflow verifies that the tag matches the package version. After +all artifacts build successfully, it creates a draft GitHub release containing +the Hackage-ready source distribution, platform binaries, and checksums. + +## Publish + +1. Download the source distribution from the draft GitHub release. +2. Upload it as a Hackage candidate and inspect the generated package page: + + ```console + cabal upload vcs-ignore-VERSION.tar.gz + ``` + +3. Publish the same archive after the candidate is verified: + + ```console + cabal upload --publish vcs-ignore-VERSION.tar.gz + ``` + +4. Review the generated release notes and publish the GitHub draft. +5. Verify the public Hackage documentation and the downloadable binaries. + +Never move or recreate a published release tag. Prepare a new package version +when a released artifact needs correction. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,78 +1,98 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - -{-| -Module : Main -Description : Simple application using the /vcs-ignore/ library -Copyright : (c) 2020-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -This simple application demonstrates the use of "vcs-ignore" library. It allows -to check whether path given as argument is ignored within existing /GIT/ repo. --} - -module Main - ( main - ) -where +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} -import Control.Monad ( when ) -import Data.VCS.Ignore.Core ( findRepo ) -import Data.VCS.Ignore.Repo ( Repo(..) ) -import Data.VCS.Ignore.Repo.Git ( Git ) -import Main.Options ( Mode(..) - , Options(..) - , optionsParser - ) -import Options.Applicative ( execParser ) -import System.Directory ( canonicalizePath - , getCurrentDirectory - ) -import System.Exit ( exitFailure - , exitSuccess - ) -import System.FilePath ( makeRelative ) +-- | +-- Module : Main +-- Description : Simple application using the /vcs-ignore/ library +-- Copyright : (c) 2020-2026 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- This simple application demonstrates the use of "vcs-ignore" library. It allows +-- to check whether path given as argument is ignored within existing /GIT/ repo. +module Main ( + main, +) where +import Control.Monad (when) +import Data.VCS.Ignore ( + GitRepository, + PathKind (..), + findGitRepository, + isIgnored, + repositoryRoot, + ) +import Main.Options ( + Mode (..), + Options (..), + optionsParser, + ) +import Options.Applicative (execParser) +import System.Directory ( + doesDirectoryExist, + doesFileExist, + getCurrentDirectory, + makeAbsolute, + pathIsSymbolicLink, + ) +import System.Exit ( + exitFailure, + exitSuccess, + ) +import System.FilePath (makeRelative, normalise) +import System.IO.Error ( + isDoesNotExistError, + tryIOError, + ) main :: IO () main = do - options <- execParser optionsParser - repo <- findRepoOrFail @Git options - executeMode repo options - - -findRepoOrFail :: (Repo r, Show r) => Options -> IO r -findRepoOrFail Options {..} = do - repoDir <- getCurrentDirectory - maybeRepo <- findRepo repoDir - case maybeRepo of - Just repo -> do - putStrLn $ "Found repository at: " <> repoRoot repo - when oDebug (putStrLn $ "Repository details: " <> show repo) - pure repo - Nothing -> do - putStrLn $ "No repository found for path: " <> repoDir - exitFailure + options <- execParser optionsParser + repo <- findRepoOrFail options + executeMode repo options +findRepoOrFail :: Options -> IO GitRepository +findRepoOrFail Options{..} = do + repoDir <- getCurrentDirectory + maybeRepo <- findGitRepository repoDir + case maybeRepo of + Just repo -> do + putStrLn $ "Found repository at: " <> repositoryRoot repo + when oDebug (putStrLn $ "Repository root: " <> repositoryRoot repo) + pure repo + Nothing -> do + putStrLn $ "No repository found for path: " <> repoDir + exitFailure -executeMode :: Repo r => r -> Options -> IO () +executeMode :: GitRepository -> Options -> IO () executeMode repo (oMode -> Path path) = checkPath repo path - -checkPath :: Repo r => r -> FilePath -> IO () +checkPath :: GitRepository -> FilePath -> IO () checkPath repo path = do - relative <- makeRelative (repoRoot repo) <$> canonicalizePath path - excluded <- isIgnored repo relative - if excluded then reportIgnored else reportNotIgnored - where - reportIgnored = do - putStrLn $ "Path '" <> path <> "' IS ignored" - exitSuccess - reportNotIgnored = do - putStrLn $ "Path '" <> path <> "' IS NOT ignored" - exitFailure + absolute <- normalise <$> makeAbsolute path + kind <- classifyPath absolute + let relative = makeRelative (repositoryRoot repo) absolute + excluded <- isIgnored repo kind relative + if excluded then reportIgnored else reportNotIgnored + where + reportIgnored = do + putStrLn $ "Path '" <> path <> "' IS ignored" + exitSuccess + reportNotIgnored = do + putStrLn $ "Path '" <> path <> "' IS NOT ignored" + exitFailure +classifyPath :: FilePath -> IO PathKind +classifyPath path = do + symbolicLinkResult <- tryIOError $ pathIsSymbolicLink path + case symbolicLinkResult of + Left error' + | isDoesNotExistError error' -> pure Other + | otherwise -> ioError error' + Right True -> pure SymbolicLink + Right False -> do + directory <- doesDirectoryExist path + regularFile <- doesFileExist path + pure $ if directory then Directory else if regularFile then RegularFile else Other diff --git a/app/Main/Options.hs b/app/Main/Options.hs --- a/app/Main/Options.hs +++ b/app/Main/Options.hs @@ -1,62 +1,62 @@ {-# LANGUAGE StrictData #-} -{-| -Module : Main.Options -Description : Options definitions for "optparse-applicative" -Copyright : (c) 2020-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Options definitions for "optparse-applicative". --} - -module Main.Options - ( Options(..) - , Mode(..) - , optionsParser - ) -where - -import Main.Vendor ( buildVersion - , productDesc - , productInfo - ) -import Options.Applicative +-- | +-- Module : Main.Options +-- Description : Options definitions for "optparse-applicative" +-- Copyright : (c) 2020-2026 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Options definitions for "optparse-applicative". +module Main.Options ( + Options (..), + Mode (..), + optionsParser, +) where +import Main.Vendor ( + buildVersion, + productDesc, + productInfo, + ) +import Options.Applicative data Options = Options - { oMode :: Mode - , oDebug :: Bool - } - deriving (Eq, Show) + { oMode :: Mode + , oDebug :: Bool + } + deriving (Eq, Show) data Mode = Path FilePath - deriving (Eq, Show) - + deriving (Eq, Show) optionsParser :: ParserInfo Options -optionsParser = info (options <**> versionP <**> helper) - (fullDesc <> progDesc productDesc <> header productInfo) - where - options = - Options - <$> ( Path - <$> strOption - (long "path" <> short 'p' <> metavar "PATH" <> help - "path to check" +optionsParser = + info + (options <**> versionP <**> helper) + (fullDesc <> progDesc productDesc <> header productInfo) + where + options = + Options . Path + <$> strOption + ( long "path" + <> short 'p' + <> metavar "PATH" + <> help + "path to check" ) - ) - <*> switch (long "debug" <> help "produce more verbose output") - + <*> switch (long "debug" <> help "produce more verbose output") versionP :: Parser (a -> a) versionP = versionInfoP <*> versionNumP - where - versionInfoP = infoOption - productInfo - (long "version" <> short 'v' <> help "show version info") - versionNumP = infoOption - buildVersion - (long "numeric-version" <> help "show only version number") + where + versionInfoP = + infoOption + productInfo + (long "version" <> short 'v' <> help "show version info") + versionNumP = + infoOption + buildVersion + (long "numeric-version" <> help "show only version number") diff --git a/app/Main/Vendor.hs b/app/Main/Vendor.hs --- a/app/Main/Vendor.hs +++ b/app/Main/Vendor.hs @@ -1,50 +1,42 @@ {-# LANGUAGE OverloadedStrings #-} -{-| -Module : Main.Vendor -Description : Details about the application. -Copyright : (c) 2020-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -Module providing info about this application. --} - -module Main.Vendor - ( buildVersion - , productDesc - , productInfo - , productName - , webRepo - ) -where - -import Data.String ( IsString(..) ) -import Data.Version ( showVersion ) -import Paths_vcs_ignore ( version ) +-- | +-- Module : Main.Vendor +-- Description : Details about the application. +-- Copyright : (c) 2020-2026 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Module providing info about this application. +module Main.Vendor ( + buildVersion, + productDesc, + productInfo, + productName, + webRepo, +) where +import Data.String (IsString (..)) +import Data.Version (showVersion) +import Paths_vcs_ignore (version) -- | Product version. -buildVersion :: IsString a => a +buildVersion :: (IsString a) => a buildVersion = fromString . showVersion $ version - -productDesc :: IsString a => a +productDesc :: (IsString a) => a productDesc = "library for handling files ignored by VCS systems" - -- | Product info. productInfo :: (IsString a, Monoid a) => a productInfo = mconcat [productName, ", v", buildVersion, " :: ", webRepo] - -- | Product full name. -productName :: IsString a => a +productName :: (IsString a) => a productName = "vcs-ignore" - -- | Product source code repository. -webRepo :: IsString a => a -webRepo = "https://github.com/vaclavsvejcar/vcs-ignore" +webRepo :: (IsString a) => a +webRepo = "https://github.com/xwinus/vcs-ignore" diff --git a/benchmark/Main.hs b/benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main.hs @@ -0,0 +1,80 @@ +module Main (main) where + +import Control.Monad (forM_) +import Criterion.Main ( + bench, + bgroup, + defaultMain, + envWithCleanup, + nfIO, + whnfIO, + ) +import Data.VCS.Ignore ( + PathKind (Directory), + WalkAction (Continue, Stop), + entryPath, + foldRepo, + isIgnored, + listRepo, + openGitRepository, + ) +import System.Directory ( + createDirectoryIfMissing, + getTemporaryDirectory, + removePathForcibly, + ) +import System.FilePath ( + takeDirectory, + (), + ) +import System.IO.Temp (createTempDirectory) + +main :: IO () +main = + defaultMain + [ envWithCleanup setupEnvironment cleanupEnvironment $ \root -> + bgroup + "repository" + [ bench "open" $ whnfIO (openGitRepository root) + , bench "cold-directory-query" . whnfIO $ do + repo <- openGitRepository root + isIgnored repo Directory "ignored" + , bench "fold-visible-tree" . whnfIO $ do + repo <- openGitRepository root + foldRepo repo (0 :: Int) countEntry + , bench "list-visible-tree" . nfIO $ do + repo <- openGitRepository root + fmap entryPath <$> listRepo repo + , bench "stop-after-ten" . whnfIO $ do + repo <- openGitRepository root + foldRepo repo (0 :: Int) stopAfterTen + ] + ] + where + countEntry count _ = pure (count + 1, Continue) + stopAfterTen count _ + | count >= 10 = pure (count, Stop) + | otherwise = pure (count + 1, Continue) + +setupEnvironment :: IO FilePath +setupEnvironment = do + temporary <- getTemporaryDirectory + sandbox <- createTempDirectory temporary "vcs-ignore-benchmark" + let root = sandbox "repo" + createDirectoryIfMissing True $ root ".git" "info" + writeFile (root ".gitignore") "ignored/\n" + createTree $ root "ignored" + createTree $ root "visible" + pure root + where + createTree base = + forM_ [1 .. directoryCount] $ \directoryIndex -> do + let directory = base show directoryIndex + createDirectoryIfMissing True directory + forM_ [1 .. filesPerDirectory] $ \fileIndex -> + writeFile (directory show fileIndex <> ".generated") "benchmark" + directoryCount = 20 :: Int + filesPerDirectory = 200 :: Int + +cleanupEnvironment :: FilePath -> IO () +cleanupEnvironment = removePathForcibly . takeDirectory diff --git a/doctest/Main.hs b/doctest/Main.hs deleted file mode 100644 --- a/doctest/Main.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main (main) where - -import Test.DocTest - -main :: IO () -main = doctest ["-XOverloadedStrings", "src"] diff --git a/src/Data/VCS/Ignore.hs b/src/Data/VCS/Ignore.hs --- a/src/Data/VCS/Ignore.hs +++ b/src/Data/VCS/Ignore.hs @@ -1,89 +1,18 @@ -{-| -Module : Data.VCS.Ignore -Description : Reexported modules for convenience -Copyright : (c) 2020-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -@vcs-ignore@ is small Haskell library used to find, check and process files -ignored by selected /VCS/. - -= Example of Use -Because this library is really simple to use, following example should be -enough to understand how to use it for your project. - -== Listing all files/directories ignored by VCS -@ -{-# LANGUAGE TypeApplications #-} - -module Data.VCS.Test where - -import Data.VCS.Ignore ( Git, Repo(..), listRepo ) - -example :: IO [FilePath] -example = do - repo <- scanRepo @Git "path/to/repo" - listRepo repo -@ - -== Walking files/directories ignored by VCS -@ -{-# LANGUAGE TypeApplications #-} - -module Data.VCS.Test where - -import Data.Maybe ( catMaybes ) -import System.Directory ( doesFileExist ) -import Data.VCS.Ignore ( Git, Repo(..), walkRepo ) - -onlyFiles :: IO [FilePath] -onlyFiles = do - repo <- scanRepo @Git "path/to/repo" - catMaybes <$> walkRepo repo walkFn - where - walkFn path = do - file <- doesFileExist path - pure (if file then Just path else Nothing) -@ - -== Checking if path is ignored by VCS -@ -{-# LANGUAGE TypeApplications #-} - -module Data.VCS.Test where - -import Data.VCS.Ignore ( Git, Repo(..) ) - -checkIgnored :: IO Bool -checkIgnored = do - repo <- scanRepo @Git "path/to/repo" - isIgnored repo "/some/path/.DS_Store" -@ --} - -module Data.VCS.Ignore - ( -- Working with ignored files - findRepo - , listRepo - , walkRepo - -- * Repo /type class/ - , Repo(..) - , RepoError(..) - -- * /GIT/ implementation - , Git(..) - -- * Common data types - , VCSIgnoreError(..) - ) -where +-- | +-- Module : Data.VCS.Ignore +-- Description : Git ignore queries and controllable repository traversal +-- Copyright : (c) 2020-2026 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- The library uses one lazy repository session for both individual ignore +-- queries and recursive traversal. Opening a repository does not scan its +-- working tree; per-directory rules are loaded only when a visible branch is +-- queried or traversed. +module Data.VCS.Ignore ( + module Data.VCS.Ignore.Git, +) where -import Data.VCS.Ignore.Core ( findRepo - , listRepo - , walkRepo - ) -import Data.VCS.Ignore.Repo ( Repo(..) - , RepoError(..) - ) -import Data.VCS.Ignore.Repo.Git ( Git(..) ) -import Data.VCS.Ignore.Types ( VCSIgnoreError(..) ) +import Data.VCS.Ignore.Git diff --git a/src/Data/VCS/Ignore/Core.hs b/src/Data/VCS/Ignore/Core.hs deleted file mode 100644 --- a/src/Data/VCS/Ignore/Core.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TypeApplications #-} - -{-| -Module : Data.VCS.Ignore.Core -Description : Core operations over the repository -Copyright : (c) 2020-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -This module contains core operations you can perform over the scanned 'Repo'. --} - -module Data.VCS.Ignore.Core - ( findRepo - , listRepo - , walkRepo - ) -where - -import Control.Exception ( try ) -import Control.Monad.IO.Class ( MonadIO - , liftIO - ) -import qualified Data.List as L -import Data.Maybe ( catMaybes - , fromMaybe - ) -import Data.VCS.Ignore.FileSystem ( walkPaths ) -import Data.VCS.Ignore.Repo ( Repo(..) ) -import Data.VCS.Ignore.Types ( VCSIgnoreError ) -import System.FilePath ( pathSeparator - , takeDirectory - ) - - --- | Attempts to find (and scan via 'scanRepo') repository at given path. --- If given path doesn't contain valid repository, it recursively tries in every --- parent directory until the root directory (e.g. @C:@ or @/@) is reached. -findRepo :: (MonadIO m, Repo r) - => FilePath -- ^ path where to start scanning - -> m (Maybe r) -- ^ scanned 'Repo' (if found) -findRepo = liftIO . go - where - go dir = do - let parent = takeDirectory dir - maybeRepo <- try @VCSIgnoreError (scanRepo dir) - case maybeRepo of - Left _ | parent == dir -> pure Nothing - Left _ -> go parent - Right repo -> pure . Just $ repo - - --- | Resursively lists all non-ignored paths withing the given repository --- (both files and directories). -listRepo :: (MonadIO m, Repo r) - => r -- ^ repository to list - -> m [FilePath] -- ^ list of non-ignored paths within the repository -listRepo repo = walkRepo repo pure - - --- | Similar to 'listRepo', but allows to perform any action on every --- non-ignored path within the repository. -walkRepo :: (MonadIO m, Repo r) - => r -- ^ repository to walk - -> (FilePath -> m a) -- ^ action to do on every non-excluded filepath - -> m [a] -- ^ list of transformed paths -walkRepo repo fn = do - let search path | L.null path = pure Nothing - | otherwise = doSearch path - catMaybes <$> walkPaths root' (search . relativePath) - where - ps = [pathSeparator] - root = repoRoot repo - root' = if ps `L.isSuffixOf` root then root else root <> ps - relativePath = dropPrefix root' - dropPrefix = \prefix t -> fromMaybe t (L.stripPrefix prefix t) - doSearch = \path -> isIgnored repo path >>= process path - process = \path x -> if x then pure Nothing else Just <$> fn path diff --git a/src/Data/VCS/Ignore/FileSystem.hs b/src/Data/VCS/Ignore/FileSystem.hs deleted file mode 100644 --- a/src/Data/VCS/Ignore/FileSystem.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} - -{-| -Module : Data.VCS.Ignore.FileSystem -Description : Helper functions for working with file system -Copyright : (c) 2020-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -This module contains mainly helper functions, that are internally used by this -library. --} - -module Data.VCS.Ignore.FileSystem - ( findPaths - , listPaths - , walkPaths - , toPosixPath - ) -where - - -import Control.Monad ( forM - , mfilter - ) -import Control.Monad.IO.Class ( MonadIO - , liftIO - ) -import Data.Maybe ( catMaybes - , fromMaybe - ) -import System.Directory ( doesDirectoryExist - , doesFileExist - , getDirectoryContents - ) -import System.FilePath ( () ) - - --- | Recursively finds paths on given path whose filename matches the predicate. -findPaths :: MonadIO m - => FilePath -- ^ path to traverse - -> (FilePath -> m Bool) -- ^ predicate to match filename - -> m [FilePath] -- ^ list of found paths -findPaths entryPath predicate = catMaybes <$> walkPaths entryPath process - where - process path = (\p -> if p then Just path else Nothing) <$> predicate path - - --- | Recursively finds all paths on given path. If file reference is passed --- instead of directory, such path is returned. -listPaths :: MonadIO m - => FilePath -- ^ path to traverse - -> m [FilePath] -- ^ list of found paths -listPaths entryPath = walkPaths entryPath pure - - --- | Recursively walks the given path and performs selected action for each --- found file. Output of this function is: --- --- * If the given __path is file__, only this single path is processed and --- returned. --- * If the given __path is directory__, all subdirectories and files are --- recursively processed and returned. --- * If the given __path doesn't exist__, empy list will be returned. -walkPaths :: MonadIO m - => FilePath -- ^ path to traverse - -> (FilePath -> m a) -- ^ function to process path - -> m [a] -- ^ result of traversed & processed paths -walkPaths entryPath fn = do - isDir <- liftIO $ doesDirectoryExist entryPath - isFile <- liftIO $ doesFileExist entryPath - if - | isDir -> fn entryPath >>= (\p -> (p :) <$> listDirectory entryPath) - | isFile -> pure <$> fn entryPath - | otherwise -> pure [] - where - listDirectory dir = do - names <- liftIO $ getDirectoryContents dir - paths <- forM (filter (`notElem` [".", ".."]) names) $ \name -> do - let path = dir name - isDirectory <- liftIO $ doesDirectoryExist path - if isDirectory then walkPaths path fn else pure <$> fn path - pure $ concat paths - - --- | If the given path contains backward slashes (Windows style), converts them --- into forward ones (Unix style). --- --- >>> toPosixPath "foo\\bar\\x.txt" --- "foo/bar/x.txt" --- --- >>> toPosixPath "foo/bar/x.txt" --- "foo/bar/x.txt" -toPosixPath :: FilePath -- ^ input filepath to convert - -> FilePath -- ^ output filepath -toPosixPath = replace '\\' '/' - where replace a b = fmap $ fromMaybe b . mfilter (/= a) . Just diff --git a/src/Data/VCS/Ignore/Git.hs b/src/Data/VCS/Ignore/Git.hs new file mode 100644 --- /dev/null +++ b/src/Data/VCS/Ignore/Git.hs @@ -0,0 +1,45 @@ +-- | +-- Module : Data.VCS.Ignore.Git +-- Description : Lazy Git ignore queries and repository traversal +-- Copyright : (c) 2020-2026 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclavsvejcar@gmail.com +-- Stability : experimental +-- Portability : portable +module Data.VCS.Ignore.Git ( + GitRepository, + PathKind (..), + Entry (..), + WalkAction (..), + WalkResult (..), + GitError (..), + openGitRepository, + findGitRepository, + repositoryRoot, + isIgnored, + foldRepo, + walkRepo, + forRepo_, + listRepo, +) where + +import Data.VCS.Ignore.Git.Internal.Repository ( + GitRepository, + findGitRepository, + isIgnored, + openGitRepository, + repositoryRoot, + ) +import Data.VCS.Ignore.Git.Internal.Traversal ( + foldRepo, + forRepo_, + listRepo, + walkRepo, + ) +import Data.VCS.Ignore.Types ( + Entry (..), + GitError (..), + PathKind (..), + WalkAction (..), + WalkResult (..), + ) diff --git a/src/Data/VCS/Ignore/Git/Internal/Pattern.hs b/src/Data/VCS/Ignore/Git/Internal/Pattern.hs new file mode 100644 --- /dev/null +++ b/src/Data/VCS/Ignore/Git/Internal/Pattern.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} + +-- | +-- Module : Data.VCS.Ignore.Git.Internal.Pattern +-- Description : Parsing and evaluation of Git ignore patterns +-- Copyright : (c) 2020-2026 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : portable +module Data.VCS.Ignore.Git.Internal.Pattern ( + Pattern, + PatternGroup (..), + parsePatterns, + loadPatternsFile, + evaluatePatternGroups, +) where + +import Control.Exception (IOException, catch, throwIO) +import qualified Data.List as L +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.VCS.Ignore.Types (PathKind (..)) +import System.Directory ( + doesDirectoryExist, + doesFileExist, + pathIsSymbolicLink, + ) +import System.FilePath (pathSeparator) +import qualified System.FilePath.Glob as G +import System.IO.Error ( + isDoesNotExistError, + tryIOError, + ) + +-- | A compiled Git ignore rule. Its representation is deliberately private so +-- callers cannot construct rules that bypass Git's line parsing semantics. +data Pattern = Pattern + { patternMatchers :: [G.Pattern] + , patternNegated :: Bool + , patternDirectoryOnly :: Bool + } + deriving (Eq, Show) + +-- | Patterns from one ignore source, scoped to a repository-relative prefix. +-- Prefixes use POSIX separators and are conventionally written as @/@ for the +-- repository root or @/directory/@ for a nested ignore file. +data PatternGroup = PatternGroup + { patternGroupPrefix :: FilePath + , patternGroupPatterns :: [Pattern] + } + deriving (Eq, Show) + +-- | Parses the contents of an ignore file. Blank lines and comments are +-- discarded. CRLF, escaped leading hash/bang characters and Git's trailing +-- space rules are handled before compiling each pattern. +parsePatterns :: T.Text -> [Pattern] +parsePatterns = foldr parseLine [] . T.lines + where + parseLine raw patterns = + case prepareLine raw of + Nothing -> patterns + Just line -> compilePattern line : patterns + +-- | Loads and parses an ignore file. The flag controls whether a symbolic link +-- may be followed: global and repository exclude files use 'True', while a +-- working-tree @.gitignore@ uses 'False' to match Git's behaviour. +-- +-- A missing file is an empty source. Other I/O failures are propagated. +loadPatternsFile :: Bool -> FilePath -> IO [Pattern] +loadPatternsFile followSymbolicLink path = do + symbolicLinkResult <- tryIOError $ pathIsSymbolicLink path + case symbolicLinkResult of + Left error' + | isDoesNotExistError error' -> pure [] + | otherwise -> ioError error' + Right True + | not followSymbolicLink -> pure [] + | otherwise -> do + isRegularFile <- doesFileExist path + if isRegularFile then parsePatterns <$> readPatterns else pure [] + Right False -> do + isDirectory <- doesDirectoryExist path + if isDirectory + then pure [] + else do + isRegularFile <- doesFileExist path + if isRegularFile then parsePatterns <$> readPatterns else pure [] + where + readPatterns = T.readFile path `catch` handleMissing + handleMissing error' + | isDoesNotExistError error' = pure T.empty + | otherwise = throwIO (error' :: IOException) + +-- | Evaluates groups ordered from lowest to highest precedence. Within each +-- group, patterns retain file order. Consequently, the last matching rule is +-- authoritative. The result is 'True' when the path is ignored. +evaluatePatternGroups :: PathKind -> [PatternGroup] -> FilePath -> Bool +evaluatePatternGroups kind groups path = + fromMaybe False $ L.foldl' applyGroup Nothing groups + where + candidate = addLeadingSlash . toPosix $ path + applyGroup result group + | groupApplies prefix candidate = + L.foldl' (applyPattern prefix) result $ patternGroupPatterns group + | otherwise = result + where + prefix = normalizePrefix $ patternGroupPrefix group + applyPattern prefix result pattern' + | matchesPattern kind pattern' (pathForGroup prefix candidate) = + Just . not $ patternNegated pattern' + | otherwise = result + +prepareLine :: T.Text -> Maybe T.Text +prepareLine raw + | T.null line = Nothing + | "#" `T.isPrefixOf` line = Nothing + | otherwise = Just line + where + line = stripUnescapedTrailingSpaces . T.dropWhileEnd (== '\r') $ raw + +compilePattern :: T.Text -> Pattern +compilePattern line = + Pattern + { patternMatchers = + if hasDanglingEscape body + then [] + else compileGlob . T.unpack <$> matcherSources patternBody directoryOnly + , patternNegated = negated + , patternDirectoryOnly = directoryOnly + } + where + (negated, body) = case T.uncons line of + Just ('!', rest) -> (True, rest) + _ -> (False, line) + directoryOnly = "/" `T.isSuffixOf` body + withoutDirectoryMarker = fromMaybe body $ T.stripSuffix "/" body + patternBody = unescapePattern withoutDirectoryMarker + +matcherSources :: T.Text -> Bool -> [T.Text] +matcherSources raw directoryOnly + | T.null raw = [] + | directoryOnly = [expandTrailingRecursive scoped] + | "/**" `T.isSuffixOf` scoped = [expandTrailingRecursive scoped] + | otherwise = [scoped] + where + scoped = case T.stripPrefix "/" raw of + Just anchored -> "/" <> anchored + Nothing + | "**/" `T.isPrefixOf` raw -> raw + | "/" `T.isInfixOf` raw -> "/" <> raw + | otherwise -> "**/" <> raw + +-- Glob recognizes recursive wildcards in the @**/@ form. Git also gives a +-- trailing @/**@ recursive meaning, so append a final wildcard component to +-- preserve that behaviour at arbitrary depth. +expandTrailingRecursive :: T.Text -> T.Text +expandTrailingRecursive source + | "/**" `T.isSuffixOf` source = source <> "/*" + | otherwise = source + +compileGlob :: String -> G.Pattern +compileGlob = + G.compileWith + G.compDefault + { G.numberRanges = False + , G.pathSepInRanges = False + } + +matchesPattern :: PathKind -> Pattern -> FilePath -> Bool +matchesPattern kind pattern' candidate = + (not (patternDirectoryOnly pattern') || kind == Directory) + && any (`G.match` candidate) (patternMatchers pattern') + +pathForGroup :: FilePath -> FilePath -> FilePath +pathForGroup "/" candidate = candidate +pathForGroup prefix candidate = + addLeadingSlash . fromMaybe candidate $ L.stripPrefix prefix candidate + +groupApplies :: FilePath -> FilePath -> Bool +groupApplies "/" _ = True +groupApplies prefix candidate = + prefix `L.isPrefixOf` addTrailingSlash candidate + && prefix /= addTrailingSlash candidate + +normalizePrefix :: FilePath -> FilePath +normalizePrefix prefix + | stripped == "" = "/" + | otherwise = addTrailingSlash . addLeadingSlash $ stripped + where + stripped = dropWhile (== '/') . L.dropWhileEnd (== '/') . toPosix $ prefix + +stripUnescapedTrailingSpaces :: T.Text -> T.Text +stripUnescapedTrailingSpaces text = case T.unsnoc text of + Just (prefix, ' ') -> + let slashes = T.takeWhileEnd (== '\\') prefix + beforeSlashes = T.dropEnd (T.length slashes) prefix + in if odd (T.length slashes) + then beforeSlashes <> T.dropEnd 1 slashes <> " " + else stripUnescapedTrailingSpaces prefix + _ -> text + +hasDanglingEscape :: T.Text -> Bool +hasDanglingEscape = odd . T.length . T.takeWhileEnd (== '\\') + +unescapePattern :: T.Text -> T.Text +unescapePattern = T.pack . go . T.unpack + where + go [] = [] + go ['\\'] = ['\\'] + go ('[' : rest) = + case takeCharacterClass [] rest of + Nothing -> "[[]" <> go rest + Just (body, remaining) -> + '[' : (unescapeClass body <> (']' : go remaining)) + go ('\\' : char : rest) = escapeGlobLiteral char <> go rest + go (char : rest) = char : go rest + + takeCharacterClass _ [] = Nothing + takeCharacterClass prefix ('\\' : char : rest) = + takeCharacterClass (char : '\\' : prefix) rest + takeCharacterClass prefix (']' : rest) = Just (reverse prefix, rest) + takeCharacterClass prefix (char : rest) = + takeCharacterClass (char : prefix) rest + + unescapeClass body = + case unescapeClassBody body of + (False, characters) -> characters + (True, '!' : characters) -> '!' : '-' : characters + (True, '^' : characters) -> '^' : '-' : characters + (True, characters) -> '-' : characters + + unescapeClassBody [] = (False, []) + unescapeClassBody ('\\' : '-' : rest) = + let (_, characters) = unescapeClassBody rest + in (True, characters) + unescapeClassBody ('\\' : char : rest) = + let (hasLiteralHyphen, characters) = unescapeClassBody rest + in (hasLiteralHyphen, escapeGlobLiteral char <> characters) + unescapeClassBody (char : rest) = + let (hasLiteralHyphen, characters) = unescapeClassBody rest + in (hasLiteralHyphen, char : characters) + + escapeGlobLiteral '*' = "[*]" + escapeGlobLiteral '?' = "[?]" + escapeGlobLiteral '[' = "[[]" + escapeGlobLiteral char = [char] + +addLeadingSlash :: FilePath -> FilePath +addLeadingSlash path + | "/" `L.isPrefixOf` path = path + | otherwise = '/' : path + +addTrailingSlash :: FilePath -> FilePath +addTrailingSlash path + | "/" `L.isSuffixOf` path = path + | otherwise = path <> "/" + +toPosix :: FilePath -> FilePath +toPosix = fmap replaceSeparator + where + replaceSeparator char + | char == pathSeparator = '/' + | otherwise = char diff --git a/src/Data/VCS/Ignore/Git/Internal/Repository.hs b/src/Data/VCS/Ignore/Git/Internal/Repository.hs new file mode 100644 --- /dev/null +++ b/src/Data/VCS/Ignore/Git/Internal/Repository.hs @@ -0,0 +1,391 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} + +-- | +-- Module : Data.VCS.Ignore.Git.Internal.Repository +-- Description : Lazy Git repository session and ignore queries +-- Copyright : (c) 2020-2026 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : portable +module Data.VCS.Ignore.Git.Internal.Repository ( + GitRepository (..), + openGitRepository, + findGitRepository, + repositoryRoot, + isIgnored, + rootRuleContext, + loadDirectoryRules, + loadDirectoryRulesWith, + isRepositoryMetadata, + validateRepositoryPath, + groupPrefix, +) where + +import Control.Concurrent.MVar ( + MVar, + modifyMVar, + modifyMVar_, + newEmptyMVar, + newMVar, + putMVar, + readMVar, + ) +import Control.Exception ( + AsyncException, + SomeException, + fromException, + mask, + throwIO, + try, + ) +import Control.Monad (unless) +import qualified Data.Char as Char +import qualified Data.List as List +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, isJust) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Data.VCS.Ignore.Git.Internal.Pattern ( + Pattern, + PatternGroup (..), + evaluatePatternGroups, + loadPatternsFile, + ) +import Data.VCS.Ignore.Types ( + GitError (..), + PathKind (..), + ) +import System.Directory ( + XdgDirectory (XdgConfig), + canonicalizePath, + doesDirectoryExist, + doesFileExist, + getXdgDirectory, + makeAbsolute, + ) +import System.FilePath ( + isAbsolute, + makeRelative, + pathSeparator, + takeDirectory, + (), + ) +import qualified System.FilePath.Posix as Posix + +-- | An opened Git working tree. Repository-level rules are captured when the +-- session is opened, while working-tree @.gitignore@ files are loaded and +-- cached on first use. +data GitRepository = GitRepository + { gitRepositoryRoot :: FilePath + , gitRepositoryGitDirectory :: FilePath + , gitRepositoryCommonDirectory :: FilePath + , gitRepositoryBasePatterns :: [Pattern] + , gitRepositoryRuleCache :: MVar (Map.Map FilePath RulePromise) + } + +data RuleLoadResult + = RuleLoadFinished (Either SomeException PatternGroup) + | RuleLoadCancelled + +type RulePromise = MVar RuleLoadResult + +-- | Open a Git working tree without scanning its contents. +openGitRepository :: FilePath -> IO GitRepository +openGitRepository path = do + root <- makeAbsolute path >>= canonicalizePath + isDirectory <- doesDirectoryExist root + unless isDirectory (throwIO $ NotGitRepository root) + gitDirectory <- resolveGitDirectory root + commonDirectory <- resolveCommonDirectory gitDirectory + globalIgnore <- getXdgDirectory XdgConfig ("git" "ignore") + globalPatterns <- loadPatternsFile True globalIgnore + repositoryPatterns <- + loadPatternsFile True (commonDirectory "info" "exclude") + cache <- newMVar Map.empty + pure + GitRepository + { gitRepositoryRoot = root + , gitRepositoryGitDirectory = gitDirectory + , gitRepositoryCommonDirectory = commonDirectory + , gitRepositoryBasePatterns = globalPatterns <> repositoryPatterns + , gitRepositoryRuleCache = cache + } + +-- | Find and open the nearest enclosing Git working tree. +findGitRepository :: FilePath -> IO (Maybe GitRepository) +findGitRepository path = do + absolute <- makeAbsolute path + isDirectory <- doesDirectoryExist absolute + start <- canonicalizePath $ if isDirectory then absolute else takeDirectory absolute + go start + where + go directory = do + hasMetadata <- gitMetadataExists directory + let parent = takeDirectory directory + if hasMetadata + then Just <$> openGitRepository directory + else + if parent == directory + then pure Nothing + else go parent + +-- | Return the canonical absolute root of the working tree. +repositoryRoot :: GitRepository -> FilePath +repositoryRoot = gitRepositoryRoot + +-- | Check a repository-relative path against Git ignore rules. The supplied +-- kind is authoritative; the candidate itself is never inspected. +isIgnored :: GitRepository -> PathKind -> FilePath -> IO Bool +isIgnored repository kind rawPath = + case validateRepositoryPath rawPath of + Left err -> throwIO err + Right relative + | relative == "." -> pure False + | isRepositoryMetadata repository relative -> pure True + | otherwise -> do + initialGroups <- rootRuleContext repository + evaluateAncestors initialGroups (ancestorDirectories relative) + where + evaluateAncestors groups [] = + pure $ evaluatePatternGroups kind groups relative + evaluateAncestors groups (directory : directories) + | evaluatePatternGroups Directory groups directory = pure True + | otherwise = do + directoryGroup <- loadDirectoryRules repository directory + evaluateAncestors (groups <> [directoryGroup]) directories + +-- | Rules applicable to entries directly under the repository root. Base +-- rules precede the lazily loaded root @.gitignore@ group. +rootRuleContext :: GitRepository -> IO [PatternGroup] +rootRuleContext repository = do + rootRules <- loadDirectoryRules repository "." + pure + [ PatternGroup + { patternGroupPrefix = "/" + , patternGroupPatterns = gitRepositoryBasePatterns repository + } + , rootRules + ] + +-- | Load and cache the @.gitignore@ belonging to a repository-relative +-- directory. Symlinked ignore files are deliberately not followed. +loadDirectoryRules :: GitRepository -> FilePath -> IO PatternGroup +loadDirectoryRules repository = + loadDirectoryRulesWith repository $ \directory -> + loadPatternsFile False $ + repositoryRoot repository + fromPosix directory + ".gitignore" + +-- | Variant with an injectable loader for concurrency tests. +loadDirectoryRulesWith :: + GitRepository -> + (FilePath -> IO [Pattern]) -> + FilePath -> + IO PatternGroup +loadDirectoryRulesWith repository loadPatterns rawDirectory = do + directory <- + case validateRepositoryPath rawDirectory of + Left err -> throwIO err + Right validDirectory -> pure validDirectory + mask $ \restore -> do + (promise, ownsLoad) <- + modifyMVar (gitRepositoryRuleCache repository) $ \cache -> + case Map.lookup directory cache of + Just existing -> pure (cache, (existing, False)) + Nothing -> do + created <- newEmptyMVar + pure (Map.insert directory created cache, (created, True)) + if ownsLoad + then do + result <- try . restore $ loadRules directory + if either isAsyncException (const False) result + then do + modifyMVar_ + (gitRepositoryRuleCache repository) + (pure . Map.delete directory) + putMVar promise RuleLoadCancelled + either throwIO pure result + else do + putMVar promise $ RuleLoadFinished result + either throwIO pure result + else do + cached <- restore $ readMVar promise + case cached of + RuleLoadFinished result -> either throwIO pure result + RuleLoadCancelled -> + loadDirectoryRulesWith repository loadPatterns directory + where + loadRules directory = do + patterns <- loadPatterns directory + pure + PatternGroup + { patternGroupPrefix = groupPrefix directory + , patternGroupPatterns = patterns + } + + isAsyncException exception = + isJust (fromException exception :: Maybe AsyncException) + +-- | Whether a repository-relative path names the working tree's own Git +-- metadata. Nested @.git@ names belong to nested working trees and are not +-- classified as this repository's metadata. +isRepositoryMetadata :: GitRepository -> FilePath -> Bool +isRepositoryMetadata repository path = + any (`containsPath` candidate) metadataPaths + where + candidate = Posix.normalise $ toPosix path + metadataPaths = + ".git" + : foldr + addInternalMetadata + [] + [ gitRepositoryGitDirectory repository + , gitRepositoryCommonDirectory repository + ] + addInternalMetadata absolutePath paths = + let relative = toPosix $ makeRelative (repositoryRoot repository) absolutePath + in if isOutside relative || relative == "." + then paths + else Posix.normalise relative : paths + containsPath metadata candidatePath = + candidatePath == metadata + || (metadata <> "/") `List.isPrefixOf` candidatePath + +-- | Validate and normalize a repository-relative lexical path. +validateRepositoryPath :: FilePath -> Either GitError FilePath +validateRepositoryPath rawPath + | invalid = Left $ InvalidRepositoryPath rawPath + | otherwise = Right normalized + where + posixPath = toPosix rawPath + components = Posix.splitDirectories posixPath + invalid = + isAbsolute rawPath + || Posix.isAbsolute posixPath + || (pathSeparator == '\\' && hasWindowsDrive posixPath) + || '\NUL' `elem` rawPath + || ".." `elem` components + normalized = + case Posix.normalise posixPath of + "" -> "." + value -> value + +-- | Convert a repository-relative directory to a normalized pattern-group +-- prefix. +groupPrefix :: FilePath -> FilePath +groupPrefix directory + | normalized `elem` ["", ".", "/"] = "/" + | otherwise = "/" <> stripSlashes normalized <> "/" + where + normalized = Posix.normalise $ toPosix directory + +resolveGitDirectory :: FilePath -> IO FilePath +resolveGitDirectory root = do + let metadata = root ".git" + isDirectory <- doesDirectoryExist metadata + if isDirectory + then canonicalizePath metadata + else do + isFile <- doesFileExist metadata + if isFile + then resolveGitFile root metadata + else throwIO $ NotGitRepository root + +resolveGitFile :: FilePath -> FilePath -> IO FilePath +resolveGitFile root metadata = do + firstLine <- readFirstLine metadata + case Text.stripPrefix "gitdir:" firstLine of + Nothing -> + throwIO $ + InvalidGitMetadata metadata "expected a 'gitdir:' declaration" + Just rawGitDirectory -> do + let declared = Text.unpack $ Text.strip rawGitDirectory + if null declared + then throwIO $ InvalidGitMetadata metadata "empty gitdir path" + else do + let resolved = + if isAbsolute declared + then declared + else root declared + exists <- doesDirectoryExist resolved + unless exists $ + throwIO (InvalidGitMetadata metadata "gitdir does not exist") + canonicalizePath resolved + +resolveCommonDirectory :: FilePath -> IO FilePath +resolveCommonDirectory gitDirectory = do + let commonFile = gitDirectory "commondir" + exists <- doesFileExist commonFile + if not exists + then pure gitDirectory + else do + rawCommonDirectory <- Text.unpack . Text.strip <$> readFirstLine commonFile + if null rawCommonDirectory + then throwIO $ InvalidGitMetadata commonFile "empty commondir path" + else do + let resolved = + if isAbsolute rawCommonDirectory + then rawCommonDirectory + else gitDirectory rawCommonDirectory + isDirectory <- doesDirectoryExist resolved + unless isDirectory $ + throwIO (InvalidGitMetadata commonFile "commondir does not exist") + canonicalizePath resolved + +readFirstLine :: FilePath -> IO Text.Text +readFirstLine path = do + content <- Text.readFile path + pure . fromMaybe Text.empty . safeHead $ Text.lines content + +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (value : _) = Just value + +gitMetadataExists :: FilePath -> IO Bool +gitMetadataExists root = do + let metadata = root ".git" + isDirectory <- doesDirectoryExist metadata + isFile <- doesFileExist metadata + pure $ isDirectory || isFile + +ancestorDirectories :: FilePath -> [FilePath] +ancestorDirectories relative = + case directoryComponents of + [] -> [] + first : rest -> scanl (Posix.) first rest + where + directory = Posix.takeDirectory relative + directoryComponents = + filter (`notElem` ["", ".", "/"]) $ + Posix.splitDirectories directory + +hasWindowsDrive :: FilePath -> Bool +hasWindowsDrive (letter : ':' : _) = Char.isAlpha letter +hasWindowsDrive _ = False + +isOutside :: FilePath -> Bool +isOutside path = + Posix.isAbsolute path + || case Posix.splitDirectories path of + ".." : _ -> True + _ -> False + +toPosix :: FilePath -> FilePath +toPosix = fmap replaceSeparator + where + replaceSeparator character + | character == pathSeparator = '/' + | otherwise = character + +fromPosix :: FilePath -> FilePath +fromPosix "." = "" +fromPosix path = fmap replaceSeparator path + where + replaceSeparator '/' = pathSeparator + replaceSeparator character = character + +stripSlashes :: FilePath -> FilePath +stripSlashes = List.dropWhileEnd (== '/') . dropWhile (== '/') diff --git a/src/Data/VCS/Ignore/Git/Internal/Traversal.hs b/src/Data/VCS/Ignore/Git/Internal/Traversal.hs new file mode 100644 --- /dev/null +++ b/src/Data/VCS/Ignore/Git/Internal/Traversal.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module : Data.VCS.Ignore.Git.Internal.Traversal +-- Description : Pruning, early-stopping traversal of a Git working tree +-- Copyright : (c) 2020-2026 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : portable +module Data.VCS.Ignore.Git.Internal.Traversal ( + foldRepo, + walkRepo, + forRepo_, + listRepo, +) where + +import Control.Monad (void) +import Data.VCS.Ignore.Git.Internal.Pattern ( + PatternGroup, + evaluatePatternGroups, + ) +import Data.VCS.Ignore.Git.Internal.Repository ( + GitRepository, + isRepositoryMetadata, + loadDirectoryRules, + repositoryRoot, + rootRuleContext, + ) +import Data.VCS.Ignore.Types ( + Entry (..), + PathKind (..), + WalkAction (..), + WalkResult (..), + ) +import System.Directory ( + doesDirectoryExist, + doesFileExist, + doesPathExist, + listDirectory, + pathIsSymbolicLink, + ) +import System.FilePath (()) +import System.IO.Error ( + isDoesNotExistError, + tryIOError, + ) + +data WorkItem + = VisitDirectory [PatternGroup] FilePath + | VisitEntry [PatternGroup] FilePath + +-- | Folds visible repository entries in depth-first preorder. +-- +-- The repository root is not passed to the callback. Ignored directories and +-- repository metadata are pruned before the callback is invoked. A callback +-- can prune any other directory or stop the complete traversal. Symbolic links +-- are emitted as links and are never followed. Sibling order is the order +-- supplied by the filesystem and is intentionally unspecified. +foldRepo :: + GitRepository -> + state -> + (state -> Entry -> IO (state, WalkAction)) -> + IO (WalkResult state) +foldRepo repository initialState step = do + initialState `seq` pure () + rules <- rootRuleContext repository + loop initialState [VisitDirectory rules ""] + where + loop !state [] = pure $ WalkCompleted state + loop !state (VisitDirectory rules relativeDirectory : pending) = do + namesResult <- tryIOError . listDirectory $ absolutePath relativeDirectory + case namesResult of + Left error' + | isDoesNotExistError error' -> loop state pending + | otherwise -> ioError error' + Right names -> do + let entries = VisitEntry rules . childPath relativeDirectory <$> names + loop state (entries <> pending) + loop !state (VisitEntry rules relative : pending) = + if isRepositoryMetadata repository relative + then loop state pending + else do + maybeKind <- classifyPath $ absolutePath relative + case maybeKind of + Nothing -> loop state pending + Just kind -> + if evaluatePatternGroups kind rules relative + then loop state pending + else do + (!nextState, action) <- step state $ Entry relative kind + continueFrom rules pending relative kind nextState action + + continueFrom _ _ _ _ !state Stop = pure $ WalkStopped state + continueFrom rules pending relative Directory !state Continue = do + currentKind <- classifyPath $ absolutePath relative + case currentKind of + Just Directory -> do + directoryRules <- loadDirectoryRules repository relative + loop state $ VisitDirectory (rules <> [directoryRules]) relative : pending + _ -> loop state pending + continueFrom _ pending _ _ !state _ = loop state pending + + absolutePath "" = repositoryRoot repository + absolutePath relative = repositoryRoot repository relative + +-- | Walks visible entries for their effects and traversal control. +walkRepo :: + GitRepository -> + (Entry -> IO WalkAction) -> + IO (WalkResult ()) +walkRepo repository action = foldRepo repository () step + where + step () entry = do + nextAction <- action entry + pure ((), nextAction) + +-- | Performs an action for every visible entry. +forRepo_ :: GitRepository -> (Entry -> IO ()) -> IO () +forRepo_ repository action = + void (walkRepo repository $ \entry -> action entry >> pure Continue) + +-- | Lists all visible repository entries in traversal order. +listRepo :: GitRepository -> IO [Entry] +listRepo repository = do + result <- foldRepo repository [] collect + pure . reverse $ case result of + WalkCompleted entries -> entries + WalkStopped entries -> entries + where + collect entries entry = pure (entry : entries, Continue) + +childPath :: FilePath -> FilePath -> FilePath +childPath "" name = name +childPath parent name = parent name + +-- A path may disappear after its name was returned by 'listDirectory'. Such an +-- entry is skipped, while all other I/O errors retain their original failure. +classifyPath :: FilePath -> IO (Maybe PathKind) +classifyPath path = do + symbolicLinkResult <- tryIOError $ pathIsSymbolicLink path + case symbolicLinkResult of + Left error' + | isDoesNotExistError error' -> pure Nothing + | otherwise -> ioError error' + Right True -> pure $ Just SymbolicLink + Right False -> classifyNonLink + where + classifyNonLink = do + isDirectory <- doesDirectoryExist path + if isDirectory + then pure $ Just Directory + else do + isFile <- doesFileExist path + if isFile + then pure $ Just RegularFile + else do + exists <- doesPathExist path + pure $ if exists then Just Other else Nothing diff --git a/src/Data/VCS/Ignore/Repo.hs b/src/Data/VCS/Ignore/Repo.hs deleted file mode 100644 --- a/src/Data/VCS/Ignore/Repo.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE StrictData #-} - -{-| -Module : Data.VCS.Ignore.Repo -Description : Type class representing the VCS repository -Copyright : (c) 2020-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -This module contains /type class/ representing the selected type of /VCS/ -repository. --} - -module Data.VCS.Ignore.Repo - ( Repo(..) - , RepoError(..) - ) -where - -import Control.Exception ( Exception(..) ) -import Control.Monad.Catch ( MonadThrow ) -import Control.Monad.IO.Class ( MonadIO ) -import Data.Text ( Text ) -import qualified Data.Text as T -import Data.VCS.Ignore.Types ( fromVCSIgnoreError - , toVCSIgnoreError - ) - - --- | /Type class/ representing instance of /VCS/ repository of selected type. --- In order to obtain instance, the physical repository needs to be scanned --- first by the 'scanRepo' method. Then absolute path to the repository root is --- provided by 'repoRoot' method. To check if any path (relative to the repo --- root) is ignored or not, use the 'isIgnored' method. -class Repo r where - - -- | Returns name of the repository (e.g. @GIT@). - repoName :: r -- ^ /VCS/ repository instance - -> Text -- ^ name of the repository - - -- | Returns absolute path to the root of the /VCS/ repository. - repoRoot :: r -- ^ /VCS/ repository instance - -> FilePath -- ^ absolute path to the repository - - -- | Scans repository at given path. If the given path doesn't contain valid - -- repository, 'RepoError' may be thrown. - scanRepo :: (MonadIO m, MonadThrow m) - => FilePath -- ^ path to the /VCS/ repository root - -> m r -- ^ scanned repository (or failure) - - -- | Checks whether the given path is ignored. The input path is expected to - -- be relative to the repository root, it might or might not point to existing - -- file or directory. - isIgnored :: MonadIO m - => r -- ^ /VCS/ repository instance - -> FilePath -- ^ path to check, relative to the repository root - -> m Bool -- ^ whether the path is ignored or not - - --- | Represents error related to operations over the /VCS/ repository. -data RepoError = InvalidRepo FilePath Text - -- ^ Given 'FilePath' doesn't contain valid /VCS/ repository root. - deriving (Eq, Show) - -instance Exception RepoError where - displayException = displayException' - fromException = fromVCSIgnoreError - toException = toVCSIgnoreError - - -displayException' :: RepoError -> String -displayException' (InvalidRepo path reason) = - mconcat ["Path '", path, "' is not a valid repository: ", T.unpack reason] diff --git a/src/Data/VCS/Ignore/Repo/Git.hs b/src/Data/VCS/Ignore/Repo/Git.hs deleted file mode 100644 --- a/src/Data/VCS/Ignore/Repo/Git.hs +++ /dev/null @@ -1,272 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TupleSections #-} - -{-| -Module : Data.VCS.Ignore.Repo.Git -Description : Implementation of 'Repo' for /GIT/ -Copyright : (c) 2020-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -This module contains implementation of 'Repo' /type class/ for the /GIT/ content -versioning system. Most of the public functions is exported only to make them -visible for tests, end user of this library really shouldn't need to use them. --} - -module Data.VCS.Ignore.Repo.Git - ( Git(..) - , Pattern(..) - , compilePattern - , matchesPattern - , parsePatterns - , loadPatterns - , findGitIgnores - , gitIgnorePatterns - , repoPatterns - , globalPatterns - , scanRepo' - , isIgnored' - , isGitRepo - ) -where - -import Control.Exception ( SomeException - , catch - ) -import Control.Monad.Catch ( MonadThrow - , throwM - ) -import Control.Monad.IO.Class ( MonadIO - , liftIO - ) -import qualified Data.List as L -import Data.Maybe ( fromMaybe - , maybeToList - ) -import Data.String ( IsString(..) ) -import Data.Text ( Text ) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Data.VCS.Ignore.FileSystem ( findPaths - , toPosixPath - ) -import Data.VCS.Ignore.Repo ( Repo(..) - , RepoError(..) - ) -import System.Directory ( XdgDirectory(XdgConfig) - , canonicalizePath - , doesDirectoryExist - , getXdgDirectory - , makeAbsolute - ) -import System.FilePath ( makeRelative - , () - ) -import qualified System.FilePath.Glob as G - - --- | Data type representing scanned instance of /GIT/ repository. -data Git = Git - { gitRepoRoot :: FilePath -- ^ absolute path to the repository - , gitPatterns :: [(FilePath, [Pattern])] -- ^ ignored patterns - } - deriving (Eq, Show) - -instance Repo Git where - repoName = const "Git" - repoRoot = gitRepoRoot - scanRepo = scanRepo' globalPatterns repoPatterns gitIgnorePatterns isGitRepo - isIgnored = isIgnored' - --- | Represents single pattern to be used as a rule for ignoring paths. -data Pattern = Pattern - { pPatterns :: [G.Pattern] -- ^ underlying implementation - , pRaw :: Text -- ^ raw textual representation of the pattern - , pIsNegated :: Bool -- ^ if the pattern is negation (starts with @!@) - } - deriving (Eq, Show) - -instance IsString Pattern where - fromString = compilePattern . T.pack - - ------------------------------- PUBLIC FUNCTIONS ------------------------------ - --- | Compiles pattern. -compilePattern :: Text -- ^ raw pattern as text - -> Pattern -- ^ compiled pattern -compilePattern raw = - let woPrefix = fromMaybe raw $ T.stripPrefix "!" raw - patterns = r2 . r1 $ woPrefix - in Pattern { pPatterns = fmap (G.compile . T.unpack) patterns - , pRaw = raw - , pIsNegated = raw /= woPrefix - } - where - r1 p | any (`T.isPrefixOf` p) ["/", "*"] = p - | length (filter (not . T.null) . T.splitOn "/" $ p) == 1 = "**/" <> p - | otherwise = "/" <> p - r2 p | "/" `T.isSuffixOf` p = [p <> "**"] - | otherwise = [p, p <> "/**"] - - --- | Tests whether given path matches against the pattern. -matchesPattern :: Pattern -- ^ pattern to match against - -> FilePath -- ^ path to check - -> Bool -- ^ check result -matchesPattern ptn path = any (`G.match` path) (pPatterns ptn) - - --- | Parses /Glob/ patterns from given text source. Each line in input text is --- considered to be single pattern. Lines starting with @#@ (comments) and blank --- lines are skipped. --- --- >>> parsePatterns "*.xml\n.DS_Store" --- [Pattern {pPatterns = [compile "*.xml",compile "*.xml/*"], pRaw = "*.xml", pIsNegated = False},Pattern {pPatterns = [compile "**/.DS_Store",compile "**/.DS_Store/*"], pRaw = ".DS_Store", pIsNegated = False}] -parsePatterns :: Text -- ^ text to parse - -> [Pattern] -- ^ parsed patterns -parsePatterns = fmap compilePattern . filter (not . excluded) . T.lines - where - excluded = \line -> or $ fmap ($ T.stripStart line) [comment, T.null] - comment = \line -> "#" `T.isPrefixOf` line - - --- | Loads /Glob/ patterns from given text file. If the fille cannot be read for --- any reason, empty list is returned. See 'parsePatterns' for more details --- about parsing. -loadPatterns :: MonadIO m - => FilePath -- ^ path to text file to parse - -> m [Pattern] -- ^ parsed /Glob/ patterns -loadPatterns path = parsePatterns <$> liftIO content - where - content = catch (T.readFile path) (\(_ :: SomeException) -> pure T.empty) - - --- | Recursively finds all @.gitignore@ files within the given directory path. -findGitIgnores :: MonadIO m - => FilePath -- ^ path to the directory to search in - -> m [FilePath] -- ^ paths of found @.gitignore@ files -findGitIgnores repoDir = findPaths repoDir isGitIgnore - where isGitIgnore path = pure $ ".gitignore" `L.isSuffixOf` path - - --- | Recursively finds all @.gitignore@ files within the given directory path --- and parses them into /Glob/ patterns. See 'loadPatterns' and 'findGitIgnores' --- for more details. -gitIgnorePatterns :: MonadIO m - => FilePath - -- ^ path to the directory to search @.gitignore@ files in - -> m [(FilePath, [Pattern])] - -- ^ list of @.gitignore@ paths and parsed /Glob/ patterns -gitIgnorePatterns repoDir = do - gitIgnores <- findGitIgnores repoDir - mapM (\p -> (toPosixPath . path $ p, ) <$> loadPatterns p) gitIgnores - where path p = stripSuffix' ".gitignore" $ stripPrefix' repoDir p - - --- | Loads /GIT/ repository specific ignore patterns, present in --- @REPO_ROOT\/info\/exclude@ file. -repoPatterns :: MonadIO m - => FilePath -- ^ path to the /GIT/ repository root - -> m [Pattern] -- ^ parsed /Glob/ patterns -repoPatterns repoDir = loadPatterns $ repoDir "info" "exclude" - - --- | Loads global /GIT/ ignore patterns, present in --- @XDG_CONFIG_GOME\/git\/ignore@ file. -globalPatterns :: MonadIO m => m [Pattern] -globalPatterns = - (liftIO . getXdgDirectory XdgConfig $ ("git" "ignore")) >>= loadPatterns - - --- | Internal version of 'scanRepo', where individual functions needs to be --- explicitly provided, which is useful mainly for testing purposes. -scanRepo' :: (MonadIO m, MonadThrow m) - => m [Pattern] - -- ^ reference to 'globalPatterns' function (or similar) - -> (FilePath -> m [Pattern]) - -- ^ reference to 'repoPatterns' function (or similar) - -> (FilePath -> m [(FilePath, [Pattern])]) - -- ^ reference to 'gitIgnorePatterns' function (or similar) - -> (FilePath -> m Bool) - -- ^ reference to 'isGitRepo' function (or similar) - -> FilePath - -- ^ path to /GIT/ repository root - -> m Git - -- ^ scanned /Git/ repository -scanRepo' globalPatternsFn repoPatternsFn gitIgnoresFn isGitRepoFn repoDir = do - absRepoDir <- liftIO $ makeAbsolute repoDir - gitRepo <- isGitRepoFn absRepoDir - (if gitRepo then proceed else abort) absRepoDir - where - abort repoDir' = throwM $ InvalidRepo repoDir' "not a valid GIT repository" - proceed repoDir' = do - globalPatterns' <- globalPatternsFn - repoPatterns' <- repoPatternsFn repoDir' - gitIgnores <- gitIgnoresFn repoDir' - let (r, o) = sep gitIgnores - patterns = [("/", globalPatterns' <> repoPatterns' <> r)] <> o - pure Git { gitRepoRoot = repoDir', gitPatterns = patterns } - sep xs = - let predicate = \(p, _) -> p == "/" - woRoot = filter (not . predicate) xs - root = concat . maybeToList $ snd <$> L.find predicate xs - in (root, woRoot) - - --- | Internal version of 'isIgnored' function. -isIgnored' :: MonadIO m - => Git -- ^ scanned /GIT/ repository - -> FilePath -- ^ path to check if ignored - -> m Bool -- @True@ if given path is ignored -isIgnored' git@(Git _ patterns) path = do - np <- toPosixPath <$> normalize (repoRoot git) path - let ignored = any (check2 np False) (filtered np) - negated = any (check2 np True) (filtered np) - pure $ ignored && not negated - where - sanitized = addPrefix "/" - asRepoPath = \np -> (`stripPrefix'` sanitized np) - filtered = \np -> filter (onPath np) patterns - onPath = \np (p, _) -> p `L.isPrefixOf` sanitized np - check2 = \np negated (prefix, ptns) -> - any (`matchesPattern` asRepoPath np prefix) - . filter (\p -> pIsNegated p == negated) - $ ptns - - --- | Checks whether given directory path is valid /GIT/ repository. -isGitRepo :: MonadIO m - => FilePath -- ^ path to the directory to check - -> m Bool -- ^ @True@ if the given directory is valid repository -isGitRepo path = liftIO . doesDirectoryExist $ path ".git" - - ------------------------------- PRIVATE FUNCTIONS ----------------------------- - -addPrefix :: String -> String -> String -addPrefix prefix str | prefix `L.isPrefixOf` str = str - | otherwise = prefix <> str - - -stripPrefix' :: String -> String -> String -stripPrefix' prefix str = - maybe str T.unpack (T.stripPrefix (T.pack prefix) (T.pack str)) - - -stripSuffix' :: String -> String -> String -stripSuffix' suffix str = - maybe str T.unpack (T.stripSuffix (T.pack suffix) (T.pack str)) - - -normalize :: MonadIO m => FilePath -> FilePath -> m FilePath -normalize repoDir path = do - canonicalized <- liftIO . canonicalizePath $ repoDir stripPrefix' "/" path - isDir <- liftIO $ doesDirectoryExist canonicalized - let suffix = if isDir || "/" `L.isSuffixOf` path then "/" else "" - pure $ makeRelative repoDir canonicalized <> suffix - diff --git a/src/Data/VCS/Ignore/Types.hs b/src/Data/VCS/Ignore/Types.hs --- a/src/Data/VCS/Ignore/Types.hs +++ b/src/Data/VCS/Ignore/Types.hs @@ -1,56 +1,73 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE StrictData #-} - -{-| -Module : Data.VCS.Ignore.Types -Description : Shared data types -Copyright : (c) 2020-2022 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -This module contains data types and functions shared across the library. --} - -module Data.VCS.Ignore.Types - ( VCSIgnoreError(..) - , fromVCSIgnoreError - , toVCSIgnoreError - ) -where - -import Control.Exception ( Exception(..) - , SomeException - ) -import Data.Typeable ( cast ) - - ---------------------------------- DATA TYPES --------------------------------- +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE StrictData #-} --- | Top-level of any exception thrown by this library. -data VCSIgnoreError = forall e . Exception e => VCSIgnoreError e +-- | +-- Module : Data.VCS.Ignore.Types +-- Description : Public types shared by repository queries and traversal +-- Copyright : (c) 2020-2026 Vaclav Svejcar +-- License : BSD-3-Clause +-- Maintainer : vaclav.svejcar@gmail.com +-- Stability : experimental +-- Portability : portable +module Data.VCS.Ignore.Types ( + PathKind (..), + Entry (..), + WalkAction (..), + WalkResult (..), + GitError (..), +) where -instance Show VCSIgnoreError where - show (VCSIgnoreError e) = show e +import Control.Exception (Exception (..)) +import Data.Text (Text) +import qualified Data.Text as T -instance Exception VCSIgnoreError where - displayException (VCSIgnoreError e) = displayException e +-- | Filesystem kind supplied to ignore queries and repository callbacks. +-- Only 'Directory' receives directory-only Git pattern semantics. Symbolic +-- links are never followed, even when their target is a directory. +data PathKind + = RegularFile + | Directory + | SymbolicLink + | Other + deriving (Eq, Ord, Show) +-- | A non-ignored repository entry. The path is always relative to the +-- repository root. +-- +-- >>> entryPath (Entry "src/Main.hs" RegularFile) +-- "src/Main.hs" +data Entry = Entry + { entryPath :: FilePath + , entryKind :: PathKind + } + deriving (Eq, Ord, Show) ------------------------------- PUBLIC FUNCTIONS ------------------------------ +-- | Controls repository traversal after processing a visible entry. +data WalkAction + = Continue + | Prune + | Stop + deriving (Eq, Ord, Show) --- | Unwraps given exception from 'VCSIgnoreError'. -fromVCSIgnoreError :: Exception e - => SomeException -- ^ exception to unwrap - -> Maybe e -- ^ unwrapped exception -fromVCSIgnoreError e = do - VCSIgnoreError e' <- fromException e - cast e' +-- | Indicates whether a repository fold visited all reachable entries or was +-- stopped early by its callback. +data WalkResult a + = WalkCompleted !a + | WalkStopped !a + deriving (Eq, Functor, Show) +-- | Errors caused by invalid Git repository metadata or query paths. Ordinary +-- filesystem failures retain their original 'IOError'. +data GitError + = NotGitRepository FilePath + | InvalidRepositoryPath FilePath + | InvalidGitMetadata FilePath Text + deriving (Eq, Show) --- | Wraps given exception from 'VCSIgnoreError'. -toVCSIgnoreError :: Exception e - => e -- ^ exception to wrap - -> SomeException -- ^ wrapped exception -toVCSIgnoreError = toException . VCSIgnoreError +instance Exception GitError where + displayException (NotGitRepository path) = + "Path '" <> path <> "' is not a Git working tree" + displayException (InvalidRepositoryPath path) = + "Path '" <> path <> "' is not a valid repository-relative path" + displayException (InvalidGitMetadata path reason) = + mconcat ["Invalid Git metadata at '", path, "': ", T.unpack reason] diff --git a/test/Data/VCS/Ignore/CoreSpec.hs b/test/Data/VCS/Ignore/CoreSpec.hs deleted file mode 100644 --- a/test/Data/VCS/Ignore/CoreSpec.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TypeApplications #-} - -module Data.VCS.Ignore.CoreSpec - ( spec - ) -where - -import Control.Monad.Catch ( throwM ) -import qualified Data.List as L -import Data.VCS.Ignore.Core - -import Data.VCS.Ignore.Repo ( Repo(..) - , RepoError(..) - ) -import System.FilePath ( () ) -import Test.Hspec - - -spec :: Spec -spec = do - - describe "findRepo" $ do - it "finds repo for some path inside repo" $ do - let path = testRepoRoot "a" "b" - expected = TestRepo testRepoRoot - findRepo path `shouldReturn` Just expected - - it "finds no repo for path outside repo" $ do - let path = "some" "path" - findRepo path `shouldReturn` Nothing @TestRepo - - - describe "listRepo" $ do - it "lists repository paths, based on the search filter" $ do - let expected = - [ ".gitignore" - , "a" - , "a" ".gitignore" - , "a" "b" - , "a" "b" ".gitignore" - , "a" "b" "test-b.txt" - , "a" "b" "test-b.xml" - , "a" "test-a.txt" - , "a" "test-a.xml" - ] - repo <- scanRepo @TestRepo testRepoRoot - result <- listRepo repo - L.sort result `shouldBe` L.sort expected - - - describe "walkRepo" $ do - it "walks repository paths, based on the search filter" $ do - let fn = \path -> pure ("foo" path) - expected = - [ "foo" ".gitignore" - , "foo" "a" - , "foo" "a" ".gitignore" - , "foo" "a" "b" - , "foo" "a" "b" ".gitignore" - , "foo" "a" "b" "test-b.txt" - , "foo" "a" "b" "test-b.xml" - , "foo" "a" "test-a.txt" - , "foo" "a" "test-a.xml" - ] - repo <- scanRepo @TestRepo testRepoRoot - result <- walkRepo repo fn - L.sort result `shouldBe` L.sort expected - - -data TestRepo = TestRepo - { trPath :: FilePath - } - deriving (Eq, Show) - -instance Repo TestRepo where - repoName = const "TestRepo" - repoRoot TestRepo {..} = trPath - scanRepo path | path == testRepoRoot = pure TestRepo { trPath = path } - | otherwise = throwM $ InvalidRepo path "err" - isIgnored _ path = pure $ "excluded.txt" `L.isSuffixOf` path - - -testRepoRoot :: FilePath -testRepoRoot = "test-data" "fake-git-repo" diff --git a/test/Data/VCS/Ignore/FileSystemSpec.hs b/test/Data/VCS/Ignore/FileSystemSpec.hs deleted file mode 100644 --- a/test/Data/VCS/Ignore/FileSystemSpec.hs +++ /dev/null @@ -1,65 +0,0 @@ -module Data.VCS.Ignore.FileSystemSpec - ( spec - ) -where - -import qualified Data.List as L -import Data.Maybe ( catMaybes ) -import Data.VCS.Ignore.FileSystem -import System.FilePath ( () ) -import Test.Hspec - - -spec :: Spec -spec = do - describe "findPaths" $ do - it "recursively finds paths filtered by given predicate" $ do - let expected = - ["test-data" "list-files" "dir1" "dir2" "d.xml"] - predicate = pure <$> ("d.xml" `L.isSuffixOf`) - result <- findPaths ("test-data" "list-files") predicate - result `shouldBe` expected - - - describe "listPaths" $ do - it "returns empty list if path doesn't exist" $ do - filePaths <- listPaths "non-existing-path" - filePaths `shouldBe` [] - - it "recursively finds all paths in directory" $ do - result <- listPaths $ "test-data" "list-files" - let expected = - [ "test-data" "list-files" - , "test-data" "list-files" "a.txt" - , "test-data" "list-files" "dir1" - , "test-data" "list-files" "dir1" "b.txt" - , "test-data" "list-files" "dir1" "dir2" - , "test-data" "list-files" "dir1" "dir2" "c.txt" - , "test-data" "list-files" "dir1" "dir2" "d.xml" - ] - L.sort result `shouldBe` L.sort expected - - - describe "walkPaths" $ do - it "recursively traverses and processes paths in directory" $ do - let - fn path = - if ".txt" `L.isSuffixOf` path then pure $ Just path else pure Nothing - expected = - [ "test-data" "list-files" "a.txt" - , "test-data" "list-files" "dir1" "b.txt" - , "test-data" "list-files" "dir1" "dir2" "c.txt" - ] - actual <- catMaybes <$> walkPaths ("test-data" "list-files") fn - L.sort actual `shouldBe` L.sort expected - - - describe "toPosixPath" $ do - it "replaces any backward slashes with forward ones" $ do - let sample = "foo\\bar\\x.txt" - expected = "foo/bar/x.txt" - toPosixPath sample `shouldBe` expected - - it "keep forwars slashes as is" $ do - let sample = "foo/bar/x.txt" - toPosixPath sample `shouldBe` sample diff --git a/test/Data/VCS/Ignore/Git/CompatibilitySpec.hs b/test/Data/VCS/Ignore/Git/CompatibilitySpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/VCS/Ignore/Git/CompatibilitySpec.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.VCS.Ignore.Git.CompatibilitySpec (spec) where + +import Control.Exception (bracket_) +import Control.Monad (unless) +import Data.VCS.Ignore ( + GitRepository, + PathKind (..), + isIgnored, + openGitRepository, + ) +import System.Directory (createDirectoryIfMissing) +import System.Environment ( + lookupEnv, + setEnv, + unsetEnv, + ) +import System.Exit (ExitCode (..)) +import System.FilePath ( + takeDirectory, + (), + ) +import System.IO.Temp (withSystemTempDirectory) +import System.Process (readProcessWithExitCode) +import Test.Hspec + +spec :: Spec +spec = describe "Git compatibility" $ do + gitExample "matches Git for ordered, anchored, recursive, and escaped rules" $ \root repository -> do + writeText + (root ".gitignore") + ( unlines + [ "*.log" + , "!keep.log" + , "keep.log" + , "/root.txt" + , "artifacts/**/result.bin" + , "cache/**" + , "file?.[ch]" + , "docs/[a-c].md" + , "build/" + , "\\#literal" + , "\\!important" + ] + ) + + assertMatchesGit repository root RegularFile "drop.log" "drop.log" + assertMatchesGit repository root RegularFile "keep.log" "keep.log" + assertMatchesGit repository root RegularFile "root.txt" "root.txt" + assertMatchesGit repository root RegularFile "nested/root.txt" "nested/root.txt" + assertMatchesGit repository root RegularFile "artifacts/a/b/result.bin" "artifacts/a/b/result.bin" + assertMatchesGit repository root RegularFile "cache/a/b/value" "cache/a/b/value" + assertMatchesGit repository root RegularFile "file1.c" "file1.c" + assertMatchesGit repository root RegularFile "file10.c" "file10.c" + assertMatchesGit repository root RegularFile "docs/b.md" "docs/b.md" + assertMatchesGit repository root Directory "build" "build/" + assertMatchesGit repository root RegularFile "#literal" "#literal" + assertMatchesGit repository root RegularFile "!important" "!important" + + gitExample "keeps descendants ignored when their parent is excluded" $ \root repository -> do + writeText (root ".gitignore") "build/\n" + writeText (root "build" ".gitignore") "!keep.txt\n" + + assertMatchesGit repository root Directory "build" "build/" + assertMatchesGit repository root RegularFile "build/keep.txt" "build/keep.txt" + + gitExample "allows re-inclusion while the parent directory remains visible" $ \root repository -> do + writeText (root ".gitignore") "build/*.txt\n!build/keep.txt\n" + + assertMatchesGit repository root Directory "build" "build/" + assertMatchesGit repository root RegularFile "build/drop.txt" "build/drop.txt" + assertMatchesGit repository root RegularFile "build/keep.txt" "build/keep.txt" + + gitExample "does not extend a parent wildcard below a re-included directory" $ \root repository -> do + writeText (root ".gitignore") "foo/*\n!foo/bar/\n" + + assertMatchesGit repository root Directory "foo/bar" "foo/bar/" + assertMatchesGit repository root RegularFile "foo/bar/file.txt" "foo/bar/file.txt" + + gitExample "treats Glob number ranges as Git literals" $ \root repository -> do + writeText (root ".gitignore") "value<1-3>.txt\n" + + assertMatchesGit repository root RegularFile "value1.txt" "value1.txt" + assertMatchesGit repository root RegularFile "value<1-3>.txt" "value<1-3>.txt" + + gitExample "preserves an escaped hyphen inside a character class" $ \root repository -> do + writeText (root ".gitignore") "[a\\-c].txt\n" + + assertMatchesGit repository root RegularFile "a.txt" "a.txt" + assertMatchesGit repository root RegularFile "-.txt" "-.txt" + assertMatchesGit repository root RegularFile "b.txt" "b.txt" + assertMatchesGit repository root RegularFile "c.txt" "c.txt" + +assertMatchesGit :: GitRepository -> FilePath -> PathKind -> FilePath -> FilePath -> Expectation +assertMatchesGit repository root kind repositoryPath gitPath = do + actual <- isIgnored repository kind repositoryPath + expected <- gitIgnores root gitPath + unless + (actual == expected) + ( expectationFailure $ + mconcat + [ "mismatch for " + , show repositoryPath + , " (Git path " + , show gitPath + , "): library=" + , show actual + , ", Git=" + , show expected + ] + ) + +gitIgnores :: FilePath -> FilePath -> IO Bool +gitIgnores root path = do + (exitCode, _, _) <- + readProcessWithExitCode + "git" + [ "-C" + , root + , "check-ignore" + , "--no-index" + , "--quiet" + , "--" + , path + ] + "" + case exitCode of + ExitSuccess -> pure True + ExitFailure 1 -> pure False + ExitFailure code -> expectationFailure ("git check-ignore failed with " <> show code) >> pure False + +gitExample :: String -> (FilePath -> GitRepository -> Expectation) -> Spec +gitExample description action = + it description . withSystemTempDirectory "vcs-ignore-git-compatibility" $ \sandbox -> + withEnvironment "XDG_CONFIG_HOME" (sandbox "xdg") $ do + let root = sandbox "repository" + createDirectoryIfMissing True root + initializeGit root + repository <- openGitRepository root + action root repository + +initializeGit :: FilePath -> IO () +initializeGit root = do + (exitCode, _, errors) <- readProcessWithExitCode "git" ["init", "--quiet", root] "" + case exitCode of + ExitSuccess -> pure () + ExitFailure code -> expectationFailure $ "git init failed with " <> show code <> ": " <> errors + +withEnvironment :: String -> String -> IO a -> IO a +withEnvironment name value action = do + original <- lookupEnv name + bracket_ (setEnv name value) (restore original) action + where + restore Nothing = unsetEnv name + restore (Just originalValue) = setEnv name originalValue + +writeText :: FilePath -> String -> IO () +writeText path content = do + createDirectoryIfMissing True $ takeDirectory path + writeFile path content diff --git a/test/Data/VCS/Ignore/Git/Internal/PatternSpec.hs b/test/Data/VCS/Ignore/Git/Internal/PatternSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/VCS/Ignore/Git/Internal/PatternSpec.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Data.VCS.Ignore.Git.Internal.PatternSpec where + +import Control.Exception ( + IOException, + bracket_, + try, + ) +import qualified Data.Text as T +import Data.VCS.Ignore.Git.Internal.Pattern +import Data.VCS.Ignore.Types (PathKind (..)) +import System.Directory ( + createDirectory, + createFileLink, + getPermissions, + readable, + setPermissions, + ) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec + +spec :: Spec +spec = do + describe "evaluatePatternGroups" $ do + it "uses the last matching pattern across ordered groups" $ do + let groups = + [ group "/" "*.log\n!keep.log\n" + , group "/nested/" "keep.log\n!keep.log\n" + ] + evaluatePatternGroups RegularFile groups "drop.log" `shouldBe` True + evaluatePatternGroups RegularFile groups "keep.log" `shouldBe` False + evaluatePatternGroups RegularFile groups "nested/keep.log" `shouldBe` False + + it "handles Git line parsing edge cases" $ do + let groups = + [ group + "/" + "# comment\r\n\\#literal\r\n\\!important\r\ntrailing \r\nescaped\\ \r\n" + ] + evaluatePatternGroups RegularFile groups "#literal" `shouldBe` True + evaluatePatternGroups RegularFile groups "!important" `shouldBe` True + evaluatePatternGroups RegularFile groups "trailing" `shouldBe` True + evaluatePatternGroups RegularFile groups "trailing " `shouldBe` False + evaluatePatternGroups RegularFile groups "escaped " `shouldBe` True + + it "applies directory-only patterns only to real directories" $ do + let groups = [group "/" "build/\n"] + evaluatePatternGroups Directory groups "build" `shouldBe` True + evaluatePatternGroups RegularFile groups "build" `shouldBe` False + evaluatePatternGroups SymbolicLink groups "build" `shouldBe` False + evaluatePatternGroups Other groups "build" `shouldBe` False + + it "respects anchoring, nested scopes, and recursive wildcards" $ do + let groups = + [ group "/" "/root.txt\na/**/result.txt\ntree/**\n**/marker\n" + , group "/nested/" "/local.txt\n" + ] + evaluatePatternGroups RegularFile groups "root.txt" `shouldBe` True + evaluatePatternGroups RegularFile groups "deep/root.txt" `shouldBe` False + evaluatePatternGroups RegularFile groups "a/result.txt" `shouldBe` True + evaluatePatternGroups RegularFile groups "a/b/c/result.txt" `shouldBe` True + evaluatePatternGroups RegularFile groups "tree/one/two/file" `shouldBe` True + evaluatePatternGroups RegularFile groups "marker" `shouldBe` True + evaluatePatternGroups RegularFile groups "deep/marker" `shouldBe` True + evaluatePatternGroups RegularFile groups "nested/local.txt" `shouldBe` True + evaluatePatternGroups RegularFile groups "nested/deep/local.txt" `shouldBe` False + + it "does not extend an ordinary pattern to every descendant" $ do + let groups = [group "/" "foo/*\n!foo/bar/\n"] + evaluatePatternGroups Directory groups "foo/bar" `shouldBe` False + evaluatePatternGroups RegularFile groups "foo/bar/file.txt" `shouldBe` False + + describe "loadPatternsFile" $ do + it "loads a regular ignore file" + . withSystemTempDirectory "vcs-ignore-patterns" + $ \directory -> do + let path = directory ".gitignore" + writeFile path "*.tmp\n" + patterns <- loadPatternsFile False path + evaluatePatternGroups RegularFile [PatternGroup "/" patterns] "file.tmp" + `shouldBe` True + + it "treats missing, non-regular, and non-followed symbolic-link sources as empty" + . withSystemTempDirectory "vcs-ignore-patterns" + $ \directory -> do + loadPatternsFile False (directory "missing") `shouldReturn` [] + let sourceDirectory = directory "directory-source" + createDirectory sourceDirectory + loadPatternsFile False sourceDirectory `shouldReturn` [] + let target = directory "rules" + link = directory ".gitignore" + writeFile target "*.tmp\n" + createFileLink target link + loadPatternsFile False link `shouldReturn` [] + + it "propagates errors from an existing unreadable source when supported" + . withSystemTempDirectory "vcs-ignore-patterns" + $ \directory -> do + let source = directory ".gitignore" + writeFile source "*.tmp\n" + permissions <- getPermissions source + result <- + bracket_ + (setPermissions source permissions{readable = False}) + (setPermissions source permissions) + (try @IOException $ loadPatternsFile True source) + case result of + Left _ -> pure () + Right _ -> pendingWith "unreadable file permissions are not enforced" + +group :: FilePath -> String -> PatternGroup +group prefix contents = PatternGroup prefix (parsePatterns $ T.pack contents) diff --git a/test/Data/VCS/Ignore/Git/Internal/RepositorySpec.hs b/test/Data/VCS/Ignore/Git/Internal/RepositorySpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/VCS/Ignore/Git/Internal/RepositorySpec.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Data.VCS.Ignore.Git.Internal.RepositorySpec (spec) where + +import Control.Concurrent ( + forkIO, + killThread, + newEmptyMVar, + putMVar, + readMVar, + takeMVar, + ) +import Control.Exception ( + IOException, + SomeException, + bracket_, + try, + ) +import Control.Monad (replicateM) +import Data.Either (isLeft, isRight) +import Data.IORef ( + atomicModifyIORef', + newIORef, + readIORef, + ) +import Data.VCS.Ignore.Git.Internal.Pattern ( + PatternGroup (..), + ) +import Data.VCS.Ignore.Git.Internal.Repository +import Data.VCS.Ignore.Types ( + GitError (..), + PathKind (..), + ) +import System.Directory ( + canonicalizePath, + createDirectoryIfMissing, + ) +import System.Environment ( + lookupEnv, + setEnv, + unsetEnv, + ) +import System.FilePath ( + pathSeparator, + takeDirectory, + (), + ) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec + +spec :: Spec +spec = do + describe "openGitRepository" $ do + repositoryExample "opens a repository without scanning nested rules" $ \root -> do + let nestedIgnore = root "nested" ".gitignore" + writeText nestedIgnore "old.txt\n" + repository <- openGitRepository root + writeText nestedIgnore "new.txt\n" + + isIgnored repository RegularFile "nested/new.txt" `shouldReturn` True + isIgnored repository RegularFile "nested/old.txt" `shouldReturn` False + + it "rejects a directory without Git metadata" + . withSystemTempDirectory "vcs-ignore-invalid" + $ \root -> + openGitRepository root `shouldThrow` isNotRepository + + it "resolves gitfile and commondir metadata" + . withIsolatedEnvironment + $ \sandbox -> do + let root = sandbox "repo" + gitDirectory = sandbox "admin" "worktrees" "main" + commonDirectory = sandbox "admin" "common" + createDirectoryIfMissing True root + createDirectoryIfMissing True gitDirectory + createDirectoryIfMissing True $ commonDirectory "info" + writeText (root ".git") "gitdir: ../admin/worktrees/main\n" + writeText (gitDirectory "commondir") "../../common\n" + writeText (commonDirectory "info" "exclude") "from-info.txt\n" + + repository <- openGitRepository root + canonicalGitDirectory <- canonicalizePath gitDirectory + canonicalCommon <- canonicalizePath commonDirectory + gitRepositoryGitDirectory repository `shouldBe` canonicalGitDirectory + gitRepositoryCommonDirectory repository `shouldBe` canonicalCommon + isIgnored repository RegularFile "from-info.txt" `shouldReturn` True + + it "reports malformed gitfile metadata" + . withIsolatedEnvironment + $ \sandbox -> do + let root = sandbox "repo" + createDirectoryIfMissing True root + writeText (root ".git") "not a gitdir\n" + + openGitRepository root `shouldThrow` isInvalidMetadata + + it "recognizes in-tree gitdir and commondir paths as metadata" + . withIsolatedEnvironment + $ \sandbox -> do + let root = sandbox "repo" + gitDirectory = root ".metadata" "worktree" + commonDirectory = root ".metadata" "common" + createDirectoryIfMissing True gitDirectory + createDirectoryIfMissing True commonDirectory + writeText (root ".git") "gitdir: .metadata/worktree\n" + writeText (gitDirectory "commondir") "../common\n" + + repository <- openGitRepository root + isRepositoryMetadata repository ".metadata/worktree" `shouldBe` True + isRepositoryMetadata repository ".metadata/worktree/index" `shouldBe` True + isRepositoryMetadata repository ".metadata/common" `shouldBe` True + isRepositoryMetadata repository ".metadata/working-file" `shouldBe` False + + describe "findGitRepository" $ do + repositoryExample "finds the nearest enclosing repository" $ \root -> do + let nested = root "one" "two" + createDirectoryIfMissing True nested + + (fmap repositoryRoot <$> findGitRepository nested) + `shouldReturnJustCanonicalPath` root + + it "returns Nothing when no repository encloses the path" + . withIsolatedEnvironment + $ \sandbox -> + (fmap repositoryRoot <$> findGitRepository sandbox) + `shouldReturn` Nothing + + describe "repository rule context" $ do + repositoryExample "applies global, info, root, and nested rules in order" $ \root -> do + let sandbox = takeDirectory root + writeText (sandbox "xdg" "git" "ignore") "*.cache\n" + writeText (root ".git" "info" "exclude") "*.log\n" + writeText (root ".gitignore") "!keep.log\n" + writeText (root "nested" ".gitignore") "!keep.cache\n" + repository <- openGitRepository root + + isIgnored repository RegularFile "drop.cache" `shouldReturn` True + isIgnored repository RegularFile "drop.log" `shouldReturn` True + isIgnored repository RegularFile "keep.log" `shouldReturn` False + isIgnored repository RegularFile "nested/keep.cache" `shouldReturn` False + + repositoryExample "caches each directory rule group after first use" $ \root -> do + let ignoreFile = root ".gitignore" + writeText ignoreFile "cached.txt\n" + repository <- openGitRepository root + isIgnored repository RegularFile "cached.txt" `shouldReturn` True + + writeText ignoreFile "" + isIgnored repository RegularFile "cached.txt" `shouldReturn` True + + repositoryExample "shares a cached rule load between concurrent queries" $ \root -> do + writeText (root ".gitignore") "shared.txt\n" + repository <- openGitRepository root + start <- newEmptyMVar + outputs <- replicateM 8 newEmptyMVar + + mapM_ + ( \output -> do + _ <- forkIO $ do + readMVar start + isIgnored repository RegularFile "shared.txt" >>= putMVar output + pure () + ) + outputs + putMVar start () + + results <- mapM readMVar outputs + results `shouldBe` replicate 8 True + + repositoryExample "retries a shared rule load after owner cancellation" $ \root -> do + repository <- openGitRepository root + calls <- newIORef (0 :: Int) + firstLoadStarted <- newEmptyMVar + blockFirstLoad <- newEmptyMVar + ownerResult <- newEmptyMVar + waiterResult <- newEmptyMVar + let loader _ = do + call <- atomicModifyIORef' calls $ \count -> (count + 1, count + 1) + if call == 1 + then putMVar firstLoadStarted () >> takeMVar blockFirstLoad >> pure [] + else pure [] + + owner <- forkIO $ do + result <- try @SomeException $ loadDirectoryRulesWith repository loader "." + putMVar ownerResult result + takeMVar firstLoadStarted + _ <- forkIO $ do + result <- try @SomeException $ loadDirectoryRulesWith repository loader "." + putMVar waiterResult result + killThread owner + + firstResult <- takeMVar ownerResult + secondResult <- takeMVar waiterResult + firstResult `shouldSatisfy` isLeft + secondResult `shouldSatisfy` isRight + readIORef calls `shouldReturn` 2 + + repositoryExample "caches synchronous rule-loading failures" $ \root -> do + repository <- openGitRepository root + calls <- newIORef (0 :: Int) + let loader _ = do + atomicModifyIORef' calls $ \count -> (count + 1, ()) + ioError $ userError "rule load failed" + + firstResult <- try @IOException $ loadDirectoryRulesWith repository loader "." + secondResult <- try @IOException $ loadDirectoryRulesWith repository loader "." + firstResult `shouldSatisfy` isLeft + secondResult `shouldSatisfy` isLeft + readIORef calls `shouldReturn` 1 + + repositoryExample "does not load rules below an ignored parent" $ \root -> do + writeText (root ".gitignore") "build/\n" + writeText (root "build" ".gitignore") "!keep.txt\n" + repository <- openGitRepository root + + isIgnored repository Directory "build" `shouldReturn` True + isIgnored repository RegularFile "build/keep.txt" `shouldReturn` True + + repositoryExample "does not apply a directory's rules to itself" $ \root -> do + writeText (root "nested" ".gitignore") "nested/\nself.txt\n" + repository <- openGitRepository root + + isIgnored repository Directory "nested" `shouldReturn` False + isIgnored repository RegularFile "nested/self.txt" `shouldReturn` True + + repositoryExample "returns normalized prefixes for cached groups" $ \root -> do + repository <- openGitRepository root + rootGroups <- rootRuleContext repository + nestedGroup <- loadDirectoryRules repository "nested/deeper" + + fmap patternGroupPrefix rootGroups `shouldBe` ["/", "/"] + patternGroupPrefix nestedGroup `shouldBe` "/nested/deeper/" + + describe "repository paths" $ do + it "normalizes valid relative paths" $ do + validateRepositoryPath "" `shouldBe` Right "." + validateRepositoryPath "./one//two" `shouldBe` Right "one/two" + groupPrefix "." `shouldBe` "/" + groupPrefix "one/two" `shouldBe` "/one/two/" + + it "rejects absolute and escaping paths" $ do + validateRepositoryPath "/outside" `shouldSatisfy` isLeft + validateRepositoryPath "../outside" `shouldSatisfy` isLeft + validateRepositoryPath "inside/../outside" `shouldSatisfy` isLeft + if pathSeparator == '\\' + then validateRepositoryPath "C:\\outside" `shouldSatisfy` isLeft + else validateRepositoryPath "C:\\outside" `shouldBe` Right "C:\\outside" + + repositoryExample "always ignores root Git metadata only" $ \root -> do + repository <- openGitRepository root + + isRepositoryMetadata repository ".git" `shouldBe` True + isRepositoryMetadata repository ".git/objects/value" `shouldBe` True + isRepositoryMetadata repository "nested/.git" `shouldBe` False + isIgnored repository Directory ".git" `shouldReturn` True + isIgnored repository RegularFile ".git/config" `shouldReturn` True + +repositoryExample :: String -> (FilePath -> Expectation) -> Spec +repositoryExample description action = + it description . withIsolatedEnvironment $ \sandbox -> do + let root = sandbox "repo" + createDirectoryIfMissing True $ root ".git" "info" + action root + +withIsolatedEnvironment :: (FilePath -> IO a) -> IO a +withIsolatedEnvironment action = + withSystemTempDirectory "vcs-ignore-repository" $ \sandbox -> + withEnvironment "XDG_CONFIG_HOME" (sandbox "xdg") $ + action sandbox + +withEnvironment :: String -> String -> IO a -> IO a +withEnvironment name value action = do + original <- lookupEnv name + bracket_ (setEnv name value) (restore original) action + where + restore Nothing = unsetEnv name + restore (Just original) = setEnv name original + +writeText :: FilePath -> String -> IO () +writeText path content = do + createDirectoryIfMissing True $ takeDirectory path + writeFile path content + +isNotRepository :: GitError -> Bool +isNotRepository (NotGitRepository _) = True +isNotRepository _ = False + +isInvalidMetadata :: GitError -> Bool +isInvalidMetadata (InvalidGitMetadata _ _) = True +isInvalidMetadata _ = False + +shouldReturnJustCanonicalPath :: IO (Maybe FilePath) -> FilePath -> Expectation +shouldReturnJustCanonicalPath action expectedPath = do + expected <- canonicalizePath expectedPath + action `shouldReturn` Just expected diff --git a/test/Data/VCS/Ignore/Git/Internal/TraversalSpec.hs b/test/Data/VCS/Ignore/Git/Internal/TraversalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/VCS/Ignore/Git/Internal/TraversalSpec.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Data.VCS.Ignore.Git.Internal.TraversalSpec (spec) where + +import Control.Exception ( + IOException, + bracket_, + try, + ) +import Control.Monad (when) +import Data.IORef ( + modifyIORef', + newIORef, + readIORef, + ) +import qualified Data.List as L +import Data.VCS.Ignore.Git.Internal.Repository ( + GitRepository, + openGitRepository, + ) +import Data.VCS.Ignore.Git.Internal.Traversal +import Data.VCS.Ignore.Types +import System.Directory ( + createDirectoryIfMissing, + createDirectoryLink, + removeDirectoryLink, + removeDirectoryRecursive, + renameDirectory, + ) +import System.Environment ( + lookupEnv, + setEnv, + unsetEnv, + ) +import System.FilePath ( + takeDirectory, + (), + ) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec + +spec :: Spec +spec = do + describe "foldRepo" $ do + it "visits entries in depth-first preorder without emitting the root" + . withRepository + $ \root repository -> do + writeText (root "directory" "child.txt") "child" + writeText (root "file.txt") "file" + + result <- foldRepo repository [] collectEntry + + entries <- completedValue result + let paths = entryPath <$> reverse entries + paths `shouldNotContain` [""] + paths `shouldMatchList` ["directory", "directory" "child.txt", "file.txt"] + reverse entries + `shouldMatchList` [ Entry "directory" Directory + , Entry ("directory" "child.txt") RegularFile + , Entry "file.txt" RegularFile + ] + L.elemIndex ("directory" "child.txt") paths + `shouldBe` ((+ 1) <$> L.elemIndex "directory" paths) + + it "automatically prunes ignored directories and repository metadata" + . withRepository + $ \root repository -> do + writeText (root ".gitignore") "ignored/\n" + writeText (root "ignored" "hidden.txt") "hidden" + writeText (root "visible.txt") "visible" + + entries <- listRepo repository + + entryPath <$> entries `shouldMatchList` [".gitignore", "visible.txt"] + + it "loads a visible directory's rules before visiting its children" + . withRepository + $ \root repository -> do + writeText (root "nested" ".gitignore") "*.tmp\n" + writeText (root "nested" "drop.tmp") "ignored" + writeText (root "nested" "keep.txt") "visible" + + entries <- listRepo repository + + entryPath <$> entries + `shouldMatchList` [ "nested" + , "nested" ".gitignore" + , "nested" "keep.txt" + ] + + it "honours caller pruning without visiting descendants" + . withRepository + $ \root repository -> do + writeText (root "pruned" "child.txt") "child" + writeText (root "visible" "child.txt") "child" + + result <- foldRepo repository [] $ \entries entry -> + pure + ( entry : entries + , if entryPath entry == "pruned" then Prune else Continue + ) + + entries <- reverse <$> completedValue result + entryPath <$> entries + `shouldMatchList` ["pruned", "visible", "visible" "child.txt"] + + it "treats Prune on a file as Continue" + . withRepository + $ \root repository -> do + writeText (root "first.txt") "first" + writeText (root "second.txt") "second" + + result <- foldRepo repository [] $ \entries entry -> + pure (entryPath entry : entries, Prune) + + paths <- reverse <$> completedValue result + paths `shouldMatchList` ["first.txt", "second.txt"] + + it "does not follow a directory replaced by a symlink in the callback" + . withRepository + $ \root repository -> + withSystemTempDirectory "vcs-ignore-replacement" $ \outside -> do + let directory = root "directory" + moved = root "moved" + writeText (directory "inside.txt") "inside" + writeText (outside "outside.txt") "outside" + + result <- try @IOException $ createDirectoryLink outside (root "probe") + case result of + Left _ -> pendingWith "directory symbolic links are unavailable" + Right _ -> do + removeDirectoryLink $ root "probe" + entries <- listWithReplacement repository directory moved outside + entryPath <$> entries `shouldBe` ["directory"] + + it "skips a directory removed by the callback" + . withRepository + $ \root repository -> do + let directory = root "directory" + writeText (directory "inside.txt") "inside" + + result <- foldRepo repository [] $ \entries entry -> do + when (entryPath entry == "directory") $ + removeDirectoryRecursive directory + pure (entry : entries, Continue) + + reverse <$> completedValue result + `shouldReturn` [Entry "directory" Directory] + + it "propagates Stop through all remaining traversal levels" + . withRepository + $ \root repository -> do + writeText (root "one" "child.txt") "child" + writeText (root "two" "child.txt") "child" + + result <- foldRepo repository (0 :: Int) $ \count _ -> + pure (count + 1, Stop) + + result `shouldBe` WalkStopped 1 + + it "forces the initial accumulator even for an empty repository" + . withRepository + $ \_ repository -> + foldRepo repository (error "strict accumulator" :: Int) keepWalking + `shouldThrow` errorCall "strict accumulator" + + it "propagates callback failures" + . withRepository + $ \root repository -> do + writeText (root "entry.txt") "entry" + + walkRepo repository (const . ioError $ userError "callback failure") + `shouldThrow` anyIOException + + describe "repository traversal wrappers" $ do + it "does not follow directory symbolic links" + . withRepository + $ \root repository -> + withSystemTempDirectory "vcs-ignore-target" $ \target -> do + writeText (target "outside.txt") "outside" + linkResult <- try @IOException $ createDirectoryLink target (root "link") + case linkResult of + Left _ -> pendingWith "directory symbolic links are unavailable" + Right _ -> do + entries <- listRepo repository + entries `shouldBe` [Entry "link" SymbolicLink] + + it "walkRepo reports normal completion" + . withRepository + $ \root repository -> do + writeText (root "entry.txt") "entry" + result <- walkRepo repository (const $ pure Continue) + result `shouldBe` WalkCompleted () + + it "forRepo_ performs an effect for every visible entry" + . withRepository + $ \root repository -> do + writeText (root "first.txt") "first" + writeText (root "second.txt") "second" + visited <- newIORef [] + + forRepo_ repository $ \entry -> + modifyIORef' visited (entryPath entry :) + + paths <- readIORef visited + paths `shouldMatchList` ["first.txt", "second.txt"] + +collectEntry :: [Entry] -> Entry -> IO ([Entry], WalkAction) +collectEntry entries entry = pure (entry : entries, Continue) + +keepWalking :: Int -> Entry -> IO (Int, WalkAction) +keepWalking state _ = pure (state, Continue) + +completedValue :: WalkResult a -> IO a +completedValue (WalkCompleted value) = pure value +completedValue (WalkStopped _) = do + expectationFailure "expected completed traversal" + error "unreachable" + +listWithReplacement :: GitRepository -> FilePath -> FilePath -> FilePath -> IO [Entry] +listWithReplacement repository directory moved outside = do + result <- foldRepo repository [] $ \entries entry -> do + when (entryPath entry == "directory") $ do + renameDirectory directory moved + createDirectoryLink outside directory + pure (entry : entries, Continue) + reverse <$> completedValue result + +withRepository :: (FilePath -> GitRepository -> IO a) -> IO a +withRepository action = + withSystemTempDirectory "vcs-ignore-traversal" $ \sandbox -> + withEnvironment "XDG_CONFIG_HOME" (sandbox "xdg") $ do + let root = sandbox "repository" + createDirectoryIfMissing True $ root ".git" "info" + repository <- openGitRepository root + action root repository + +withEnvironment :: String -> String -> IO a -> IO a +withEnvironment name value action = do + original <- lookupEnv name + bracket_ (setEnv name value) (restore original) action + where + restore Nothing = unsetEnv name + restore (Just originalValue) = setEnv name originalValue + +writeText :: FilePath -> String -> IO () +writeText path content = do + createDirectoryIfMissing True $ takeDirectory path + writeFile path content diff --git a/test/Data/VCS/Ignore/Repo/GitSpec.hs b/test/Data/VCS/Ignore/Repo/GitSpec.hs deleted file mode 100644 --- a/test/Data/VCS/Ignore/Repo/GitSpec.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Data.VCS.Ignore.Repo.GitSpec where - -import qualified Data.List as L -import qualified Data.Text as T -import Data.VCS.Ignore.Repo ( RepoError(..) ) -import Data.VCS.Ignore.Repo.Git -import System.Directory ( makeAbsolute ) -import System.FilePath ( () ) -import Test.Hspec - - -spec :: Spec -spec = do - let repo = "test-data" "fake-git-repo" - - describe "compilePattern" $ do - it "compiles negated pattern" $ do - compilePattern "!/foo/bar" - `shouldBe` Pattern ["/foo/bar", "/foo/bar/**"] "!/foo/bar" True - - it "compiles pattern matching files or directories inside path" $ do - compilePattern ".hidden" - `shouldBe` Pattern ["**/.hidden", "**/.hidden/**"] ".hidden" False - compilePattern ".hidden/" - `shouldBe` Pattern ["**/.hidden/**"] ".hidden/" False - - - describe "matchesPattern" $ do - it "matches all content in subdirectory" $ do - matchesPattern (compilePattern "/foo/*") "/foo" `shouldBe` False - matchesPattern (compilePattern "/foo/*") "/foo/bar" `shouldBe` True - - it "matches all content in all subdirectories" $ do - matchesPattern (compilePattern "/foo/**") "/foo/bar" `shouldBe` True - matchesPattern (compilePattern "/foo/**") "/foo/bar/c" `shouldBe` True - - it "matches negated pattern" $ do - matchesPattern (compilePattern "!/foo/*") "/foo" `shouldBe` False - matchesPattern (compilePattern "!/foo/*") "/foo/bar" `shouldBe` True - - it "matches dir pattern anywhere in the path" $ do - matchesPattern (compilePattern "bar/") "/foo/bar/x" `shouldBe` True - matchesPattern (compilePattern "bar/") "/foo/bar" `shouldBe` False - - it "matches dir or file pattern anywhere in the path" $ do - matchesPattern (compilePattern "bar") "/foo/bar/x" `shouldBe` True - matchesPattern (compilePattern "bar") "/foo/bar" `shouldBe` True - - - describe "parsePatterns" $ do - it "parses glob patterns from input text (pattern per line)" $ do - let input = T.unlines [".cabal-sandbox/", "## comment", ".DS_Store"] - expected = [".cabal-sandbox/", ".DS_Store"] - parsePatterns input `shouldBe` expected - - - describe "loadPatterns" $ do - it "loads and parses glob patterns from input file" $ do - let source = repo "a" ".gitignore" - expected = ["**/*.xml"] - loadPatterns source `shouldReturn` expected - - it "returns empty list if input cannot be read" $ do - let source = repo "non-existing" - loadPatterns source `shouldReturn` [] - - - describe "findGitIgnores" $ do - it "finds all .gitignore files in repo" $ do - let expected = - [ repo "a" ".gitignore" - , repo "a" "b" ".gitignore" - , repo ".gitignore" - ] - L.sort <$> findGitIgnores repo `shouldReturn` L.sort expected - - - describe "gitIgnorePatterns" $ do - it "loads patterns for all .gitignore files in repo" $ do - let expected = - [("/a/", ["**/*.xml"]), ("/a/b/", ["*.txt"]), ("/", ["foo"])] - sortFst <$> gitIgnorePatterns repo `shouldReturn` sortFst expected - - - describe "scanRepo'" $ do - it "scans repository for ignored patterns" $ do - absRepo <- makeAbsolute repo - let - fn1 = pure [] - fn2 = const $ pure [] - fn3 = const $ pure True - expected = Git - { gitPatterns = sortFst - [("/", ["foo"]), ("/a/", ["**/*.xml"]), ("/a/b/", ["*.txt"])] - , gitRepoRoot = absRepo - } - result <- scanRepo' fn1 fn2 gitIgnorePatterns fn3 repo - let result' = result { gitPatterns = sortFst (gitPatterns result) } - result' `shouldBe` expected - - it "aborts scanning if given path is not valid GIT repo" $ do - let fn1 = pure [] - fn2 = const $ pure [] - fn3 = const $ pure False - let err (InvalidRepo _ _) = True - scanRepo' fn1 fn2 gitIgnorePatterns fn3 repo `shouldThrow` err - - - describe "isIgnored'" $ do - it "checks whether given path is excluded" $ do - absRepo <- makeAbsolute repo - let git = Git - { gitPatterns = [ ("/" , ["!keep.xml", ".hidden/", ".hid"]) - , ("/a/" , ["**/*.xml"]) - , ("/a/b/", ["*.txt"]) - ] - , gitRepoRoot = absRepo - } - isIgnored' git "foo/bar" `shouldReturn` False - isIgnored' git "a/hello.txt" `shouldReturn` False - isIgnored' git "a/hello.xml" `shouldReturn` True - isIgnored' git "a/b/hello.xml" `shouldReturn` True - isIgnored' git "a/b/keep.xml" `shouldReturn` False - isIgnored' git "/foo/bar" `shouldReturn` False - isIgnored' git "/a/hello.txt" `shouldReturn` False - isIgnored' git "/a/hello.xml" `shouldReturn` True - isIgnored' git "/a/b/hello.xml" `shouldReturn` True - isIgnored' git "/a/b/../hello.txt" `shouldReturn` False - isIgnored' git "/a/b/../hello.xml" `shouldReturn` True - isIgnored' git "/a/b/.hidden" `shouldReturn` False - isIgnored' git "/a/b/.hidden/foo" `shouldReturn` True - isIgnored' git "/a/b/.hid" `shouldReturn` True - isIgnored' git "/a/b/.hid/foo" `shouldReturn` True - - -sortFst :: Ord a => [(a, b)] -> [(a, b)] -sortFst = L.sortOn fst diff --git a/vcs-ignore.cabal b/vcs-ignore.cabal --- a/vcs-ignore.cabal +++ b/vcs-ignore.cabal @@ -1,25 +1,24 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.39.6. -- -- see: https://github.com/sol/hpack name: vcs-ignore -version: 0.0.2.0 -synopsis: Library for handling files ignored by VCS systems. -description: vcs-ignore is small Haskell library used to find, check and process files ignored by selected VCS. +version: 0.1.0.0 +synopsis: Query Git ignore rules and traverse visible repository entries. +description: vcs-ignore provides lazy Git ignore queries and a pruning, early-stopping repository traversal built on one shared rule engine. category: Development -homepage: https://github.com/vaclavsvejcar/vcs-ignore -bug-reports: https://github.com/vaclavsvejcar/vcs-ignore/issues +homepage: https://github.com/xwinus/vcs-ignore +bug-reports: https://github.com/xwinus/vcs-ignore/issues author: Vaclav Svejcar maintainer: vaclav.svejcar@gmail.com -copyright: Copyright (c) 2020-2022 Vaclav Svejcar +copyright: Copyright (c) 2020-2026 Vaclav Svejcar license: BSD-3-Clause license-file: LICENSE build-type: Simple extra-source-files: README.md - CHANGELOG.md test-data/fake-git-repo/.gitignore test-data/fake-git-repo/a/test-a.txt test-data/fake-git-repo/a/test-a.xml @@ -31,20 +30,23 @@ test-data/list-files/dir1/b.txt test-data/list-files/dir1/dir2/c.txt test-data/list-files/dir1/dir2/d.xml +extra-doc-files: + CHANGELOG.md + RELEASING.md source-repository head type: git - location: https://github.com/vaclavsvejcar/vcs-ignore + location: https://github.com/xwinus/vcs-ignore library exposed-modules: Data.VCS.Ignore - Data.VCS.Ignore.Core - Data.VCS.Ignore.FileSystem - Data.VCS.Ignore.Repo - Data.VCS.Ignore.Repo.Git + Data.VCS.Ignore.Git Data.VCS.Ignore.Types other-modules: + Data.VCS.Ignore.Git.Internal.Pattern + Data.VCS.Ignore.Git.Internal.Repository + Data.VCS.Ignore.Git.Internal.Traversal Paths_vcs_ignore autogen-modules: Paths_vcs_ignore @@ -52,13 +54,12 @@ src ghc-options: -optP-Wno-nonportable-include-path -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Werror=incomplete-patterns build-depends: - Glob - , base >=4.7 && <5 - , containers - , directory - , exceptions - , filepath - , text + Glob >=0.10.2 && <0.11 + , base >=4.20 && <4.23 + , containers >=0.6 && <0.9 + , directory >=1.3.8 && <1.4 + , filepath >=1.4.2 && <1.6 + , text >=2.0 && <2.2 default-language: Haskell2010 executable ignore @@ -67,58 +68,73 @@ Main.Options Main.Vendor Paths_vcs_ignore + autogen-modules: + Paths_vcs_ignore hs-source-dirs: app ghc-options: -optP-Wno-nonportable-include-path -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Werror=incomplete-patterns -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 && <5 - , containers - , directory - , exceptions - , filepath - , optparse-applicative - , text + base >=4.20 && <4.23 + , containers >=0.6 && <0.9 + , directory >=1.3.8 && <1.4 + , filepath >=1.4.2 && <1.6 + , optparse-applicative ==0.18.* + , text >=2.0 && <2.2 , vcs-ignore default-language: Haskell2010 -test-suite doctest - type: exitcode-stdio-1.0 - main-is: Main.hs - other-modules: - Paths_vcs_ignore - hs-source-dirs: - doctest - ghc-options: -optP-Wno-nonportable-include-path -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Werror=incomplete-patterns - build-depends: - base >=4.7 && <5 - , containers - , directory - , doctest - , exceptions - , filepath - , text - default-language: Haskell2010 - test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - Data.VCS.Ignore.CoreSpec - Data.VCS.Ignore.FileSystemSpec - Data.VCS.Ignore.Repo.GitSpec + Data.VCS.Ignore + Data.VCS.Ignore.Git + Data.VCS.Ignore.Git.Internal.Pattern + Data.VCS.Ignore.Git.Internal.Repository + Data.VCS.Ignore.Git.Internal.Traversal + Data.VCS.Ignore.Types + Data.VCS.Ignore.Git.CompatibilitySpec + Data.VCS.Ignore.Git.Internal.PatternSpec + Data.VCS.Ignore.Git.Internal.RepositorySpec + Data.VCS.Ignore.Git.Internal.TraversalSpec Paths_vcs_ignore + autogen-modules: + Paths_vcs_ignore hs-source-dirs: + src test ghc-options: -optP-Wno-nonportable-include-path -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Werror=incomplete-patterns -threaded -rtsopts -with-rtsopts=-N build-tool-depends: hspec-discover:hspec-discover build-depends: - base >=4.7 && <5 - , containers - , directory - , exceptions - , filepath + Glob >=0.10.2 && <0.11 + , base >=4.20 && <4.23 + , containers >=0.6 && <0.9 + , directory >=1.3.8 && <1.4 + , filepath >=1.4.2 && <1.6 , hspec - , text + , process + , temporary + , text >=2.0 && <2.2 + default-language: Haskell2010 + +benchmark repository-traversal + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_vcs_ignore + autogen-modules: + Paths_vcs_ignore + hs-source-dirs: + benchmark + ghc-options: -optP-Wno-nonportable-include-path -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Werror=incomplete-patterns + build-depends: + base >=4.20 && <4.23 + , containers >=0.6 && <0.9 + , criterion + , directory >=1.3.8 && <1.4 + , filepath >=1.4.2 && <1.6 + , temporary + , text >=2.0 && <2.2 , vcs-ignore default-language: Haskell2010