diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -36,6 +36,9 @@ # Exclude paths matching a regex sizes -x '\.cache' /path/to/dir +# Exclude paths matching any of several regexes (repeat -x) +sizes -x '\.cache' -x '\.git' /path/to/dir + # Stay on one filesystem (skip mounted volumes, NFS/SMB shares, etc.) sizes -X /path/to/dir @@ -70,7 +73,7 @@ | `-A` | Git-annex aware | | `--apparent` | Apparent sizes, not disk blocks | | `-H` | Base-10 (MB/GB) | -| `-x REGEX` | Exclude matching paths | +| `-x REGEX` | Exclude matching paths; repeatable | | `-m INT` | Minimum size in MB (default: 10) | | `-M INT` | Minimum file count (default: 100) | | `-B INT` | Block size in bytes (default: 512) | diff --git a/Sizes.hs b/Sizes.hs --- a/Sizes.hs +++ b/Sizes.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -10,6 +11,7 @@ -- * Types SizesOpts (..), EntryInfo (..), + ReportEntries, SeenInodes, -- * Lenses @@ -22,11 +24,12 @@ humanReadable, reportEntryP, newEntry, + emptyReportEntries, + reportEntriesToList, + combineEntryResults, crossesFileSystemBoundary, ) where --- jww (2013-08-23): Still need to deal with hard-links. - import Control.Concurrent.ParallelIO import Control.DeepSeq import Control.Exception hiding (catch) @@ -34,10 +37,11 @@ import Control.Monad import Control.Monad.Catch (catch) import Control.Monad.State.Strict -import Data.DList (DList) -import qualified Data.DList as DL +import qualified Data.Foldable as Foldable import Data.Function import qualified Data.List as L +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq import qualified Data.Set as Set import Data.Text as T hiding (chunksOf, filter, map) import Filesystem (isFile, listDirectory) @@ -46,6 +50,8 @@ import Stat import System.Console.CmdArgs import System.Environment (getArgs, withArgs) +import System.Exit (ExitCode (ExitFailure), exitWith) +import System.IO (hPutStrLn, stderr) import System.Posix.Files hiding (fileBlockSize) import System.Posix.Types (DeviceID, FileID) import Text.Printf @@ -56,7 +62,7 @@ default (Integer, Text) version :: String -version = "2.4.3" +version = "2.4.4" copyright :: String copyright = "2012-2026" @@ -70,7 +76,7 @@ , annex :: Bool , apparent :: Bool , baseTen :: Bool - , exclude :: String + , exclude :: [String] , minSize :: Int , minCount :: Int , blockSize :: Int @@ -114,7 +120,7 @@ def &= name "x" &= typ "REGEX" - &= help "Exclude files whose path matches the REGEX" + &= help "Exclude files whose path matches any of the REGEXes (repeatable)" , minSize = def &= name "m" @@ -161,8 +167,8 @@ data EntryInfo = EntryInfo { _entryPath :: FilePath - , _entryCount :: Int - , _entryAllocSize :: Int + , _entryCount :: !Int + , _entryAllocSize :: !Int , _entryIsDir :: Bool } deriving (Show, Eq) @@ -172,23 +178,48 @@ -- Track (DeviceID, FileID) pairs to detect hard links type SeenInodes = Set.Set (DeviceID, FileID) +-- | Stack-safe collection of entries retained for the final report. +newtype ReportEntries = ReportEntries (Seq EntryInfo) + +-- | An empty report-entry collection. +emptyReportEntries :: ReportEntries +emptyReportEntries = ReportEntries Seq.empty + +-- | Materialize report entries in traversal order. +reportEntriesToList :: ReportEntries -> [EntryInfo] +reportEntriesToList (ReportEntries entries) = Foldable.toList entries + newEntry :: FilePath -> Bool -> EntryInfo newEntry p = EntryInfo p 0 0 instance Semigroup EntryInfo where x <> y = - seq x $ - seq y $ - entryCount +~ y ^. entryCount $ - entryAllocSize +~ y ^. entryAllocSize $ - x + let !count' = x ^. entryCount + y ^. entryCount + !allocSize' = x ^. entryAllocSize + y ^. entryAllocSize + in x + & entryCount .~ count' + & entryAllocSize .~ allocSize' instance Monoid EntryInfo where mempty = newEntry "" False instance NFData EntryInfo where - rnf a = a `seq` () + rnf entry = + rnf (toTextIgnore (entry ^. entryPath)) `seq` + rnf (entry ^. entryCount) `seq` + rnf (entry ^. entryAllocSize) `seq` + rnf (entry ^. entryIsDir) +-- | Add one child aggregate and its retained descendants to a directory. +combineEntryResults :: Bool -> (EntryInfo, ReportEntries) -> (EntryInfo, ReportEntries) -> (EntryInfo, ReportEntries) +combineEntryResults keepReports (total, ReportEntries reports) (child, ReportEntries childReports) = + let total' = total <> child + reports' = + if keepReports + then ReportEntries ((reports Seq.|> child) Seq.>< childReports) + else emptyReportEntries + in total' `seq` reports' `seq` (total', reports') + sizesMain :: IO () sizesMain = do mainArgs <- getArgs @@ -219,10 +250,11 @@ reportSizes :: SizesOpts -> [FilePath] -> IO () reportSizes opts xs = do - entryInfos <- parallel $ Prelude.map reportSizesForDir xs + excludes <- compileExcludes (exclude opts) + entryInfos <- parallel $ Prelude.map (reportSizesForDir excludes) xs let infos = Prelude.map fst entryInfos - ++ DL.toList (DL.concat (Prelude.map snd entryInfos)) + ++ Prelude.concatMap (reportEntriesToList . snd) entryInfos sorted = L.sortBy ( (compare `on`) $ @@ -235,15 +267,29 @@ (reportEntry (baseTen opts)) (Prelude.filter (reportEntryP opts) sorted) where - reportSizesForDir dir = + reportSizesForDir excludes dir = -- fsStatus <- getFilesystemStatus (E.encodeUtf8 (toTextIgnore dir)) let fsBlkSize = statBlockSize -- filesystemBlockSize fsStatus opts' = if blockSize opts == 0 then opts{blockSize = fromIntegral fsBlkSize} else opts - in fst <$> runStateT (gatherSizes opts' Nothing 0 dir) Set.empty + in fst <$> runStateT (gatherSizes opts' excludes Nothing 0 dir) Set.empty +{- | Compile the exclusion patterns once, up front. An invalid pattern is a +fatal startup error rather than a silent per-path failure. +-} +compileExcludes :: [String] -> IO [Regex] +compileExcludes = mapM compileOne + where + compileOne regex = do + compiled <- try (makeRegexM regex) + case compiled of + Left ex -> do + hPutStrLn stderr $ "invalid exclusion regex " ++ Prelude.show regex ++ ": " ++ Prelude.show (ex :: SomeException) + exitWith (ExitFailure 1) + Right r -> pure r + humanReadable :: Int -> Int -> String humanReadable x d | x < d = printf "%db" x @@ -272,8 +318,8 @@ toTextIgnore :: FilePath -> Text toTextIgnore = either id id . toText -returnEmpty :: FilePath -> StateT SeenInodes IO (EntryInfo, DList EntryInfo) -returnEmpty path = return (newEntry path False, DL.empty) +returnEmpty :: FilePath -> StateT SeenInodes IO (EntryInfo, ReportEntries) +returnEmpty path = return (newEntry path False, emptyReportEntries) {- | Decide whether an entry should be skipped because it lies on a different filesystem than the traversal root. The second argument is the device of @@ -285,16 +331,15 @@ crossesFileSystemBoundary True Nothing _ = False crossesFileSystemBoundary True (Just rootDev) dev = dev /= rootDev -gatherSizes :: SizesOpts -> Maybe DeviceID -> Int -> FilePath -> StateT SeenInodes IO (EntryInfo, DList EntryInfo) -gatherSizes opts mRootDev curDepth path = do - excl <- - if L.null (exclude opts) - then return $ Right False - else liftIO $ try $ return $ path' =~ exclude opts -- jww (2013-08-15): poor - case excl of - Left (_ :: SomeException) -> returnEmpty path - Right True -> returnEmpty path - _ -> +-- | Decide whether a path matches any of the compiled exclusion patterns. +excludePath :: [Regex] -> String -> Bool +excludePath patterns path = L.any (`match` path) patterns + +gatherSizes :: SizesOpts -> [Regex] -> Maybe DeviceID -> Int -> FilePath -> StateT SeenInodes IO (EntryInfo, ReportEntries) +gatherSizes opts excludes mRootDev curDepth path = + if excludePath excludes path' + then returnEmpty path + else ( do status <- liftIO @@ -318,15 +363,10 @@ | isDirectory status = foldM ( \(y, ys) x -> do - (x', xs') <- gatherSizes opts (Just (deviceID status)) (curDepth + 1) (collapse x) - let x'' = y <> x' - xs'' = - if curDepth < depth opts - then ys <> DL.singleton x' <> xs' - else DL.empty - return $! x'' `seq` xs'' `seq` (x'', xs'') + child <- gatherSizes opts excludes (Just (deviceID status)) (curDepth + 1) (collapse x) + return $! combineEntryResults (curDepth < depth opts) (y, ys) child ) - (newEntry path True, DL.empty) + (newEntry path True, emptyReportEntries) =<< liftIO (listDirectory path) | ( isRegularFile status && not (annex opts && ".git/annex/" `isInfixOf` pathT) @@ -386,7 +426,7 @@ , _entryAllocSize = allocSize , _entryIsDir = False } - , DL.empty + , emptyReportEntries ) | otherwise = returnEmpty path diff --git a/sizes.cabal b/sizes.cabal --- a/sizes.cabal +++ b/sizes.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: sizes -version: 2.4.3 +version: 2.4.4 synopsis: Recursively show space (size and i-nodes) used in subdirectories description: A command-line utility that recursively analyzes directory trees to display @@ -37,7 +37,6 @@ , cmdargs >= 0.10 && < 0.11 , containers >= 0.5 && < 0.8 , deepseq >= 1.3 && < 1.6 - , dlist >= 0.5 && < 1.1 , exceptions >= 0.8 && < 0.11 , lens >= 2.8 && < 6 , mtl >= 2.2 && < 2.4 @@ -53,7 +52,7 @@ main-is: Main.hs hs-source-dirs: app default-language: Haskell2010 - ghc-options: -Wall -Wcompat -threaded -with-rtsopts=-K64M + ghc-options: -Wall -Wcompat -threaded build-depends: , base >= 4 && < 5 @@ -64,12 +63,19 @@ main-is: Spec.hs hs-source-dirs: test default-language: Haskell2010 - ghc-options: -Wall -Wcompat + -- Fault-inject a small stack so the wide-aggregation regression stays meaningful. + ghc-options: -Wall -Wcompat -with-rtsopts=-K1M build-depends: - , base >= 4 && < 5 - , hedgehog >= 1.0 && < 1.6 + , base >= 4 && < 5 + , directory >= 1.3 && < 1.4 + , filepath >= 1.4 && < 1.6 + , hedgehog >= 1.0 && < 1.6 + , process >= 1.6 && < 1.7 , sizes + + build-tool-depends: + sizes:sizes source-repository head type: git diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,19 +2,44 @@ module Main where +import Control.Exception (bracket) import Control.Monad (unless) +import qualified Data.List as List import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -import Sizes (EntryInfo (..), crossesFileSystemBoundary, humanReadable) -import System.Exit (exitFailure) +import Sizes ( + EntryInfo (..), + combineEntryResults, + crossesFileSystemBoundary, + emptyReportEntries, + humanReadable, + reportEntriesToList, + ) +import System.Directory (createDirectory, getTemporaryDirectory, removeFile, removePathForcibly) +import System.Exit (ExitCode (ExitSuccess), exitFailure) +import System.FilePath (()) +import System.IO (hClose, openTempFile) import System.Posix.Types (DeviceID) +import System.Process (readProcessWithExitCode) main :: IO () main = do passed <- checkParallel $$(discover) unless passed exitFailure +-- | Allocate a unique scratch directory and remove it after the test. +withScratchDirectory :: (FilePath -> IO a) -> IO a +withScratchDirectory = bracket create removePathForcibly + where + create = do + temporaryRoot <- getTemporaryDirectory + (path, handle) <- openTempFile temporaryRoot "sizes-test" + hClose handle + removeFile path + createDirectory path + pure path + -- | Generate an EntryInfo with random count and size. genEntryInfo :: Gen EntryInfo genEntryInfo = do @@ -80,6 +105,137 @@ prop_monoid_right_identity_size = property $ do e <- forAll genEntryInfo _entryAllocSize (e <> mempty) === _entryAllocSize e + +-- Wide directory aggregation must not require stack proportional to entry count. +prop_wide_directory_aggregation_stack_safe :: Property +prop_wide_directory_aggregation_stack_safe = + withTests 1 . property $ do + let entryCount = 200000 + leaf = mempty{_entryCount = 1, _entryAllocSize = 2} + step aggregate _ = + combineEntryResults + True + aggregate + (leaf, emptyReportEntries) + (total, reports) = + List.foldl' + step + (mempty, emptyReportEntries) + [1 .. entryCount] + _entryCount total === entryCount + _entryAllocSize total === 2 * entryCount + length (reportEntriesToList reports) === entryCount + +-- Report accumulation preserves sibling/preorder content and drops it past depth. +prop_report_entries_preserve_preorder :: Property +prop_report_entries_preserve_preorder = + withTests 1 . property $ do + let first = mempty{_entryCount = 1, _entryAllocSize = 10} + child = mempty{_entryCount = 2, _entryAllocSize = 20} + grandchild = mempty{_entryCount = 3, _entryAllocSize = 30} + firstResult = + combineEntryResults + True + (mempty, emptyReportEntries) + (first, emptyReportEntries) + (_, grandchildReports) = + combineEntryResults + True + (mempty, emptyReportEntries) + (grandchild, emptyReportEntries) + (_, retained) = + combineEntryResults + True + firstResult + (child, grandchildReports) + (_, dropped) = + combineEntryResults + False + firstResult + (child, grandchildReports) + entryIdentity entry = (_entryCount entry, _entryAllocSize entry) + fmap entryIdentity (reportEntriesToList retained) + === [(1, 10), (2, 20), (3, 30)] + reportEntriesToList dropped === [] + +-- The packaged executable traverses a real nested tree in report preorder. +prop_cli_traverses_nested_directory :: Property +prop_cli_traverses_nested_directory = + withTests 1 . property $ do + (root, child, file, exitCode, stdout, stderr) <- evalIO $ + withScratchDirectory $ \root -> do + let child = root "child" + file = child "file" + createDirectory child + writeFile file "abc" + (exitCode, stdout, stderr) <- + readProcessWithExitCode + "sizes" + ["-j1", "-a", "-s", "-d3", root] + "" + pure (root, child, file, exitCode, stdout, stderr) + annotate stderr + exitCode === ExitSuccess + fmap (last . words) (lines stdout) + === [root ++ "/", child ++ "/", file] + +-- A single -x pattern excludes matching paths but keeps the rest. +prop_cli_single_exclude_filters :: Property +prop_cli_single_exclude_filters = + withTests 1 . property $ do + (exitCode, stdout, stderr) <- evalIO $ + withScratchDirectory $ \root -> do + let keepDir = root "keep" + dropDir = root "drop-me" + mapM_ + (\dir -> createDirectory dir >> writeFile (dir "marker") "x") + [keepDir, dropDir] + readProcessWithExitCode + "sizes" + ["-j1", "-a", "-s", "-d3", "-x", "drop-me", root] + "" + annotate stderr + exitCode === ExitSuccess + let reported = map (last . words) (lines stdout) + annotate (unlines reported) + assert $ any (List.isSuffixOf "keep/marker") reported + assert $ not $ any (List.isSuffixOf "drop-me/marker") reported + +-- Repeated -x flags accumulate: every provided pattern excludes its matches, +-- not just the last one. +prop_cli_multiple_excludes_accumulate :: Property +prop_cli_multiple_excludes_accumulate = + withTests 1 . property $ do + (exitCode, stdout, stderr) <- evalIO $ + withScratchDirectory $ \root -> do + let keepDir = root "keep" + firstDir = root "drop-first" + secondDir = root "drop-second" + mapM_ + (\dir -> createDirectory dir >> writeFile (dir "marker") "x") + [keepDir, firstDir, secondDir] + readProcessWithExitCode + "sizes" + [ "-j1" + , "-a" + , "-s" + , "-d3" + , "-x" + , "drop-first" + , "-x" + , "drop-second" + , root + ] + "" + annotate stderr + exitCode === ExitSuccess + let reported = map (last . words) (lines stdout) + annotate (unlines reported) + -- The first -x pattern must still exclude: both flags accumulate + -- rather than the last one winning. + assert $ any (List.isSuffixOf "keep/marker") reported + assert $ not $ any (List.isSuffixOf "drop-first/marker") reported + assert $ not $ any (List.isSuffixOf "drop-second/marker") reported -- humanReadable always returns a non-empty string prop_humanReadable_nonempty :: Property