diff --git a/Data/Cond.hs b/Data/Cond.hs --- a/Data/Cond.hs +++ b/Data/Cond.hs @@ -4,6 +4,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} module Data.Cond ( CondT(..), Cond @@ -244,6 +245,10 @@ instance MonadCatch m => MonadCatch (CondT a m) where catch (CondT m) c = CondT $ m `catch` \e -> getCondT (c e) +#if MIN_VERSION_exceptions(0,6,0) + +instance MonadMask m => MonadMask (CondT a m) where +#endif mask a = CondT $ mask $ \u -> getCondT (a $ q u) where q u = CondT . u . getCondT uninterruptibleMask a = @@ -262,7 +267,17 @@ lift m = CondT $ liftM accept' $ lift m {-# INLINE lift #-} +#if MIN_VERSION_monad_control(1,0,0) instance MonadBaseControl b m => MonadBaseControl b (CondT r m) where + type StM (CondT r m) a = StM m (Result r m a, r) + liftBaseWith f = CondT $ StateT $ \s -> + liftM (\x -> (accept' x, s)) $ liftBaseWith $ \runInBase -> f $ \k -> + runInBase $ runStateT (getCondT k) s + restoreM = CondT . StateT . const . restoreM + {-# INLINE liftBaseWith #-} + {-# INLINE restoreM #-} +#else +instance MonadBaseControl b m => MonadBaseControl b (CondT r m) where newtype StM (CondT r m) a = CondTStM { unCondTStM :: StM m (Result r m a, r) } liftBaseWith f = CondT $ StateT $ \s -> @@ -271,6 +286,7 @@ restoreM = CondT . StateT . const . restoreM . unCondTStM {-# INLINE liftBaseWith #-} {-# INLINE restoreM #-} +#endif instance MFunctor (CondT a) where hoist nat (CondT m) = CondT $ hoist nat (liftM (hoist nat) m) diff --git a/Data/Conduit/Find.hs b/Data/Conduit/Find.hs --- a/Data/Conduit/Find.hs +++ b/Data/Conduit/Find.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} module Data.Conduit.Find ( @@ -18,10 +21,12 @@ -- $notes -- * Finding functions - find - , findFilesSource + sourceFindFiles + , find , findFiles , findFilePaths + , FindOptions(..) + , defaultFindOptions , test , ltest , stat @@ -35,10 +40,13 @@ -- * GNU find compatibility predicates , depth_ + , follow_ + , noleaf_ + , prune_ , maxdepth_ , mindepth_ - , ignoreReaddirRace_ - , noIgnoreReaddirRace_ + , ignoreErrors_ + , noIgnoreErrors_ , amin_ , atime_ , anewer_ @@ -48,12 +56,8 @@ , name_ , getDepth , filename_ - , filenameS_ , pathname_ - , pathnameS_ , getFilePath - , follow_ - , prune_ -- * File entry predicates (uses stat information) , regular @@ -74,24 +78,29 @@ import Conduit import Control.Applicative import Control.Exception -import Control.Monad hiding (forM_) +import Control.Monad hiding (forM_, forM) import Control.Monad.Morph import Control.Monad.State.Class import Data.Attoparsec.Text as A import Data.Bits import qualified Data.Cond as Cond import Data.Cond hiding (test) -import Data.Foldable hiding (elem, find) -import Data.Maybe (fromMaybe) +import qualified Data.Conduit.Filesystem as CF +#if LEAFOPT +import Data.IORef +#endif +import Data.Maybe (fromMaybe,fromJust) import Data.Monoid import Data.Text (Text, unpack, pack) import Data.Time import Data.Time.Clock.POSIX -import Filesystem.Path.CurrentOS (FilePath, encodeString, filename) +import Filesystem.Path.CurrentOS (FilePath, + encodeString, decodeString) import Prelude hiding (FilePath) -import System.Posix.Files -import System.Posix.Types -import qualified Text.Regex.Posix as R ((=~)) +import qualified System.FilePath as FP +import System.PosixCompat.Files +import System.PosixCompat.Types +import Text.Regex.Posix ((=~)) {- $intro @@ -189,50 +198,46 @@ -} data FindOptions = FindOptions - { findFollowSymlinks :: Bool - , findContentsFirst :: Bool - , findIgnoreReaddirRace :: Bool - , findIgnoreResults :: Bool + { findFollowSymlinks :: !Bool + , findContentsFirst :: !Bool + , findIgnoreErrors :: !Bool + , findIgnoreResults :: !Bool + , findLeafOptimization :: !Bool } defaultFindOptions :: FindOptions defaultFindOptions = FindOptions - { findFollowSymlinks = True - , findContentsFirst = False - , findIgnoreReaddirRace = False - , findIgnoreResults = False + { findFollowSymlinks = True + , findContentsFirst = False + , findIgnoreErrors = False + , findIgnoreResults = False + , findLeafOptimization = True } data FileEntry = FileEntry - { entryPath :: !FilePath + { entryPath :: !FP.FilePath , entryDepth :: !Int - , entryFindOptions :: !(FindOptions) + , entryFindOptions :: !FindOptions , entryStatus :: !(Maybe FileStatus) -- ^ This is Nothing until we determine stat should be called. } -newFileEntry :: FilePath -> Int -> FindOptions -> FileEntry -newFileEntry p d f = FileEntry p d f Nothing +newFileEntry :: FP.FilePath -> Int -> FindOptions -> FileEntry +newFileEntry fp d f = FileEntry fp d f Nothing instance Show FileEntry where show entry = "FileEntry " ++ show (entryPath entry) ++ " " ++ show (entryDepth entry) -getFilePath :: Monad m => CondT FileEntry m FilePath +getFilePath :: Monad m => CondT FileEntry m FP.FilePath getFilePath = gets entryPath -pathname_ :: Monad m => (FilePath -> Bool) -> CondT FileEntry m () +pathname_ :: Monad m => (FP.FilePath -> Bool) -> CondT FileEntry m () pathname_ f = guard . f =<< getFilePath -pathnameS_ :: Monad m => (String -> Bool) -> CondT FileEntry m () -pathnameS_ f = pathname_ (f . encodeString) - -filename_ :: Monad m => (FilePath -> Bool) -> CondT FileEntry m () -filename_ f = pathname_ (f . filename) - -filenameS_ :: Monad m => (String -> Bool) -> CondT FileEntry m () -filenameS_ f = pathname_ (f . encodeString . filename) +filename_ :: Monad m => (FP.FilePath -> Bool) -> CondT FileEntry m () +filename_ f = pathname_ (f . FP.takeFileName) getDepth :: Monad m => CondT FileEntry m Int getDepth = gets entryDepth @@ -253,23 +258,26 @@ follow_ :: Monad m => CondT FileEntry m () follow_ = modifyFindOptions $ \opts -> opts { findFollowSymlinks = True } -ignoreReaddirRace_ :: Monad m => CondT FileEntry m () -ignoreReaddirRace_ = - modifyFindOptions $ \opts -> opts { findIgnoreReaddirRace = True } +noleaf_ :: Monad m => CondT FileEntry m () +noleaf_ = modifyFindOptions $ \opts -> opts { findLeafOptimization = False } -noIgnoreReaddirRace_ :: Monad m => CondT FileEntry m () -noIgnoreReaddirRace_ = - modifyFindOptions $ \opts -> opts { findIgnoreReaddirRace = False } +prune_ :: Monad m => CondT a m () +prune_ = prune +ignoreErrors_ :: Monad m => CondT FileEntry m () +ignoreErrors_ = + modifyFindOptions $ \opts -> opts { findIgnoreErrors = True } + +noIgnoreErrors_ :: Monad m => CondT FileEntry m () +noIgnoreErrors_ = + modifyFindOptions $ \opts -> opts { findIgnoreErrors = False } + maxdepth_ :: Monad m => Int -> CondT FileEntry m () maxdepth_ l = getDepth >>= guard . (<= l) mindepth_ :: Monad m => Int -> CondT FileEntry m () mindepth_ l = getDepth >>= guard . (>= l) -prune_ :: Monad m => CondT a m () -prune_ = prune - -- xdev_ = error "NYI" timeComp :: MonadIO m @@ -285,7 +293,7 @@ atime_ :: MonadIO m => Int -> CondT FileEntry m () atime_ n = timeComp lastAccessed_ (n * 24 * 3600) -anewer_ :: MonadIO m => FilePath -> CondT FileEntry m () +anewer_ :: MonadIO m => FP.FilePath -> CondT FileEntry m () anewer_ path = do e <- get es <- applyStat Nothing @@ -296,7 +304,7 @@ Nothing -> prune >> error "This is never reached" Just (s, _) -> guard $ diffUTCTime (f s) (f es) > 0 where - f = posixSecondsToUTCTime . accessTimeHiRes + f = posixSecondsToUTCTime . realToFrac . accessTime -- cmin_ = error "NYI" -- cnewer_ = error "NYI" @@ -326,7 +334,7 @@ mtime_ -} -name_ :: Monad m => FilePath -> CondT FileEntry m () +name_ :: Monad m => FP.FilePath -> CondT FileEntry m () name_ = filename_ . (==) {- @@ -351,6 +359,16 @@ ------------------------------------------------------------------------ +statFilePath :: Bool -> Bool -> FP.FilePath -> 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 throwIO (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 :: MonadIO m @@ -364,25 +382,21 @@ | otherwise -> fmap (, entry) `liftM` wrapStat Nothing -> do ms <- wrapStat - case ms of - Just s -> return $ Just (s, entry { entryStatus = Just s }) - Nothing -> return Nothing + return $ case ms of + Just s -> Just (s, entry { entryStatus = Just s }) + Nothing -> Nothing where - follow = findFollowSymlinks . entryFindOptions - doStat = (if fromMaybe (follow entry) mfollow - then getFileStatus - else getSymbolicLinkStatus) $ encodeString (entryPath entry) - wrapStat = liftIO $ catch (Just <$> doStat) $ \e -> - if findIgnoreReaddirRace opts - then return Nothing - else throwIO (e :: IOException) + follow = findFollowSymlinks . entryFindOptions + wrapStat = liftIO $ statFilePath + (fromMaybe (findFollowSymlinks opts) mfollow) + (findIgnoreErrors opts) + (entryPath entry) where opts = entryFindOptions entry applyStat :: MonadIO m => Maybe Bool -> CondT FileEntry m FileStatus applyStat mfollow = do - e <- get - ms <- lift (getStat mfollow e) + ms <- lift . getStat mfollow =<< get case ms of Nothing -> prune >> error "This is never reached" Just (s, e') -> s <$ put e' @@ -409,32 +423,17 @@ hasMode m = hasStatus (\s -> fileMode s .&. m /= 0) withStatusTime :: MonadIO m - => (FileStatus -> POSIXTime) -> (UTCTime -> Bool) + => (FileStatus -> EpochTime) -> (UTCTime -> Bool) -> CondT FileEntry m () -withStatusTime g f = hasStatus (f . posixSecondsToUTCTime . g) +withStatusTime g f = hasStatus (f . posixSecondsToUTCTime . realToFrac . g) lastAccessed_ :: MonadIO m => (UTCTime -> Bool) -> CondT FileEntry m () -lastAccessed_ = withStatusTime accessTimeHiRes +lastAccessed_ = withStatusTime accessTime lastModified_ :: MonadIO m => (UTCTime -> Bool) -> CondT FileEntry m () -lastModified_ = withStatusTime modificationTimeHiRes - --- | This is a re-export of 'Text.Regex.Posix.=~', with the types changed for --- use with this module. For example, you can simply say: --- --- @ --- filename_ (=~ \"\\\\.hs$\") --- @ --- --- Which is the same thing as: --- --- @ --- regex \"\\\\.hs$\" --- @ -(=~) :: FilePath -> Text -> Bool -str =~ pat = encodeString str R.=~ unpack pat +lastModified_ = withStatusTime modificationTime -regex :: Monad m => Text -> CondT FileEntry m () +regex :: Monad m => String -> CondT FileEntry m () regex pat = filename_ (=~ pat) -- | Return all entries, except for those within version-control metadata @@ -446,10 +445,10 @@ -- | Find every entry whose filename part matching the given filename globbing -- expression. For example: @glob "*.hs"@. -glob :: Monad m => Text -> CondT FileEntry m () -glob g = case parseOnly globParser g of +glob :: Monad m => String -> CondT FileEntry m () +glob g = case parseOnly globParser (pack g) of Left e -> error $ "Failed to parse glob: " ++ e - Right x -> regex ("^" <> x <> "$") + Right x -> regex ("^" <> unpack x <> "$") where globParser :: Parser Text globParser = fmap mconcat $ many $ @@ -462,47 +461,115 @@ <*> char ']' <|> do x <- anyChar - return . pack $ if x `elem` ".()^$" + return . pack $ if x `elem` (".()^$" :: String) then ['\\', x] else [x] +#if LEAFOPT +type DirCounter = IORef LinkCount + +newDirCounter :: MonadIO m => m DirCounter +newDirCounter = liftIO $ newIORef 1 +#else +type DirCounter = () + +newDirCounter :: MonadIO m => m DirCounter +newDirCounter = return () +#endif + -- | Find file entries in a directory tree, recursively, applying the given -- recursion predicate to the search. This conduit yields pairs of type -- @(FileEntry, a)@, where is the return value from the predicate at each -- step. -findFilesSource :: (MonadIO m, MonadResource m) +sourceFindFiles :: (MonadIO m, MonadResource m) => FindOptions -> FilePath -> CondT FileEntry m a -> Producer m (FileEntry, a) -findFilesSource opts startPath predicate = - wrap $ go (newFileEntry startPath 0 opts) $ hoist lift predicate +sourceFindFiles findOptions startPath predicate = do + startDc <- newDirCounter + walk startDc + (newFileEntry (encodeString startPath) 0 findOptions) + (encodeString startPath) + predicate where - wrap = mapInput (const ()) (const Nothing) - - go x pr = do - ((mres, mcond), entry) <- applyCondT x pr + walk :: MonadResource m + => DirCounter + -> FileEntry + -> FP.FilePath + -> CondT FileEntry m a + -> Producer m (FileEntry, a) + walk !dc !entry !path !cond = do + ((!mres, !mcond), !entry') <- lift $ applyCondT entry cond let opts' = entryFindOptions entry - this = unless (findIgnoreResults opts') $ yieldEntry entry mres - next = walkChildren entry mcond + this = unless (findIgnoreResults opts') $ + yieldEntry entry' mres + next = walkChildren dc entry' path mcond if findContentsFirst opts' then next >> this else this >> next + where + yieldEntry _ Nothing = return () + yieldEntry entry' (Just res) = yield (entry', res) - yieldEntry entry mres = - -- If the item matched, also yield the predicate's result value. - forM_ mres $ yield . (entry,) + walkChildren :: MonadResource m + => DirCounter + -> FileEntry + -> FP.FilePath + -> Maybe (CondT FileEntry m a) + -> Producer m (FileEntry, a) + walkChildren _ _ _ Nothing = return () + -- If the conditional matched, we are requested to recurse if this is a + -- directory + walkChildren !dc !entry !path (Just !cond) = do + st <- lift $ checkIfDirectory dc entry path + when (fmap isDirectory st == Just True) $ do +#if LEAFOPT + -- Update directory count for the parent directory. + liftIO $ modifyIORef dc pred + -- Track the directory count for this child path. + let leafOpt = findLeafOptimization (entryFindOptions entry) + let lc = linkCount (fromJust st) - 2 + opts' = (entryFindOptions entry) + { findLeafOptimization = leafOpt && lc >= 0 + } + dc' <- liftIO $ newIORef lc +#else + let dc' = dc + opts' = entryFindOptions entry +#endif + CF.sourceDirectory path =$= awaitForever (go dc' opts') + where + go dc' opts' fp = + let entry' = newFileEntry fp (succ (entryDepth entry)) opts' + in walk dc' entry' fp cond - walkChildren entry@(FileEntry path depth opts' _) mcond = - -- If the conditional matched, we are requested to recurse if this - -- is a directory - forM_ mcond $ \cond -> do - -- If no status has been determined, we must do so now in order - -- to know whether to actually recurse or not. - descend <- fmap (isDirectory . fst) <$> getStat Nothing entry - when (descend == Just True) $ - (sourceDirectory path =$) $ awaitForever $ \fp -> - wrap $ go (newFileEntry fp (succ depth) opts') cond + -- Return True if the given entry is a directory. 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. + checkIfDirectory :: MonadResource m + => DirCounter + -> FileEntry + -> FP.FilePath + -> m (Maybe FileStatus) + checkIfDirectory !dc !entry !path = do +#if LEAFOPT + let leafOpt = findLeafOptimization (entryFindOptions entry) + doStat <- if leafOpt + then (> 0) <$> liftIO (readIORef dc) + else return True +#else + let doStat = dc == () -- to quiet hlint warnings +#endif + let opts = entryFindOptions entry + if doStat + then liftIO $ statFilePath + (findFollowSymlinks opts) + (findIgnoreErrors opts) + path + else return Nothing findFiles :: (MonadIO m, MonadBaseControl IO m, MonadThrow m) => FindOptions @@ -510,9 +577,9 @@ -> CondT FileEntry m a -> m () findFiles opts path predicate = - runResourceT $ findFilesSource - opts { findIgnoreResults = True } path (hoist lift predicate) - $$ sinkNull + runResourceT $ + sourceFindFiles opts { findIgnoreResults = True } path + (hoist lift predicate) $$ sinkNull -- | A simpler version of 'findFiles', which yields only 'FilePath' values, -- and ignores any values returned by the predicate action. @@ -522,7 +589,8 @@ -> CondT FileEntry m a -> Producer m FilePath findFilePaths opts path predicate = - findFilesSource opts path predicate =$= mapC (entryPath . fst) + mapOutput decodeString $ + sourceFindFiles opts path predicate =$= mapC (entryPath . fst) -- | Calls 'findFilePaths' with the default set of finding options. -- Equivalent to @findFilePaths defaultFindOptions@. @@ -534,11 +602,13 @@ -- 'findFiles'. test :: MonadIO m => CondT FileEntry m () -> FilePath -> m Bool test matcher path = - Cond.test (newFileEntry path 0 defaultFindOptions) matcher + Cond.test (newFileEntry (encodeString path) 0 defaultFindOptions) matcher -- | 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 m () -> FilePath -> m Bool -ltest matcher path = Cond.test - (newFileEntry path 0 defaultFindOptions { findFollowSymlinks = False }) - matcher +ltest matcher path = + Cond.test + (newFileEntry (encodeString path) 0 defaultFindOptions + { findFollowSymlinks = False }) + matcher diff --git a/find-conduit.cabal b/find-conduit.cabal --- a/find-conduit.cabal +++ b/find-conduit.cabal @@ -1,5 +1,5 @@ Name: find-conduit -Version: 0.4.1 +Version: 0.4.3 Synopsis: A file-finding conduit that allows user control over traversals. License-file: LICENSE License: MIT @@ -16,27 +16,36 @@ type: git location: git://github.com/jwiegley/find-conduit.git +Flag leafopt + Description: Enable leaf optimization + Default: True + Library default-language: Haskell98 - ghc-options: -Wall + ghc-options: -Wall -O2 -funbox-strict-fields + if os(linux) && flag(leafopt) + cpp-options: -DLEAFOPT=1 build-depends: base >= 3 && < 5 , conduit + , conduit-extra , conduit-combinators , attoparsec , system-filepath - , unix >= 2.5.1.1 + , unix-compat >= 0.4.1.1 , text >= 0.11.3.1 , regex-posix , mtl , semigroups , exceptions , time + , streaming-commons , transformers , transformers-base , mmorph , either , monad-control + , filepath exposed-modules: Data.Cond, Data.Conduit.Find @@ -53,18 +62,20 @@ , conduit-combinators , attoparsec , system-filepath - , unix >= 2.5.1.1 + , unix-compat >= 0.4.1.1 , text >= 0.11.3.1 , regex-posix , mtl , time , either , semigroups + , streaming-commons , exceptions , transformers , transformers-base , monad-control , mmorph + , filepath , hspec >= 1.4 Test-suite doctests @@ -73,9 +84,36 @@ Main-is: doctest.hs Hs-source-dirs: test Build-depends: - base - , directory >= 1.0 - , doctest >= 0.8 - , filepath >= 1.3 - , semigroups >= 0.4 + base + , directory >= 1.0 + , doctest >= 0.8 + , filepath >= 1.3 + , semigroups >= 0.4 +Executable find-hs + Main-is: find-hs.hs + default-language: Haskell2010 + Ghc-options: -threaded -O2 + Hs-source-dirs: test + Build-depends: + base + , find-conduit + , conduit + , conduit-extra + , conduit-combinators + , attoparsec + , system-filepath + , unix >= 0.4.1.1 + , text >= 0.11.3.1 + , regex-posix + , mtl + , time + , either + , semigroups + , streaming-commons + , exceptions + , transformers + , transformers-base + , monad-control + , mmorph + , filepath diff --git a/test/doctest.hs b/test/doctest.hs --- a/test/doctest.hs +++ b/test/doctest.hs @@ -11,7 +11,6 @@ main = getSources >>= \sources -> doctest $ "-iData" : "-idist/build/autogen" - : "-package=semigroups-0.13.0.1" : "-optP-include" : "-optPdist/build/autogen/cabal_macros.h" : sources 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,42 @@ +module Main where + +import Conduit +import Control.Monad +import Control.Monad.Reader.Class +import Data.Conduit.Find +import Data.List +import Filesystem.Path.CurrentOS +import System.Environment +import System.Posix.Process + +main :: IO () +main = do + [command, dir] <- getArgs + case command of + "conduit" -> do + putStrLn "Running sourceDirectoryDeep from conduit-extra" + runResourceT $ + sourceDirectoryDeep False (decodeString dir) + =$ filterC ((".hs" `isSuffixOf`) . encodeString) + $$ mapM_C (liftIO . putStrLn . encodeString) + + "find-conduit" -> do + putStrLn "Running findFiles from find-conduit" + findFiles defaultFindOptions { findFollowSymlinks = False } + (decodeString dir) $ do + path <- asks entryPath + guard (".hs" `isSuffixOf` path) + norecurse + liftIO $ putStrLn path + + "find-conduit2" -> do + putStrLn "Running findFiles from find-conduit" + runResourceT $ + sourceFindFiles defaultFindOptions { findFollowSymlinks = False } + (decodeString dir) (return ()) + =$ filterC ((".hs" `isSuffixOf`) . entryPath . fst) + $$ mapM_C (liftIO . putStrLn . entryPath . fst) + + "find" -> do + putStrLn "Running GNU find" + executeFile "find" True [dir, "-name", "*.hs", "-print"] Nothing