diff --git a/LICENSE b/LICENSE deleted file mode 100644 --- a/LICENSE +++ /dev/null @@ -1,28 +0,0 @@ -Copyright (c) 2003-2009, John Wiegley. All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -- Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -- Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -- Neither the name of New Artisans LLC nor the names of its - contributors may be used to endorse or promote products derived from - this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,28 @@ +Copyright (c) 2012-2025, John Wiegley. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +- Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +- Neither the name of New Artisans LLC nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Main.hs b/Main.hs deleted file mode 100644 --- a/Main.hs +++ /dev/null @@ -1,283 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - -module Main where - --- jww (2013-08-23): Still need to deal with hard-links. - -import Control.Applicative -import Control.Concurrent.ParallelIO -import Control.DeepSeq -import Control.Exception hiding (catch) -import Control.Monad.Catch (MonadCatch, catch) -import Control.Lens -import Control.Monad -import Control.Monad.State.Strict -import Data.DList (DList) -import qualified Data.DList as DL -import Data.Function -import qualified Data.List as L -import Data.Monoid -import qualified Data.Set as Set -import Data.Text as T hiding (filter, map, chunksOf) -import qualified Data.Text.Encoding as E -import Debug.Trace -import Filesystem (listDirectory, isFile) -import Filesystem.Path.CurrentOS -import GHC.Conc -import Prelude hiding (FilePath, sequence, catch) -import Stat -import System.Console.CmdArgs -import System.Environment (getArgs, withArgs) -import System.Posix.Files hiding (fileBlockSize) -import System.Posix.Types (DeviceID, FileID) -import Text.Printf -import Text.Regex.PCRE -import Unsafe.Coerce - -default (Integer, Text) - -version :: String -version = "2.4.2" - -copyright :: String -copyright = "2025" - -sizesSummary :: String -sizesSummary = "sizes v" ++ version ++ ", (C) John Wiegley " ++ copyright - -data SizesOpts = SizesOpts { jobs :: Int - , byCount :: Bool - , annex :: Bool - , apparent :: Bool - , baseTen :: Bool - , exclude :: String - , minSize :: Int - , minCount :: Int - , blockSize :: Int - , smalls :: Bool - , dedupeLinks :: Bool - -- , dirsOnly :: Bool - , depth :: Int - , dirs :: [String] } - deriving (Data, Typeable, Show, Eq) - -sizesOpts :: SizesOpts -sizesOpts = SizesOpts - { jobs = def &= name "j" &= typ "INT" - &= help "Run INT concurrent finds at once (default: 2)" - , byCount = def &= name "c" &= typ "BOOL" - &= help "Sort output by count (default: by size)" - , annex = def &= name "A" &= typ "BOOL" - &= help "Be mindful of how git-annex stores files" - , apparent = def &= typ "BOOL" - &= help "Print apparent sizes, rather than disk usage" - , baseTen = def &= name "H" &= typ "BOOL" - &= help "Print amounts divided by 1000 rather than 1024" - , exclude = def &= name "x" &= typ "REGEX" - &= help "Exclude files whose path matches the REGEX" - , minSize = def &= name "m" &= typ "INT" - &= help "Smallest size to show, in MB (default: 10)" - , minCount = def &= name "M" &= typ "INT" - &= help "Smallest count to show (default: 100)" - , blockSize = def &= name "B" &= typ "INT" - &= help "Size of blocks on disk (default: 512)" - , smalls = def &= name "s" &= typ "BOOL" - &= help "Also show small (<1M && <100 files) entries" - , dedupeLinks = def &= name "L" &= typ "BOOL" - &= help "Deduplicate hard links (count each inode only once)" - -- , dirsOnly = def &= typ "BOOL" - -- &= help "Show directories only" - , depth = def &= typ "INT" - &= help "Report entries to a depth of INT (default: 1)" - , dirs = def &= args &= typ "DIRS..." } &= - summary sizesSummary &= - program "sizes" &= - help "Calculate amount of disk used by the given directories" - -data EntryInfo = EntryInfo { _entryPath :: FilePath - , _entryCount :: Int - , _entryAllocSize :: Int - , _entryIsDir :: Bool } - deriving Show - -makeLenses ''EntryInfo - --- Track (DeviceID, FileID) pairs to detect hard links -type SeenInodes = Set.Set (DeviceID, FileID) - -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 - -instance Monoid EntryInfo where - mempty = newEntry "" False - mappend = (<>) - -instance NFData EntryInfo where - rnf a = a `seq` () - -main :: IO () -main = do - mainArgs <- getArgs - opts <- withArgs (if L.null mainArgs then [] else mainArgs) - (cmdArgs sizesOpts) - _ <- GHC.Conc.setNumCapabilities $ case jobs opts of 0 -> 2; x -> x - runSizes $ case depth opts of 0 -> opts { depth = 1 }; _ -> opts - -runSizes :: SizesOpts -> IO () -runSizes opts = do - let dirsOpt = dirs opts - directories = if L.null dirsOpt then ["."] else dirsOpt - reportSizes opts $ map (fromText . pack) directories - stopGlobalPool - -reportEntryP :: SizesOpts -> EntryInfo -> Bool -reportEntryP opts entry = smalls opts - || entry^.entryAllocSize >= minSize' - || entry^.entryCount >= minCount' - where - minSize' = (if minSize opts == 0 then 10 else minSize opts) * - (if baseTen opts then 1000 else 1024)^2 - minCount' = if minCount opts == 0 then 100 else minCount opts - -reportSizes :: SizesOpts -> [FilePath] -> IO () -reportSizes opts xs = do - entryInfos <- parallel $ map reportSizesForDir xs - let infos = map fst entryInfos ++ - DL.toList (DL.concat (map snd entryInfos)) - sorted = L.sortBy ((compare `on`) $ - if byCount opts - then (^. entryCount) - else (^. entryAllocSize)) infos - mapM_ (reportEntry (baseTen opts)) (filter (reportEntryP opts) sorted) - - where - reportSizesForDir 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' 0 dir) Set.empty - -humanReadable :: Int -> Int -> String -humanReadable x div - | x < div = printf "%db" x - | x < div^2 = printf "%.0fK" (fromIntegral x / (fromIntegral div :: Double)) - | x < div^3 = printf "%.1fM" (fromIntegral x / (fromIntegral div^2 :: Double)) - | x < div^4 = printf "%.2fG" (fromIntegral x / (fromIntegral div^3 :: Double)) - | x < div^5 = printf "%.3fT" (fromIntegral x / (fromIntegral div^4 :: Double)) - | x < div^6 = printf "%.3fP" (fromIntegral x / (fromIntegral div^5 :: Double)) - | x < div^7 = printf "%.3fX" (fromIntegral x / (fromIntegral div^6 :: Double)) - | otherwise = printf "%db" x - -reportEntry :: Bool -> EntryInfo -> IO () -reportEntry bTen entry = - let path = unpack (toTextIgnore (entry^.entryPath)) - in printf - (unpack "%10s %10d %s%s\n") - (humanReadable (entry^.entryAllocSize) (if bTen then 1000 else 1024)) - (entry^.entryCount) path - (unpack $ if entry^.entryIsDir && L.last path /= '/' - then "/" else "") - -toTextIgnore :: FilePath -> Text -toTextIgnore = either id id . toText - -returnEmpty :: FilePath -> StateT SeenInodes IO (EntryInfo, DList EntryInfo) -returnEmpty path = return (newEntry path False, DL.empty) - -gatherSizes :: SizesOpts -> Int -> FilePath -> StateT SeenInodes IO (EntryInfo, DList EntryInfo) -gatherSizes opts 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 - _ -> - (do status <- liftIO (if curDepth == 0 - then getFileStatus path' - else getSymbolicLinkStatus path') - go status) - `catch` - (\e -> do liftIO $ putStrLn $ path' ++ ": " ++ Prelude.show (e :: IOException) - returnEmpty path) - where - pathT = toTextIgnore path - path' = unpack pathT - - go status - | isDirectory status = - foldM (\(y, ys) x -> do - (x',xs') <- gatherSizes opts (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'')) - (newEntry path True, DL.empty) =<< liftIO (listDirectory path) - - | (isRegularFile status - && not (annex opts && ".git/annex/" `isInfixOf` pathT)) - || (annex opts && isSymbolicLink status) = do - status' <- - -- If status is for a symbolic link, it must be a Git-annex'd file - if isSymbolicLink status - then do - destPath <- liftIO $ readSymbolicLink path' - if ".git/annex/" `L.isInfixOf` destPath - then do - let destFilePath = fromText (T.pack destPath) - destPath' = if relative destFilePath - then T.unpack . toTextIgnore $ - parent path destFilePath - else destPath - destFilePath' = fromText (T.pack destPath') - exists <- liftIO $ isFile destFilePath' - if exists - then liftIO $ getFileStatus destPath' - else return status - else return status - else return status - - -- Check for hard link deduplication - let dev = deviceID status' - ino = fileID status' - numLinks = linkCount status' - shouldDedupe = dedupeLinks opts && numLinks > 1 - - -- If deduplication is enabled and this has multiple hard links, check if we've seen it - alreadySeen <- if shouldDedupe - then do - seen <- get - if Set.member (dev, ino) seen - then return True - else do - put $ Set.insert (dev, ino) seen - return False - else return False - - let fsize = fileSize status' - blksize = fileBlockSize (unsafeCoerce status') - allocSize = if alreadySeen - then 0 -- Don't count size if we've already seen this inode - else if apparent opts - then fromIntegral fsize - else fromIntegral blksize * blockSize opts - - return (EntryInfo { _entryPath = path - , _entryCount = if alreadySeen then 0 else 1 - , _entryAllocSize = allocSize - , _entryIsDir = False }, DL.empty) - - | otherwise = returnEmpty path - --- Main.hs (sizes) ends here diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,2 +1,106 @@ -sizes compute the space and i-node consumption of all files and directories -under the current directory. Think du, but with a bit more flexibility. +# sizes + +I wrote `sizes` because `du` wasn't giving me what I needed. When you're +managing large filesystems -- especially ones with git-annex repositories -- +you want to see where your disk space is actually going, sorted by size or +file count, with the ability to exclude paths and handle hard-linked files +properly. + +It's `du` with a bit more flexibility: concurrent traversal, PCRE path +exclusion, git-annex awareness, hard link deduplication, and output that +focuses on what matters. + +## Getting started + +```bash +# With Nix (preferred) +nix build github:jwiegley/sizes +./result/bin/sizes /path/to/dir + +# Or install via Cabal +cabal install sizes +``` + +## Usage + +```bash +# Basic: show directories using >10MB +sizes /path/to/dir + +# Sort by file count +sizes -c /path/to/dir + +# Use 4 concurrent threads +sizes -j4 /path/to/dir + +# Exclude paths matching a regex +sizes -x '\.cache' /path/to/dir + +# Stay on one filesystem (skip mounted volumes, NFS/SMB shares, etc.) +sizes -X /path/to/dir + +# Handle git-annex repos correctly +sizes -A /path/to/annex-repo + +# Deduplicate hard links +sizes -L /path/to/dir + +# Show apparent sizes (not allocated blocks) +sizes --apparent /path/to/dir + +# Base-10 units (MB/GB instead of MiB/GiB) +sizes -H /path/to/dir + +# Lower the minimum threshold +sizes -m 1 /path/to/dir + +# Increase reporting depth +sizes --depth 3 /path/to/dir + +# Show everything, including small entries +sizes -s /path/to/dir +``` + +## Options + +| Flag | Description | +|------|-------------| +| `-j INT` | Concurrent threads (default: 2) | +| `-c` | Sort by file count | +| `-A` | Git-annex aware | +| `--apparent` | Apparent sizes, not disk blocks | +| `-H` | Base-10 (MB/GB) | +| `-x REGEX` | Exclude matching paths | +| `-m INT` | Minimum size in MB (default: 10) | +| `-M INT` | Minimum file count (default: 100) | +| `-B INT` | Block size in bytes (default: 512) | +| `-s` | Show small entries | +| `-L` | Deduplicate hard links | +| `-X`, `--one-file-system` | Don't descend into other filesystems | +| `--depth INT` | Reporting depth (default: 1) | + +## Development + +```bash +# Enter dev shell +nix develop + +# Build +cabal build + +# Run tests +cabal test + +# Format code +fourmolu --mode inplace Sizes.hs app/Main.hs test/Spec.hs + +# Lint +hlint Sizes.hs app/Main.hs test/Spec.hs + +# Run all checks +nix flake check +``` + +## License + +BSD-3-Clause -- see [LICENSE.md](LICENSE.md). diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/Sizes.hs b/Sizes.hs new file mode 100644 --- /dev/null +++ b/Sizes.hs @@ -0,0 +1,393 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Sizes ( + -- * Main entry point + sizesMain, + + -- * Types + SizesOpts (..), + EntryInfo (..), + SeenInodes, + + -- * Lenses + entryPath, + entryCount, + entryAllocSize, + entryIsDir, + + -- * Functions + humanReadable, + reportEntryP, + newEntry, + 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) +import Control.Lens +import Control.Monad +import Control.Monad.Catch (catch) +import Control.Monad.State.Strict +import Data.DList (DList) +import qualified Data.DList as DL +import Data.Function +import qualified Data.List as L +import qualified Data.Set as Set +import Data.Text as T hiding (chunksOf, filter, map) +import Filesystem (isFile, listDirectory) +import Filesystem.Path.CurrentOS +import GHC.Conc +import Stat +import System.Console.CmdArgs +import System.Environment (getArgs, withArgs) +import System.Posix.Files hiding (fileBlockSize) +import System.Posix.Types (DeviceID, FileID) +import Text.Printf +import Text.Regex.PCRE +import Unsafe.Coerce +import Prelude hiding (FilePath, sequence) + +default (Integer, Text) + +version :: String +version = "2.4.3" + +copyright :: String +copyright = "2012-2026" + +sizesSummary :: String +sizesSummary = "sizes v" ++ version ++ ", (C) John Wiegley " ++ copyright + +data SizesOpts = SizesOpts + { jobs :: Int + , byCount :: Bool + , annex :: Bool + , apparent :: Bool + , baseTen :: Bool + , exclude :: String + , minSize :: Int + , minCount :: Int + , blockSize :: Int + , smalls :: Bool + , dedupeLinks :: Bool + , oneFileSystem :: Bool + , -- , dirsOnly :: Bool + depth :: Int + , dirs :: [String] + } + deriving (Data, Typeable, Show, Eq) + +sizesOpts :: SizesOpts +sizesOpts = + SizesOpts + { jobs = + def + &= name "j" + &= typ "INT" + &= help "Run INT concurrent finds at once (default: 2)" + , byCount = + def + &= name "c" + &= typ "BOOL" + &= help "Sort output by count (default: by size)" + , annex = + def + &= name "A" + &= typ "BOOL" + &= help "Be mindful of how git-annex stores files" + , apparent = + def + &= typ "BOOL" + &= help "Print apparent sizes, rather than disk usage" + , baseTen = + def + &= name "H" + &= typ "BOOL" + &= help "Print amounts divided by 1000 rather than 1024" + , exclude = + def + &= name "x" + &= typ "REGEX" + &= help "Exclude files whose path matches the REGEX" + , minSize = + def + &= name "m" + &= typ "INT" + &= help "Smallest size to show, in MB (default: 10)" + , minCount = + def + &= name "M" + &= typ "INT" + &= help "Smallest count to show (default: 100)" + , blockSize = + def + &= name "B" + &= typ "INT" + &= help "Size of blocks on disk (default: 512)" + , smalls = + def + &= name "s" + &= typ "BOOL" + &= help "Also show small (<1M && <100 files) entries" + , dedupeLinks = + def + &= name "L" + &= typ "BOOL" + &= help "Deduplicate hard links (count each inode only once)" + , oneFileSystem = + def + &= explicit + &= name "one-file-system" + &= name "X" + &= typ "BOOL" + &= help "Do not descend into directories on other filesystems" + , -- , dirsOnly = def &= typ "BOOL" + -- &= help "Show directories only" + depth = + def + &= typ "INT" + &= help "Report entries to a depth of INT (default: 1)" + , dirs = def &= args &= typ "DIRS..." + } + &= summary sizesSummary + &= program "sizes" + &= help "Calculate amount of disk used by the given directories" + +data EntryInfo = EntryInfo + { _entryPath :: FilePath + , _entryCount :: Int + , _entryAllocSize :: Int + , _entryIsDir :: Bool + } + deriving (Show, Eq) + +makeLenses ''EntryInfo + +-- Track (DeviceID, FileID) pairs to detect hard links +type SeenInodes = Set.Set (DeviceID, FileID) + +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 + +instance Monoid EntryInfo where + mempty = newEntry "" False + +instance NFData EntryInfo where + rnf a = a `seq` () + +sizesMain :: IO () +sizesMain = do + mainArgs <- getArgs + opts <- + withArgs + (if L.null mainArgs then [] else mainArgs) + (cmdArgs sizesOpts) + GHC.Conc.setNumCapabilities $ case jobs opts of 0 -> 2; x -> x + runSizes $ case depth opts of 0 -> opts{depth = 1}; _ -> opts + +runSizes :: SizesOpts -> IO () +runSizes opts = do + let dirsOpt = dirs opts + directories = if L.null dirsOpt then ["."] else dirsOpt + reportSizes opts $ Prelude.map (fromText . pack) directories + stopGlobalPool + +reportEntryP :: SizesOpts -> EntryInfo -> Bool +reportEntryP opts entry = + smalls opts + || entry ^. entryAllocSize >= minSize' + || entry ^. entryCount >= minCount' + where + minSize' = + (if minSize opts == 0 then 10 else minSize opts) + * (if baseTen opts then 1000 else 1024) ^ (2 :: Int) + minCount' = if minCount opts == 0 then 100 else minCount opts + +reportSizes :: SizesOpts -> [FilePath] -> IO () +reportSizes opts xs = do + entryInfos <- parallel $ Prelude.map reportSizesForDir xs + let infos = + Prelude.map fst entryInfos + ++ DL.toList (DL.concat (Prelude.map snd entryInfos)) + sorted = + L.sortBy + ( (compare `on`) $ + if byCount opts + then (^. entryCount) + else (^. entryAllocSize) + ) + infos + mapM_ + (reportEntry (baseTen opts)) + (Prelude.filter (reportEntryP opts) sorted) + where + reportSizesForDir 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 + +humanReadable :: Int -> Int -> String +humanReadable x d + | x < d = printf "%db" x + | x < d ^ (2 :: Int) = printf "%.0fK" (fromIntegral x / (fromIntegral d :: Double)) + | x < d ^ (3 :: Int) = printf "%.1fM" (fromIntegral x / (fromIntegral d ^ (2 :: Int) :: Double)) + | x < d ^ (4 :: Int) = printf "%.2fG" (fromIntegral x / (fromIntegral d ^ (3 :: Int) :: Double)) + | x < d ^ (5 :: Int) = printf "%.3fT" (fromIntegral x / (fromIntegral d ^ (4 :: Int) :: Double)) + | x < d ^ (6 :: Int) = printf "%.3fP" (fromIntegral x / (fromIntegral d ^ (5 :: Int) :: Double)) + | x < d ^ (7 :: Int) = printf "%.3fX" (fromIntegral x / (fromIntegral d ^ (6 :: Int) :: Double)) + | otherwise = printf "%db" x + +reportEntry :: Bool -> EntryInfo -> IO () +reportEntry bTen entry = + let path = T.unpack (toTextIgnore (entry ^. entryPath)) + in printf + (T.unpack "%10s %10d %s%s\n") + (humanReadable (entry ^. entryAllocSize) (if bTen then 1000 else 1024)) + (entry ^. entryCount) + path + ( T.unpack $ + if entry ^. entryIsDir && L.last path /= '/' + then "/" + else "" + ) + +toTextIgnore :: FilePath -> Text +toTextIgnore = either id id . toText + +returnEmpty :: FilePath -> StateT SeenInodes IO (EntryInfo, DList EntryInfo) +returnEmpty path = return (newEntry path False, DL.empty) + +{- | 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 +the traversal root, or 'Nothing' at the top-level argument itself (where the +boundary is merely established, so nothing is skipped). +-} +crossesFileSystemBoundary :: Bool -> Maybe DeviceID -> DeviceID -> Bool +crossesFileSystemBoundary False _ _ = False +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 + _ -> + ( do + status <- + liftIO + ( if curDepth == 0 + then getFileStatus path' + else getSymbolicLinkStatus path' + ) + if crossesFileSystemBoundary (oneFileSystem opts) mRootDev (deviceID status) + then returnEmpty path + else go status + ) + `catch` ( \e -> do + liftIO $ putStrLn $ path' ++ ": " ++ Prelude.show (e :: IOException) + returnEmpty path + ) + where + pathT = toTextIgnore path + path' = T.unpack pathT + + go status + | 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'') + ) + (newEntry path True, DL.empty) + =<< liftIO (listDirectory path) + | ( isRegularFile status + && not (annex opts && ".git/annex/" `isInfixOf` pathT) + ) + || (annex opts && isSymbolicLink status) = do + status' <- + -- If status is for a symbolic link, it must be a Git-annex'd file + if isSymbolicLink status + then do + destPath <- liftIO $ readSymbolicLink path' + if ".git/annex/" `L.isInfixOf` destPath + then do + let destFilePath = fromText (T.pack destPath) + destPath' = + if relative destFilePath + then + T.unpack . toTextIgnore $ + parent path destFilePath + else destPath + destFilePath' = fromText (T.pack destPath') + exists <- liftIO $ isFile destFilePath' + if exists + then liftIO $ getFileStatus destPath' + else return status + else return status + else return status + + -- Check for hard link deduplication + let dev = deviceID status' + ino = fileID status' + numLinks = linkCount status' + shouldDedupe = dedupeLinks opts && numLinks > 1 + + -- If deduplication is enabled and this has multiple hard links, check if we've seen it + alreadySeen <- + if shouldDedupe + then do + seen <- get + if Set.member (dev, ino) seen + then return True + else do + put $ Set.insert (dev, ino) seen + return False + else return False + + let fsize = fileSize status' + blksize = fileBlockSize (unsafeCoerce status') + allocSize + | alreadySeen = 0 -- Don't count size if we've already seen this inode + | apparent opts = fromIntegral fsize + | otherwise = fromIntegral blksize * blockSize opts + + return + ( EntryInfo + { _entryPath = path + , _entryCount = if alreadySeen then 0 else 1 + , _entryAllocSize = allocSize + , _entryIsDir = False + } + , DL.empty + ) + | otherwise = returnEmpty path + +-- Sizes.hs ends here diff --git a/Stat.hsc b/Stat.hsc --- a/Stat.hsc +++ b/Stat.hsc @@ -2,7 +2,6 @@ module Stat where -import Foreign.C.String import Foreign.C.Types import Foreign.ForeignPtr import Foreign.Ptr @@ -11,7 +10,6 @@ import System.Posix.ByteString.FilePath import System.Posix.Internals ( CFilePath ) import System.Posix.Types -import Unsafe.Coerce #include "HsStat.h" diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Sizes (sizesMain) + +main :: IO () +main = sizesMain diff --git a/sizes.cabal b/sizes.cabal --- a/sizes.cabal +++ b/sizes.cabal @@ -1,53 +1,76 @@ -Name: sizes +cabal-version: 2.4 +name: sizes +version: 2.4.3 +synopsis: Recursively show space (size and i-nodes) used in subdirectories +description: + A command-line utility that recursively analyzes directory trees to display + space usage information, including both file sizes and inode counts. -Version: 2.4.2 -Synopsis: Recursively show space (size and i-nodes) used in subdirectories +homepage: https://github.com/jwiegley/sizes +license: BSD-3-Clause +license-file: LICENSE.md +author: John Wiegley +maintainer: John Wiegley +category: Development +build-type: Simple -Description: - A command-line utility that recursively analyzes directory trees to display - space usage information, including both file sizes and inode counts. This tool - provides detailed statistics about disk space consumption in subdirectories, - making it useful for identifying large files and directories, analyzing storage - usage patterns, and managing disk space efficiently. The output can be filtered - and sorted to help locate space-consuming items quickly. +extra-source-files: + README.md + Stat.hsc + HsStat.h + HsStat.c -Homepage: https://github.com/jwiegley/sizes -License: BSD3 -License-file: LICENSE -Author: John Wiegley -Maintainer: John Wiegley -Category: Development -Build-type: Simple -Cabal-version: >= 1.10 +library + exposed-modules: + Sizes + Stat -Extra-Source-Files: README.md Stat.hsc HsStat.h HsStat.c + hs-source-dirs: . + include-dirs: . + includes: HsStat.h + c-sources: HsStat.c + default-language: Haskell2010 + ghc-options: -Wall -Wcompat -Executable sizes - Main-is: Main.hs - Other-modules: Stat - Include-dirs: . - Includes: HsStat.h - c-sources: HsStat.c - ghc-options: -threaded -with-rtsopts=-K64M + build-depends: + , base >= 4 && < 5 + , 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 + , parallel-io >= 0.3.2 && < 0.4 + , regex-pcre >= 0.95 && < 0.96 + , semigroups >= 0.8 && < 0.21 + , system-fileio >= 0.3.9 && < 0.4 + , system-filepath >= 0.4.7 && < 0.5 + , text >= 0.11 && < 2.2 + , unix >= 2.5 && < 2.9 - default-language: Haskell2010 +executable sizes + main-is: Main.hs + hs-source-dirs: app + default-language: Haskell2010 + ghc-options: -Wall -Wcompat -threaded -with-rtsopts=-K64M - Build-depends: base >= 4 && < 5 - , cmdargs >= 0.10 && < 0.11 - , containers >= 0.5 && < 0.8 - , deepseq >= 1.3 && < 1.6 - , exceptions >= 0.8 && < 0.11 - , lens >= 2.8 && < 6 - , mtl >= 2.2 && < 2.4 - , parallel-io >= 0.3.2 && < 0.4 - , regex-pcre >= 0.95 && < 0.96 - , system-fileio >= 0.3.9 && < 0.4 - , system-filepath >= 0.4.7 && < 0.5 - , dlist >= 0.5 && < 1.1 - , semigroups >= 0.8 && < 0.21 - , text >= 0.11 && < 2.2 - , unix >= 2.5 && < 2.9 + build-depends: + , base >= 4 && < 5 + , sizes -Source-repository head +test-suite sizes-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall -Wcompat + + build-depends: + , base >= 4 && < 5 + , hedgehog >= 1.0 && < 1.6 + , sizes + +source-repository head type: git location: https://github.com/jwiegley/sizes diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +import Control.Monad (unless) +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Sizes (EntryInfo (..), crossesFileSystemBoundary, humanReadable) +import System.Exit (exitFailure) +import System.Posix.Types (DeviceID) + +main :: IO () +main = do + passed <- checkParallel $$(discover) + unless passed exitFailure + +-- | Generate an EntryInfo with random count and size. +genEntryInfo :: Gen EntryInfo +genEntryInfo = do + count <- Gen.int (Range.linear 0 10000) + size <- Gen.int (Range.linear 0 (1024 * 1024 * 1024)) + isDir <- Gen.bool + pure $ mempty{_entryCount = count, _entryAllocSize = size, _entryIsDir = isDir} + +-- humanReadable: bytes +prop_humanReadable_bytes :: Property +prop_humanReadable_bytes = + withTests 1 . property $ + humanReadable 500 1024 === "500b" + +-- humanReadable: kilobytes +prop_humanReadable_kilobytes :: Property +prop_humanReadable_kilobytes = + withTests 1 . property $ + humanReadable 2048 1024 === "2K" + +-- humanReadable: megabytes (base-2) +prop_humanReadable_megabytes :: Property +prop_humanReadable_megabytes = + withTests 1 . property $ + humanReadable (5 * 1024 * 1024) 1024 === "5.0M" + +-- humanReadable: gigabytes (base-2) +prop_humanReadable_gigabytes :: Property +prop_humanReadable_gigabytes = + withTests 1 . property $ + humanReadable (2 * 1024 * 1024 * 1024) 1024 === "2.00G" + +-- humanReadable: megabytes (base-10) +prop_humanReadable_base10 :: Property +prop_humanReadable_base10 = + withTests 1 . property $ + humanReadable 5000000 1000 === "5.0M" + +-- Semigroup: count accumulation is associative +prop_semigroup_count_associative :: Property +prop_semigroup_count_associative = property $ do + a <- forAll genEntryInfo + b <- forAll genEntryInfo + c <- forAll genEntryInfo + _entryCount ((a <> b) <> c) === _entryCount (a <> (b <> c)) + +-- Semigroup: size accumulation is associative +prop_semigroup_size_associative :: Property +prop_semigroup_size_associative = property $ do + a <- forAll genEntryInfo + b <- forAll genEntryInfo + c <- forAll genEntryInfo + _entryAllocSize ((a <> b) <> c) === _entryAllocSize (a <> (b <> c)) + +-- Monoid: right identity preserves count +prop_monoid_right_identity_count :: Property +prop_monoid_right_identity_count = property $ do + e <- forAll genEntryInfo + _entryCount (e <> mempty) === _entryCount e + +-- Monoid: right identity preserves size +prop_monoid_right_identity_size :: Property +prop_monoid_right_identity_size = property $ do + e <- forAll genEntryInfo + _entryAllocSize (e <> mempty) === _entryAllocSize e + +-- humanReadable always returns a non-empty string +prop_humanReadable_nonempty :: Property +prop_humanReadable_nonempty = property $ do + x <- forAll $ Gen.int (Range.linear 0 (1024 * 1024 * 1024 * 1024)) + d <- forAll $ Gen.element [1000, 1024] + assert $ not (null (humanReadable x d)) + +-- | Generate an arbitrary device ID. +genDevice :: Gen DeviceID +genDevice = fromIntegral <$> Gen.int (Range.linear 0 100000) + +-- crossesFileSystemBoundary: with the option disabled, nothing is ever a crossing +prop_oneFS_disabled_never_crosses :: Property +prop_oneFS_disabled_never_crosses = property $ do + root <- forAll $ Gen.maybe genDevice + dev <- forAll genDevice + crossesFileSystemBoundary False root dev === False + +-- crossesFileSystemBoundary: the traversal root only establishes the boundary +prop_oneFS_root_establishes_boundary :: Property +prop_oneFS_root_establishes_boundary = property $ do + dev <- forAll genDevice + crossesFileSystemBoundary True Nothing dev === False + +-- crossesFileSystemBoundary: same device as the root is not a crossing +prop_oneFS_same_device_stays :: Property +prop_oneFS_same_device_stays = property $ do + dev <- forAll genDevice + crossesFileSystemBoundary True (Just dev) dev === False + +-- crossesFileSystemBoundary: a different device than the root is a crossing +prop_oneFS_different_device_crosses :: Property +prop_oneFS_different_device_crosses = property $ do + root <- forAll genDevice + delta <- forAll $ Gen.int (Range.linear 1 100000) + let dev = root + fromIntegral delta + crossesFileSystemBoundary True (Just root) dev === True