diff --git a/Helper.c b/Helper.c new file mode 100644 --- /dev/null +++ b/Helper.c @@ -0,0 +1,44 @@ +#include +#include +#include + +unsigned int __hscore_d_type( struct dirent* d ) +{ + return d->d_type; +} + +unsigned int __hscore_d_namlen( struct dirent* d ) +{ + return d->d_namlen; +} + +int __hscore_readdir_r(DIR * dir, struct dirent * d, struct dirent ** dp) +{ +#if HAVE_READDIR_R + if (d == NULL) { + *dp = readdir(dir); + return 0; + } else { + return readdir_r(dir, d, dp); + } +#else + *dp = readdir(dir); + return 0; +#endif +} + +unsigned int __hscore_sizeof_dirent() +{ + static unsigned int nm_max = (unsigned int)-1; + + if (nm_max == (unsigned int)-1) { +#ifdef NAME_MAX + nm_max = NAME_MAX + 1; +#else + nm_max = pathconf(".", _PC_NAME_MAX); + if (nm_max == -1) { nm_max = 255; } + nm_max++; +#endif + } + return nm_max + sizeof(struct dirent); +} diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, 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 John Wiegley nor the names of other + 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/Pipes/Files.hs b/Pipes/Files.hs new file mode 100644 --- /dev/null +++ b/Pipes/Files.hs @@ -0,0 +1,646 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Pipes.Files + ( + -- * Introduction + -- $intro + + -- ** Basic comparison with GNU find + -- $gnufind + + -- ** Performance + -- $performance + + -- ** Other notes + -- $notes + + -- * Finding functions + sourceFindFiles + , find + , findFiles + , findFilesIO + , findFilePaths + , FindOptions(..) + , defaultFindOptions + , directoryFiles + , test + , ltest + , stat + , lstat + , hasStatus + + -- * File path predicates + , glob + , regex + , ignoreVcs + + -- * GNU find compatibility predicates + , depth_ + , follow_ + , prune_ + , maxdepth_ + , mindepth_ + , ignoreErrors_ + , noIgnoreErrors_ + , amin_ + , atime_ + , anewer_ + , empty_ + , executable_ + , gid_ + , name_ + , getDepth + , filename_ + , pathname_ + , getEntryPath + , getRawEntryPath + + -- * File entry predicates (uses stat information) + , regular + , directory + , hasMode + , executable + , lastAccessed_ + , lastModified_ + + -- * Predicate combinators + , module Cond + , (=~) + + -- * Types and type classes + , FileEntry(..) + , IsFilePath(..) + + -- * Helper functions for library writers + , genericFindFiles + , genericFindFilePaths + , genericFind + , genericTest + , genericLtest + ) where + +import Control.Applicative +import Control.Comonad.Trans.Cofree +import qualified Control.Cond as Cond +import Control.Cond hiding (test) +import Control.Exception as E +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Morph +import Control.Monad.Trans.Control +import Data.Attoparsec.Text as A +import Data.Bits +import qualified Data.ByteString as B +import Data.Char (ord) +import Data.Monoid +import Data.String (IsString) +import Data.Text (Text, pack) +import Data.Time +import Data.Time.Clock.POSIX +import Data.Word (Word8) +import Foreign.C +import Pipes +import Pipes.Files.Directory +import Pipes.Files.Types +import qualified Pipes.Prelude as P +import Pipes.Safe +import Pipes.Tree +import Prelude +import System.Directory hiding (executable, findFiles) +import System.Posix.ByteString.FilePath +import System.Posix.FilePath +import System.PosixCompat.Files +import System.PosixCompat.Types +import Text.Regex.Posix ((=~)) + +{- $intro + +**find-conduit** is essentially a souped version of GNU find for Haskell, +using a DSL to provide both ease of us, and extensive flexbility. + +In its simplest form, let's compare some uses of find to find-conduit. Bear +in mind that the result of the find function is a conduit, so you're expected +to either sink it to a list, or operate on the file paths as they are yielded. +-} + +{- $gnufind + +A typical find command: + +@ +find src -name '*.hs' -type f -print +@ + +Would in find-conduit be: + +@ +find "src" (glob \"*.hs\" \<\> regular) $$ mapM_C (liftIO . print) +@ + +The 'glob' predicate matches the file basename against the globbing pattern, +while the 'regular' predicate matches plain files. + +A more complicated example: + +@ +find . -size +100M -perm 644 -mtime 1 +@ + +Now in find-conduit: + +@ +let megs = 1024 * 1024 + days = 86400 +now <- liftIO getCurrentTime +find \".\" ( fileSize (> 100*megs) + \<\> hasMode 0o644 + \<\> lastModified (> addUTCTime now (-(1*days))) + ) +@ + +Appending predicates like this expressing an "and" relationship. Use '<|>' to +express "or". You can also negate any predicate: + +@ +find \".\" (not_ (hasMode 0o644)) +@ + +By default, predicates, whether matching or not, will allow recursion into +directories. In order to express that matching predicate should disallow +recursion, use 'prune': + +@ +find \".\" (prune (depth (> 2))) +@ + +This is the same as using '-maxdepth 2' in find. + +@ +find \".\" (prune (filename_ (== \"dist\"))) +@ + +This is the same as: + +@ +find . \\( -name dist -prune \\) -o -print +@ +-} + +{- $performance + +find-conduit strives to make file-finding a well performing operation. To +this end, a composed Predicate will only call stat once per entry being +considered; and if you prune a directory, it is not traversed at all. + +By default, 'find' calls stat for every file before it applies the predicate, +in order to ensure that only one such call is needed. Sometimes, however, you +know just from the FilePath that you don't want to consider a certain file, or +you want to prune a directory tree. + +To support these types of optimized queries, a variant of find is provided +called 'findWithPreFilter'. This takes two predicates: one that is applied to +only the FilePath, before stat (or lstat) is called; and one that is applied +to the full file information after the stat. +-} + +{- $notes + +See 'Data.Cond' for more details on the Monad used to build predicates. +-} + +getEntryPath :: (Monad m, IsFilePath f) => CondT (FileEntry f) m f +getEntryPath = queries (fromRawFilePath . entryPath) + +getRawEntryPath :: Monad m => CondT (FileEntry f) m RawFilePath +getRawEntryPath = queries entryPath + +pathname_ :: (Monad m, IsFilePath f) => (f -> Bool) -> CondT (FileEntry f) m () +pathname_ f = guard . f =<< getEntryPath + +-- jww (2014-04-30): This will not perform well for other f's. +filename_ :: (Monad m, IsFilePath f) => (f -> Bool) -> CondT (FileEntry f) m () +filename_ f = pathname_ (f . fromRawFilePath . takeFileName . getRawFilePath) + +getDepth :: Monad m => CondT (FileEntry f) m Int +getDepth = queries entryDepth + +modifyFindOptions :: Monad m + => (FindOptions -> FindOptions) -> CondT (FileEntry f) m () +modifyFindOptions f = + updates $ \e -> e { entryFindOptions = f (entryFindOptions e) } + +------------------------------------------------------------------------ +-- Workalike options for emulating GNU find. +------------------------------------------------------------------------ + +depth_ :: Monad m => CondT (FileEntry f) m () +depth_ = modifyFindOptions $ \opts -> opts { findContentsFirst = True } + +follow_ :: Monad m => CondT (FileEntry f) m () +follow_ = modifyFindOptions $ \opts -> opts { findFollowSymlinks = True } + +prune_ :: Monad m => CondT a m () +prune_ = prune + +ignoreErrors_ :: Monad m => CondT (FileEntry f) m () +ignoreErrors_ = + modifyFindOptions $ \opts -> opts { findIgnoreErrors = True } + +noIgnoreErrors_ :: Monad m => CondT (FileEntry f) m () +noIgnoreErrors_ = + modifyFindOptions $ \opts -> opts { findIgnoreErrors = False } + +maxdepth_ :: Monad m => Int -> CondT (FileEntry f) m () +maxdepth_ l = getDepth >>= guard . (<= l) + +mindepth_ :: Monad m => Int -> CondT (FileEntry f) m () +mindepth_ l = getDepth >>= guard . (>= l) + +-- xdev_ = error "NYI" + +timeComp :: MonadIO m + => ((UTCTime -> Bool) -> CondT (FileEntry f) m ()) -> Int + -> CondT (FileEntry f) m () +timeComp f n = do + now <- liftIO getCurrentTime + f (\t -> diffUTCTime now t > fromIntegral n) + +amin_ :: MonadIO m => Int -> CondT (FileEntry f) m () +amin_ n = timeComp lastAccessed_ (n * 60) + +atime_ :: MonadIO m => Int -> CondT (FileEntry f) m () +atime_ n = timeComp lastAccessed_ (n * 24 * 3600) + +anewer_ :: (MonadIO m, IsFilePath f) => f -> CondT (FileEntry f) m () +anewer_ path = do + e <- query + es <- applyStat Nothing + ms <- liftIO $ getStat Nothing + e { entryPath = getRawFilePath path + , entryStatus = Nothing + } + case ms of + Nothing -> prune >> error "This is never reached" + Just (s, _) -> guard $ diffUTCTime (f s) (f es) > 0 + where + f = posixSecondsToUTCTime . realToFrac . accessTime + +-- cmin_ = error "NYI" +-- cnewer_ = error "NYI" +-- ctime_ = error "NYI" + +empty_ :: MonadIO m => CondT (FileEntry f) m () +empty_ = (regular >> hasStatus ((== 0) . fileSize)) + `mplus` (directory >> hasStatus ((== 2) . linkCount)) + +executable_ :: MonadIO m => CondT (FileEntry f) m () +executable_ = executable + +gid_ :: MonadIO m => Int -> CondT (FileEntry f) m () +gid_ n = hasStatus ((== n) . fromIntegral . fileGroup) + +{- +group_ name +ilname_ pat +iname_ pat +inum_ n +ipath_ pat +iregex_ pat +iwholename_ pat +links_ n +lname_ pat +mmin_ +mtime_ +-} + +name_ :: (Monad m, IsFilePath f, Eq f) => f -> CondT (FileEntry f) m () +name_ = filename_ . (==) + +{- +newer_ path +newerXY_ ref +nogroup_ +nouser_ +path_ pat +perm_ mode :: Perm +readable_ +regex_ pat +samefile_ path +size_ n :: Size +type_ c +uid_ n +used_ n +user_ name +wholename_ pat +writable_ +xtype_ c +-} + +------------------------------------------------------------------------ + +applyStat :: MonadIO m => Maybe Bool -> CondT (FileEntry f) m FileStatus +applyStat mfollow = do + ms <- liftIO . getStat mfollow =<< query + case ms of + Nothing -> prune >> error "This is never reached" + Just (s, e') -> const s `liftM` update e' + +lstat :: MonadIO m => CondT (FileEntry f) m FileStatus +lstat = applyStat (Just False) + +stat :: MonadIO m => CondT (FileEntry f) m FileStatus +stat = applyStat (Just True) + +hasStatus :: MonadIO m => (FileStatus -> Bool) -> CondT (FileEntry f) m () +hasStatus f = guard . f =<< applyStat Nothing + +regular :: MonadIO m => CondT (FileEntry f) m () +regular = hasStatus isRegularFile + +executable :: MonadIO m => CondT (FileEntry f) m () +executable = hasMode ownerExecuteMode + +directory :: MonadIO m => CondT (FileEntry f) m () +directory = hasStatus isDirectory + +hasMode :: MonadIO m => FileMode -> CondT (FileEntry f) m () +hasMode m = hasStatus (\s -> fileMode s .&. m /= 0) + +withStatusTime :: MonadIO m + => (FileStatus -> EpochTime) -> (UTCTime -> Bool) + -> CondT (FileEntry f) m () +withStatusTime g f = hasStatus (f . posixSecondsToUTCTime . realToFrac . g) + +lastAccessed_ :: MonadIO m => (UTCTime -> Bool) -> CondT (FileEntry f) m () +lastAccessed_ = withStatusTime accessTime + +lastModified_ :: MonadIO m => (UTCTime -> Bool) -> CondT (FileEntry f) m () +lastModified_ = withStatusTime modificationTime + +regex :: (Monad m, IsFilePath f) => String -> CondT (FileEntry f) m () +regex pat = filename_ ((=~ pat) . getFilePath) + +-- | Return all entries, except for those within version-control metadata +-- directories (and not including the version control directory itself either). +ignoreVcs :: (Monad m, IsString f, Eq f, IsFilePath f) + => CondT (FileEntry f) m () +ignoreVcs = when_ (filename_ (`elem` vcsDirs)) prune + where + vcsDirs = [ ".git", "CVS", "RCS", "SCCS", ".svn", ".hg", "_darcs" ] + +-- | Find every entry whose filename part matching the given filename globbing +-- expression. For example: @glob "*.hs"@. +glob :: (Monad m, IsString f, IsFilePath f, Monoid f) + => String -> CondT (FileEntry f) m () +glob g = case parseOnly globParser (pack g) of + Left e -> error $ "Failed to parse glob: " ++ e + Right x -> regex ("^" <> fromTextPath x <> "$") + where + globParser :: Parser Text + globParser = fmap mconcat $ many $ + char '*' *> return ".*" + <|> char '?' *> return "." + <|> string "[]]" *> return "[]]" + <|> (\x y z -> pack ((x:y) ++ [z])) + <$> char '[' + <*> manyTill anyChar (A.try (char ']')) + <*> char ']' + <|> do + x <- anyChar + return . pack $ if x `elem` (".()^$" :: String) + then ['\\', x] + else [x] + +-- | Find file entries in a directory tree, recursively, applying the given +-- recursion predicate to the search. This conduit yields pairs of type +-- @(FileEntry f, a)@, where is the return value from the predicate at each +-- step. +sourceFindFiles :: (MonadIO m, MonadSafe m, IsFilePath f) + => FindOptions + -> f + -> CondT (FileEntry f) m a + -> Producer (FileEntry f, a) m () +sourceFindFiles findOptions startPath = + walkChildren (newFileEntry (getRawFilePath startPath) 0 findOptions) +{-# INLINE sourceFindFiles #-} + +walkChildren :: MonadSafe m + => FileEntry f + -> CondT (FileEntry f) m a + -> Producer (FileEntry f, a) m () +walkChildren !entry !cond = do + let !path = B.snoc (entryPath entry) sep + !opts = entryFindOptions entry + !nextDepth = succ (entryDepth entry) + !worker = uncurry $ handleEntry opts path nextDepth cond + if findPreloadDirectories opts + then do + !fps <- liftIO $ getDirectoryContentsAndAttrs path + forM_ fps $ {-mapInput-} undefined (const Nothing) . worker + else + for (sourceDirectory path) worker + +handleEntry :: MonadSafe m + => FindOptions + -> RawFilePath + -> Int + -> CondT (FileEntry f) m a + -> RawFilePath + -> CUInt + -> Producer (FileEntry f, a) m () +handleEntry opts path nextDepth cond !fp !typ = do + let childPath = B.append path fp + child = newFileEntry childPath nextDepth opts + + ((!mres, !mcond), !child') <- lift $ runCondT child cond + + let opts' = entryFindOptions child' + this = case mres of + Nothing -> return () + Just res + | findIgnoreResults opts' -> return () + | otherwise -> yield (child', res) + that = case mcond of + Nothing -> return () + Just !cond' + | typ == 10 -> + when (findFollowSymlinks opts) $ do + isDir <- liftIO $ statIsDirectory childPath + when isDir $ walkChildren child' cond' + | typ == 4 -> walkChildren child' cond' + | otherwise -> return () + + if findContentsFirst opts' + then that >> this + else this >> that +{-# INLINE handleEntry #-} + +-- | Find file entries in a directory tree, recursively, applying the given +-- recursion predicate to the search. This conduit yields pairs of type +-- @(FileEntry f, a)@, where is the return value from the predicate at each +-- step. +findFilesIO :: IsFilePath f + => FindOptions -> f -> CondT (FileEntry f) IO a -> IO () +findFilesIO findOptions startPath = + walkChildrenIO (newFileEntry (getRawFilePath startPath) 0 findOptions) + +sep :: Word8 +sep = fromIntegral (ord '/') + +walkChildrenIO :: FileEntry f -> CondT (FileEntry f) IO a -> IO () +walkChildrenIO !entry !cond = do + let !path = B.snoc (entryPath entry) sep + !opts = entryFindOptions entry + !nextDepth = entryDepth entry + 1 + !fps <- getDirectoryContentsAndAttrs path + if findDepthFirst opts + then do + let f _ Nothing = return () + f _ (Just x) = uncurry walkChildrenIO x + forM_ fps $ handleEntryIO opts path cond nextDepth (f ()) + else do + let f acc Nothing = return acc + f acc (Just x) = return (x:acc) + dirs <- (\k -> foldM k [] fps) $ \acc -> + handleEntryIO opts path cond nextDepth (f acc) + forM_ dirs $ uncurry walkChildrenIO + +handleEntryIO :: FindOptions + -> RawFilePath + -> CondT (FileEntry f) IO a + -> Int + -> (Maybe (FileEntry f, CondT (FileEntry f) IO a) -> IO b) + -> (RawFilePath, CUInt) + -> IO b +handleEntryIO opts path cond nextDepth f (!fp, !typ) = do + let !childPath = B.append path fp + !child = newFileEntry childPath nextDepth opts + ((_, !mcond), !child') <- runCondT child cond + case mcond of + Nothing -> f Nothing + Just !cond' + | typ == 10 -> + if findFollowSymlinks opts + then do + isDir <- liftIO $ statIsDirectory childPath + f $ if isDir + then Just (child', cond') + else Nothing + else f Nothing + | typ == 4 -> f (Just (child', cond')) + | otherwise -> f Nothing +{-# INLINE handleEntryIO #-} + +-- | Return all files within a directory tree, hierarchically. +directoryFiles :: MonadIO m => FilePath -> TreeT m FilePath +directoryFiles path = CofreeT $ Select $ do + eres <- liftIO $ E.try $ getDirectoryContents path + case eres of + Left (_ :: IOException) -> return () + -- liftIO $ putStrLn $ + -- "Error reading directory " ++ path ++ ": " ++ show e + Right entries -> forM_ entries $ \entry -> + unless (entry `elem` [".", ".."]) $ do + let fullPath = path ++ "/" ++ entry + estat <- liftIO $ E.try $ getFileStatus fullPath + case estat of + Left (_ :: IOException) -> return () + Right st -> + yield (fullPath :< if isDirectory st + then Just (directoryFiles fullPath) + else Nothing) + +genericFindFiles + :: (MonadIO m, MonadBaseControl IO m, + MonadThrow m, MonadCatch m, MonadMask m, IsFilePath f) + => FindOptions + -> f + -> CondT (FileEntry f) m a + -> m () +genericFindFiles opts path predicate = + runSafeT $ runEffect $ + sourceFindFiles opts { findIgnoreResults = True } path + (hoist lift predicate) >-> P.drain +{-# INLINE genericFindFiles #-} + +-- | A simpler version of 'findFiles', which yields only 'FilePath' values, +-- and ignores any values returned by the predicate action. +genericFindFilePaths + :: (MonadIO m, MonadSafe m, IsFilePath f) + => FindOptions + -> f + -> CondT (FileEntry f) m a + -> Producer f m () +genericFindFilePaths opts path predicate = + sourceFindFiles opts path predicate + >-> P.map (fromRawFilePath . entryPath . fst) +{-# INLINE genericFindFilePaths #-} + +-- | Calls 'findFilePaths' with the default set of finding options. +-- Equivalent to @findFilePaths defaultFindOptions@. +genericFind :: (MonadIO m, MonadSafe m, IsFilePath f) + => f -> CondT (FileEntry f) m a -> Producer f m () +genericFind = genericFindFilePaths defaultFindOptions +{-# INLINE genericFind #-} + +-- | Test a file path using the same type of predicate that is accepted by +-- 'findFiles'. +genericTest :: (MonadIO m, IsFilePath f) + => CondT (FileEntry f) m () -> f -> m Bool +genericTest matcher path = + Cond.test + (newFileEntry (getRawFilePath path) 0 defaultFindOptions + { findFollowSymlinks = True }) + matcher + +-- | Test a file path using the same type of predicate that is accepted by +-- 'findFiles', but do not follow symlinks. +genericLtest :: (MonadIO m, IsFilePath f) + => CondT (FileEntry f) m () -> f -> m Bool +genericLtest matcher path = + Cond.test + (newFileEntry (getRawFilePath path) 0 defaultFindOptions) + matcher +{-# INLINE genericLtest #-} + +findFiles :: (MonadIO m, MonadBaseControl IO m, + MonadThrow m, MonadCatch m, MonadMask m) + => FindOptions + -> FilePath + -> CondT (FileEntry FilePath) m a + -> m () +findFiles = genericFindFiles +{-# INLINE findFiles #-} + +-- | A simpler version of 'findFiles', which yields only 'FilePath' values, +-- and ignores any values returned by the predicate action. +findFilePaths :: (MonadIO m, MonadSafe m) + => FindOptions + -> FilePath + -> CondT (FileEntry FilePath) m a + -> Producer FilePath m () +findFilePaths = genericFindFilePaths +{-# INLINE findFilePaths #-} + +-- | Calls 'findFilePaths' with the default set of finding options. +-- Equivalent to @findFilePaths defaultFindOptions@. +find :: (MonadIO m, MonadSafe m) + => FilePath -> CondT (FileEntry FilePath) m a -> Producer FilePath m () +find = genericFind +{-# INLINE find #-} + +-- | Test a file path using the same type of predicate that is accepted by +-- 'findFiles'. +test :: MonadIO m => CondT (FileEntry FilePath) m () -> FilePath -> m Bool +test = genericTest + +-- | Test a file path using the same type of predicate that is accepted by +-- 'findFiles', but do not follow symlinks. +ltest :: MonadIO m => CondT (FileEntry FilePath) m () -> FilePath -> m Bool +ltest = genericLtest diff --git a/Pipes/Files/Directory.hs b/Pipes/Files/Directory.hs new file mode 100644 --- /dev/null +++ b/Pipes/Files/Directory.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE RankNTypes #-} + +module Pipes.Files.Directory where + +import Control.Applicative +import Control.Exception (IOException) +import qualified Control.Exception as E +import Control.Monad +import qualified Data.ByteString as B +import Data.Maybe (fromMaybe) +import Foreign +import Foreign.C +import Pipes +import Pipes.Files.Types +import Pipes.Safe +import Prelude hiding (FilePath) +import System.Posix.ByteString.FilePath +import System.Posix.Files.ByteString + +type CDir = () +type CDirent = () +type DirStream = Ptr CDir + +-- | @openDirStream dir@ calls @opendir@ to obtain a directory stream for +-- @dir@. +openDirStream :: RawFilePath -> IO DirStream +openDirStream name = withFilePath name $ \s -> + throwErrnoPathIfNullRetry "openDirStream" name $ c_opendir s +{-# INLINE openDirStream #-} + +foreign import ccall unsafe "__hsunix_opendir" + c_opendir :: CString -> IO (Ptr CDir) + +getDirectoryContentsAndAttrs :: RawFilePath -> IO [(RawFilePath, CUInt)] +getDirectoryContentsAndAttrs path = do + resetErrno + E.bracket + (openDirStream path) + closeDirStream + (allocaBytes (fromIntegral c_sizeof_dirent) . readDir []) + where + readDir !acc ds direntp = do + res <- readDirStream ds direntp + case fst res of + "" -> return acc + "." -> readDir acc ds direntp + ".." -> readDir acc ds direntp + _ -> readDir (res:acc) ds direntp +{-# INLINE getDirectoryContentsAndAttrs #-} + +sourceDirectory :: MonadSafe m + => RawFilePath -> Producer (RawFilePath, CUInt) m () +sourceDirectory dir = + bracket (liftIO $ openDirStream dir) (liftIO . closeDirStream) go + where + go ds = loop + where + loop = do + res <- liftIO $ readDirStream ds nullPtr + case fst res of + "" -> return () + "." -> loop + ".." -> loop + _ -> yield res >> loop +{-# INLINE sourceDirectory #-} + +-- | @readDirStream dp@ calls @readdir@ to obtain the next directory entry +-- (@struct dirent@) for the open directory stream @dp@, and returns the +-- @d_name@ member of that structure. +readDirStream :: DirStream -> Ptr CDirent -> IO (RawFilePath, CUInt) +readDirStream dirp direntp = alloca loop + where + noresult = (B.empty, 0) + + loop ptr_dEnt = do + r <- c_readdir_r dirp direntp ptr_dEnt + if r == 0 + then do + dEnt <- peek ptr_dEnt + if dEnt == nullPtr + then return noresult + else readEntry dEnt + else do + errno <- getErrno + if errno == eINTR + then loop ptr_dEnt + else do + let Errno eo = errno + if eo == 0 + then return noresult + else throwErrno "readDirStream" + + readEntry dEnt = do + !len <- fromIntegral <$> d_namlen dEnt + !entry <- d_name dEnt >>= \p -> peekFilePathLen (p, len) + + -- We can sometimes use "leaf optimization" on Linux to answer this + -- question without performing a stat call. This is possible because + -- the link count of a directory is two more than the number of + -- sub-directories it contains, so we've seen that many + -- sub-directories, the remaining entries must be files. + !typ <- d_type dEnt + return (entry, typ) + +statIsDirectory :: RawFilePath -> IO Bool +statIsDirectory path = + maybe False isDirectory <$> statFilePath True True path + +statFilePath :: Bool -> Bool -> RawFilePath -> IO (Maybe FileStatus) +statFilePath follow ignoreErrors path = do + let doStat = (if follow + then getFileStatus + else getSymbolicLinkStatus) path + catch (Just <$> doStat) $ \e -> + if ignoreErrors + then return Nothing + else throwM (e :: IOException) + +-- | Get the current status for the file. If the status being requested is +-- already cached in the entry information, simply return it from there. +getStat :: Maybe Bool -> FileEntry f -> IO (Maybe (FileStatus, FileEntry f)) +getStat mfollow entry = case entryStatus entry of + Just s + | maybe True (== follow entry) mfollow -> + return $ Just (s, entry) + | otherwise -> fmap (, entry) `liftM` wrapStat + Nothing -> do + ms <- wrapStat + return $ case ms of + Just s -> Just (s, entry { entryStatus = Just s }) + Nothing -> Nothing + where + follow = findFollowSymlinks . entryFindOptions + + wrapStat = statFilePath + (fromMaybe (findFollowSymlinks opts) mfollow) + (findIgnoreErrors opts) + (entryPath entry) + where + opts = entryFindOptions entry + +-- traversing directories +foreign import ccall unsafe "__hscore_readdir" + c_readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt + +foreign import ccall unsafe "__hscore_free_dirent" + c_freeDirEnt :: Ptr CDirent -> IO () + +foreign import ccall unsafe "__hscore_readdir_r" + c_readdir_r :: Ptr CDir -> Ptr CDirent -> Ptr (Ptr CDirent) -> IO CInt + +foreign import ccall unsafe "__hscore_sizeof_dirent" + c_sizeof_dirent :: CUInt + +foreign import ccall unsafe "__hscore_d_name" + d_name :: Ptr CDirent -> IO CString + +foreign import ccall unsafe "__hscore_d_namlen" + d_namlen :: Ptr CDirent -> IO CUInt + +foreign import ccall unsafe "__hscore_d_type" + d_type :: Ptr CDirent -> IO CUInt + +-- | @closeDirStream dp@ calls @closedir@ to close the directory stream @dp@. +closeDirStream :: DirStream -> IO () +closeDirStream dirp = + throwErrnoIfMinus1Retry_ "closeDirStream" (c_closedir dirp) + +foreign import ccall unsafe "closedir" + c_closedir :: Ptr CDir -> IO CInt diff --git a/Pipes/Files/Types.hs b/Pipes/Files/Types.hs new file mode 100644 --- /dev/null +++ b/Pipes/Files/Types.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE TypeFamilies #-} + +module Pipes.Files.Types where + +import Data.ByteString (ByteString) +import Data.Text +import Data.Text.Encoding +import Foreign +import Prelude hiding (FilePath) +import System.FilePath as FP +import System.Posix.ByteString.FilePath +import System.PosixCompat.Files + +data FindOptions = FindOptions + { findFollowSymlinks :: !Bool + , findContentsFirst :: !Bool + , findIgnoreErrors :: !Bool + , findIgnoreResults :: !Bool + , findPreloadDirectories :: !Bool + , findDepthFirst :: !Bool + } + +defaultFindOptions :: FindOptions +defaultFindOptions = FindOptions + { findFollowSymlinks = False + , findContentsFirst = False + , findIgnoreErrors = False + , findIgnoreResults = False + , findPreloadDirectories = False + , findDepthFirst = True + } + +data FileEntry f = FileEntry + { entryPath :: !RawFilePath + , entryDepth :: !Int + , entryFindOptions :: !FindOptions + , entryStatus :: !(Maybe FileStatus) + -- ^ This is Nothing until we determine stat should be called. + } + +newFileEntry :: RawFilePath -> Int -> FindOptions -> FileEntry f +newFileEntry fp d f = FileEntry fp d f Nothing + +instance Show (FileEntry f) where + show entry = "FileEntry " + ++ show (entryPath entry) ++ " " ++ show (entryDepth entry) + +class IsFilePath a where + getRawFilePath :: a -> RawFilePath + getFilePath :: a -> FilePath + + fromRawFilePath :: RawFilePath -> a + fromFilePath :: FilePath -> a + fromTextPath :: Text -> a + +instance IsFilePath ByteString where + getRawFilePath = id + getFilePath = unpack . decodeUtf8 + + fromRawFilePath = id + fromFilePath = getRawFilePath + fromTextPath = encodeUtf8 + +instance a ~ Char => IsFilePath [a] where + getRawFilePath = encodeUtf8 . pack + getFilePath = id + + fromRawFilePath = getFilePath + fromFilePath = id + fromTextPath = unpack diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/pipes-files.cabal b/pipes-files.cabal new file mode 100644 --- /dev/null +++ b/pipes-files.cabal @@ -0,0 +1,112 @@ +name: pipes-files +version: 0.1.0 +synopsis: Fast traversal of directory trees using pipes +description: Fast traversal of directory trees using pipes +homepage: https://github.com/jwiegley/pipes-files +license: BSD3 +license-file: LICENSE +author: John Wiegley +maintainer: johnw@newartisans.com +copyright: Copyright 2015 (c) John Wiegley. All Rights Reserved. +category: Data +build-type: Simple +cabal-version: >=1.10 + +Source-repository head + type: git + location: git://github.com/jwiegley/pipes-files.git + +Flag leafopt + Description: Enable leaf optimization + Default: True + +library + ghc-options: -Wall -O2 -funbox-strict-fields + include-dirs: . + c-sources: Helper.c + if os(linux) + cpp-options: -DHAVE_READDIR_R=1 + if os(linux) && flag(leafopt) + cpp-options: -DLEAFOPT=1 + if os(darwin) + cpp-options: -DHAVE_READDIR_R=1 + exposed-modules: + Pipes.Files + , Pipes.Files.Directory + , Pipes.Files.Types + build-depends: + base >=4.7 && <4.9 + , transformers >=0.3 && <0.5 + , transformers-base >=0.3 && <0.5 + , transformers-compat >=0.3 && <0.5 + , exceptions >=0.8 && <0.9 + , mmorph >=1.0 && <1.1 + , mtl >=2.1 && <2.3 + , monad-control >=1.0 && <1.1 + , semigroups >=0.16 && <0.17 + , free >=4.12 && <4.13 + , pipes >=4.1 && <4.2 + , directory >=1.2 && <1.3 + , unix >=2.7 && <2.8 + , hierarchy >=0.2.1 + , regex-posix + , unix-compat + , attoparsec + , bytestring + , text + , time + , filepath + , posix-paths + , pipes-safe + -- hs-source-dirs: + default-language: Haskell2010 + +Test-suite doctests + default-language: Haskell98 + type: exitcode-stdio-1.0 + main-is: doctest.hs + hs-source-dirs: test + build-depends: + base + , directory >=1.0 + , doctest >=0.8 + , filepath >=1.3 + , semigroups >=0.4 + +test-suite test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + ghc-options: -Wall -fno-warn-deprecated-flags -threaded + hs-source-dirs: test + main-is: Main.hs + build-depends: + base >=3 + , hierarchy + , pipes-files + , pipes >=4.1 && <4.2 + , directory >=1.2 && <1.3 + , unix >=2.7 && <2.8 + , transformers >=0.3 && <0.5 + , mtl >=2.1 && <2.3 + , hspec >=1.4.4 + , hspec-expectations >=0.3 + +test-suite find-hs + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: find-hs.hs + ghc-options: -threaded -O2 + hs-source-dirs: test + build-depends: + base + , transformers >=0.3 && <0.5 + , text >= 0.11.3.1 + , unix >= 0.4.1.1 + , pipes >=4.1 && <4.2 + , hspec >=1.4.4 + , hspec-expectations >=0.3 + , pipes-safe + , pipes-files + , bytestring + , process + , mtl diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,48 @@ +module Main where + +import Control.Cond +import Control.Monad +import Data.List +import Pipes +import Pipes.Files +import Pipes.Prelude (toListM) +import Pipes.Tree +import Test.Hspec + +main :: IO () +main = hspec $ do + describe "Sanity tests" $ do + it "Finds expected files in project" findsExpected + +findsExpected :: Expectation +findsExpected = do + let ignored = ["./.git", "./dist", "./result"] + + let files = winnow (directoryFiles ".") $ do + path <- query + liftIO $ putStrLn $ "Considering " ++ path + when_ (guard_ (`elem` ignored)) $ do + liftIO $ putStrLn $ "Pruning " ++ path + prune + -- equivalently we can say (but won't reach here now)... + when (path `elem` ignored) $ do + liftIO $ putStrLn $ "Pruning " ++ path + prune + + guard_ (".hs" `isInfixOf`) + + -- We only reach the end if we have a file of interest, + -- however any directories we didn't prune will still be + -- descended into + liftIO $ putStrLn "We found a Haskell file!" + + let expected = [ "./Pipes/Files.hs" + , "./Pipes/Files/Directory.hs" + , "./Pipes/Files/Types.hs" + , "./Setup.hs" + , "./test/Main.hs" + , "./test/doctest.hs" + , "./test/find-hs.hs" + ] + found <- toListM $ enumerate (walk files) + sort found `shouldBe` expected diff --git a/test/doctest.hs b/test/doctest.hs new file mode 100644 --- /dev/null +++ b/test/doctest.hs @@ -0,0 +1,30 @@ +module Main where + +import Test.DocTest +import System.Directory +import System.FilePath +import Control.Applicative +import Control.Monad +import Data.List + +main :: IO () +main = getSources >>= \sources -> doctest $ + "-iPipes" + : "-idist/build/autogen" + : "-optP-include" + : "-optPdist/build/autogen/cabal_macros.h" + : sources + +getSources :: IO [FilePath] +getSources = + filter (\n -> ".hs" `isSuffixOf` n) <$> go "./Pipes" + where + go dir = do + (dirs, files) <- getFilesAndDirectories dir + (files ++) . concat <$> mapM go dirs + +getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) +getFilesAndDirectories dir = do + c <- map (dir ) . filter (`notElem` ["..", "."]) + <$> getDirectoryContents dir + (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c diff --git a/test/find-hs.hs b/test/find-hs.hs new file mode 100644 --- /dev/null +++ b/test/find-hs.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Main where + +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Writer +import Data.ByteString +import qualified Data.ByteString.Char8 as B +import Data.IORef +import qualified Data.List as L +import qualified Data.Text as T +import Data.Text.Encoding +import Pipes +import Pipes.Files +import qualified Pipes.Prelude as P +import Pipes.Safe +import qualified Prelude +import Prelude hiding (putStrLn) +import System.Environment +import System.Posix.ByteString.FilePath +import System.Posix.Process +import System.Process +import Test.Hspec +import Test.Hspec.Expectations + +main :: IO () +main = do + args <- getArgs + case args of + [] -> compareVersions + ["hierarchy", dir] -> hierarchy dir Nothing + ["hierarchy-preload", dir] -> hierarchyPreload dir Nothing + ["hierarchy-io", dir] -> hierarchyIO dir Nothing + -- ["hierarchy-gather", dir] -> hierarchyGather dir Nothing + ["hierarchy-source", dir] -> hierarchySource dir Nothing + ["find", dir] -> gnuFind dir Nothing + _ -> error "Invalid arguments" + +gatherFiles :: (Maybe (IORef [RawFilePath]) -> IO ()) -> IO [FilePath] +gatherFiles f = do + files <- newIORef [] + f (Just files) + L.sort . Prelude.map (T.unpack . decodeUtf8) <$> readIORef files + +compareVersions = hspec $ describe "Comparison tests" $ do + it "Running findFiles from hierarchy" $ do + expected <- gatherFiles $ hierarchy "." + found <- gatherFiles $ hierarchy "." + found `shouldBe` expected + -- it "Running findFiles from hierarchy with preload" $ do + -- expected <- gatherFiles $ hierarchy "." + -- found <- gatherFiles $ hierarchyPreload "." + -- found `shouldBe` expected + it "Running findFilesIO from hierarchy" $ do + expected <- gatherFiles $ hierarchy "." + found <- gatherFiles $ hierarchyIO "." + found `shouldBe` expected + -- it "Running parFindFiles from hierarchy" $ do + -- expected <- gatherFiles $ hierarchy "." + -- found <- gatherFiles $ hierarchyGather "." + -- found `shouldBe` expected + it "Running findFilesSource from hierarchy" $ do + expected <- gatherFiles $ hierarchy "." + found <- gatherFiles $ hierarchySource "." + found `shouldBe` expected + it "Running GNU find" $ do + expected <- gatherFiles $ hierarchy "." + found <- gatherFiles $ gnuFind "." + found `shouldBe` expected + +hierarchy dir files = do + findFiles defaultFindOptions dir $ do + path <- getRawEntryPath + guard (".hs" `isSuffixOf` path) + liftIO $ maybe (B.putStrLn path) (flip modifyIORef' (path :)) files + +hierarchyPreload dir files = do + findFiles defaultFindOptions + { findPreloadDirectories = True + } + dir $ do + path <- getRawEntryPath + guard (".hs" `isSuffixOf` path) + liftIO $ maybe (B.putStrLn path) (flip modifyIORef' (path :)) files + +hierarchyIO dir files = do + findFilesIO defaultFindOptions (encodeUtf8 (T.pack dir)) $ do + path <- getRawEntryPath + guard (".hs" `isSuffixOf` path) + liftIO $ maybe (B.putStrLn path) (flip modifyIORef' (path :)) files + +-- hierarchyGather dir files = do +-- gatherFrom 128 (\queue -> +-- findFilesIO defaultFindOptions +-- (encodeUtf8 (T.pack dir)) $ do +-- path <- asks entryPath +-- guard (".hs" `isSuffixOf` path) +-- norecurse +-- liftIO $ atomically $ writeTBQueue queue path) +-- $$ mapM_C (liftIO . putStrLn) + +hierarchySource dir files = do + runSafeT $ runEffect $ + for (sourceFindFiles defaultFindOptions + (encodeUtf8 (T.pack dir)) (return ()) + >-> P.filter ((".hs" `isSuffixOf`) . entryPath . fst)) $ \p -> do + let path = entryPath (fst p) + liftIO $ maybe (B.putStrLn path) (flip modifyIORef' (path :)) files + +gnuFind dir files = do + output <- readProcess "find" [dir, "-name", "*.hs", "-print"] "" + case files of + Nothing -> Prelude.putStrLn output + Just ref -> writeIORef ref (L.map (encodeUtf8 . T.pack) (lines output))