packages feed

pipes-files (empty) → 0.1.0

raw patch · 10 files changed

+1276/−0 lines, 10 filesdep +attoparsecdep +basedep +bytestringsetup-changed

Dependencies added: attoparsec, base, bytestring, directory, doctest, exceptions, filepath, free, hierarchy, hspec, hspec-expectations, mmorph, monad-control, mtl, pipes, pipes-files, pipes-safe, posix-paths, process, regex-posix, semigroups, text, time, transformers, transformers-base, transformers-compat, unix, unix-compat

Files

+ Helper.c view
@@ -0,0 +1,44 @@+#include <dirent.h>+#include <unistd.h>+#include <limits.h>++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);+}
+ LICENSE view
@@ -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.
+ Pipes/Files.hs view
@@ -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
+ Pipes/Files/Directory.hs view
@@ -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
+ Pipes/Files/Types.hs view
@@ -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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ pipes-files.cabal view
@@ -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
+ test/Main.hs view
@@ -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
+ test/doctest.hs view
@@ -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
+ test/find-hs.hs view
@@ -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))