sizes 2.4.3 → 2.4.4

raw patch · 4 files changed

+254/−49 lines, 4 filesdep +directorydep +filepathdep +processdep −dlistPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: directory, filepath, process

Dependencies removed: dlist

API changes (from Hackage documentation)

Files

• README.md +4/−1
• Sizes.hs +80/−40
• sizes.cabal +12/−6
• test/Spec.hs +158/−2

@@ -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) |

@@ -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 

@@ -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

@@ -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