diff --git a/HsStat.c b/HsStat.c new file mode 100644 --- /dev/null +++ b/HsStat.c @@ -0,0 +1,12 @@ +#include "HsStat.h" + +#if defined(__MINGW32__) +inline int __hscore_statvfs(wchar_t *path, struct_statvfs *buf) { + /* jww (2012-10-18): ??? */ + return _wstatvfsi64(path,buf); +} +#else +inline int __hscore_statvfs(char *path, struct_statvfs *buf) { + return statvfs(path,buf); +} +#endif diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -9,24 +9,28 @@ import Control.Exception import Control.Lens import Control.Monad hiding (sequence) +import qualified Data.Text.Encoding as E import Data.Function import qualified Data.List as L import Data.Monoid import Data.Text as T hiding (filter, map, chunksOf) -import Filesystem (listDirectory) +import Filesystem (listDirectory, isFile) import Filesystem.Path.CurrentOS import GHC.Conc -import Prelude hiding (FilePath, sequence, catch) +import Prelude hiding (FilePath, sequence) +import Stat import System.Console.CmdArgs import System.Environment (getArgs, withArgs) import System.Posix.Files import Text.Printf import Text.Regex.Posix +import Unsafe.Coerce +import Debug.Trace default (Integer, Text) version :: String -version = "1.2.0" +version = "2.0.1" copyright :: String copyright = "2012" @@ -34,45 +38,55 @@ sizesSummary :: String sizesSummary = "sizes v" ++ version ++ ", (C) John Wiegley " ++ copyright -data SizesOpts = SizesOpts { jobs :: Int - , byCount :: Bool - , exclude :: String - , minSize :: Integer - , minCount :: Integer - , smalls :: Bool +data SizesOpts = SizesOpts { jobs :: Int + , byCount :: Bool + , annex :: Bool + , apparent :: Bool + , exclude :: String + , minSize :: Integer + , minCount :: Integer + , blockSize :: Integer + , smalls :: Bool -- , dirsOnly :: Bool - , depth :: Int - , dirs :: [String] } + , 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)" - , exclude = def &= name "x" &= typ "REGEX" - &= help "Sort output by count (default: by size)" - , minSize = def &= name "m" &= typ "INT" - &= help "Smallest entries to show, in MB (default: 10)" - , minCount = def &= name "M" &= typ "INT" - &= help "Smallest entries to show, in count (default: 100)" - , smalls = def &= name "s" &= typ "BOOL" - &= help "Also show small (<1M && <100 files) entries" + { 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" + , exclude = def &= name "x" &= typ "REGEX" + &= help "Sort output by count (default: by size)" + , 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" -- , dirsOnly = def &= typ "BOOL" -- &= help "Show directories only" - , depth = def &= typ "INT" - &= help "Report all entries to a depth of INT (default: 0)" - , dirs = def &= args &= typ "DIRS..." } &= + , depth = def &= typ "INT" + &= help "Report entries to a depth of INT (default: 0)" + , 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 :: !Integer - , _entrySize :: !Integer - , _entryIsDir :: !Bool } - deriving Show +data EntryInfo = EntryInfo { _entryPath :: !FilePath + , _entryCount :: !Integer + , _entryActualSize :: !Integer + , _entryAllocSize :: !Integer + , _entryIsDir :: !Bool } + deriving Show makeLenses ''EntryInfo @@ -80,35 +94,45 @@ rnf a = a `seq` () newEntry :: FilePath -> Bool -> EntryInfo -newEntry p = EntryInfo p 0 0 +newEntry p = EntryInfo p 0 0 0 main :: IO () main = do mainArgs <- getArgs - opts <- withArgs (if L.null mainArgs then ["."] else mainArgs) + opts <- withArgs (if L.null mainArgs then [] else mainArgs) (cmdArgs sizesOpts) _ <- GHC.Conc.setNumCapabilities $ case jobs opts of 0 -> 2; x -> x runSizes opts runSizes :: SizesOpts -> IO () runSizes opts = do - reportSizes opts $ map (fromText . pack) (dirs opts) + let dirsOpt = dirs opts + directories = if L.null dirsOpt then ["."] else dirsOpt + reportSizes opts $ map (fromText . pack) directories stopGlobalPool reportSizes :: SizesOpts -> [FilePath] -> IO () reportSizes opts xs = do - entryInfos <- parallel $ map (gatherSizesW opts 0) xs + entryInfos <- parallel $ map reportSizesForDir xs let infos = map fst entryInfos ++ mconcat (map snd entryInfos) sorted = L.sortBy ((compare `on`) $ if byCount opts then (^. entryCount) - else (^. entrySize)) infos + else (^. entryAllocSize)) infos forM_ sorted $ \entry -> when ( smalls opts - || entry^.entrySize >= minSize' + || entry^.entryAllocSize >= minSize' || entry^.entryCount >= minCount') $ reportEntry entry where + reportSizesForDir dir = do + fsStatus <- getFilesystemStatus (E.encodeUtf8 (toTextIgnore dir)) + let fsBlkSize = statBlockSize -- filesystemBlockSize fsStatus + opts' = if blockSize opts == 0 + then opts { blockSize = fromIntegral fsBlkSize } + else opts + gatherSizesW opts' 0 dir + minSize' = (if minSize opts == 0 then 10 else minSize opts) * 1024^2 minCount' = (if minCount opts == 0 then 100 else minCount opts) @@ -127,7 +151,8 @@ reportEntry entry = let path = unpack . toTextIgnore $ entry^.entryPath in printf (unpack "%10s %10d %s%s\n") - (humanReadable (entry^.entrySize)) (entry^.entryCount) path + (humanReadable (entry^.entryAllocSize)) + (entry^.entryCount) path (unpack $ if entry^.entryIsDir && L.last path /= '/' then "/" else "") @@ -151,6 +176,8 @@ where path' = unpack $ toTextIgnore path + annexRe = unpack "\\.git/annex/" + gatherSizes' status | (exclude opts) /= "" && path' =~ exclude opts = returnEmpty @@ -160,22 +187,59 @@ in if curDepth == 0 then parallel $ map func files else mapM func files + let firsts = map fst entries + return $!! ( L.foldl' (\current entry -> - entryCount +~ entry^.entryCount $ - entrySize +~ entry^.entrySize $ current) + entryCount +~ entry^.entryCount $ + entryActualSize +~ entry^.entryActualSize $ + entryAllocSize +~ entry^.entryAllocSize $ current) (newEntry path True) firsts , if curDepth <= depth opts then firsts ++ L.concatMap snd entries else [] ) - | isRegularFile status = - return (entryCount .~ 1 $ - entrySize .~ fromIntegral (fileSize status) $ - newEntry path False, []) + | ( isRegularFile status + && not (annex opts && path' =~ annexRe)) + || (annex opts && isSymbolicLink status) = + catch (getFileSize status) + (\e -> do print (e :: IOException) + returnEmpty) | otherwise = returnEmpty + + -- If status is for a symbolic link, it must be a Git-annex'd file + getFileSize status = do + status' <- + if isSymbolicLink status + then do + destPath <- readSymbolicLink path' + if destPath =~ annexRe + 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 <- isFile destFilePath' + if exists + then getFileStatus destPath' + else return status + else return status + else return status + + let fsize = fromIntegral $ fileSize status' + blksize = fromIntegral $ + fileBlockSize (unsafeCoerce status') + + return ( entryCount .~ 1 + $ entryActualSize .~ fsize + $ entryAllocSize .~ (if apparent opts + then fsize + else blksize * blockSize opts) + $ newEntry path False, []) returnEmpty = return (newEntry path False, []) diff --git a/Stat.hsc b/Stat.hsc new file mode 100644 --- /dev/null +++ b/Stat.hsc @@ -0,0 +1,47 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Stat where + +import Foreign.C.String +import Foreign.C.Types +import Foreign.ForeignPtr +import Foreign.Ptr +import Foreign.Storable +import System.IO.Unsafe +import System.Posix.ByteString.FilePath +import System.Posix.Internals ( CFilePath ) +import System.Posix.Types +import Unsafe.Coerce + +#include "HsStat.h" + +type CStat = () +newtype FileStatus = FileStatus (ForeignPtr CStat) + +statBlockSize :: FileOffset +statBlockSize = (#const S_BLKSIZE) + +fileBlockSize :: FileStatus -> FileOffset +fileBlockSize (Stat.FileStatus stat) = + unsafePerformIO $ withForeignPtr stat $ (#peek struct stat, st_blocks) + +type CStatvfs = () +newtype FilesystemStatus = FilesystemStatus (ForeignPtr CStatvfs) + +-- jww (2012-10-18): This will +foreign import ccall unsafe "HsBase.h __hscore_statvfs" + c_statvfs :: CFilePath -> Ptr CStatvfs -> IO CInt + +getFilesystemStatus :: RawFilePath -> IO Stat.FilesystemStatus +getFilesystemStatus path = do + fp <- mallocForeignPtrBytes (#const sizeof(struct statvfs)) + withForeignPtr fp $ \p -> + withFilePath path $ \s -> + throwErrnoPathIfMinus1_ "getFilesystemStatus" path (c_statvfs s p) + return (FilesystemStatus fp) + +filesystemBlockSize :: FilesystemStatus -> CULong +filesystemBlockSize (Stat.FilesystemStatus statvfs) = + unsafePerformIO $ withForeignPtr statvfs $ (#peek struct statvfs, f_frsize) + +-- Stat.hsc ends here diff --git a/sizes.cabal b/sizes.cabal --- a/sizes.cabal +++ b/sizes.cabal @@ -1,6 +1,6 @@ Name: sizes -Version: 1.2.0 +Version: 2.0.1 Synopsis: Recursively show space (size and i-nodes) used in subdirectories Description: Recursively show space (size and i-nodes) used in subdirectories @@ -17,10 +17,15 @@ Extra-Source-Files: README.md Executable sizes - Main-is: Main.hs - Ghc-options: -threaded + Main-is: Main.hs + Other-modules: Stat + Include-dirs: . + Includes: HsStat.h + c-sources: HsStat.c + Ghc-options: -threaded Build-depends: base >= 4 && < 5 + , bytestring >= 0.10 , cmdargs >= 0.10 , deepseq >= 1.3 , lens >= 2.8 @@ -29,7 +34,7 @@ , system-fileio >= 0.3.9 , system-filepath >= 0.4.7 , text >= 0.11.2 - , unix >= 2.5.1 + , unix == 2.6.0.0 Source-repository head type: git