diff --git a/Data/Cond.hs b/Data/Cond.hs new file mode 100644 --- /dev/null +++ b/Data/Cond.hs @@ -0,0 +1,506 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Cond + ( CondT(..), Cond + + -- * Executing CondT + , runCondT, runCond, applyCondT, applyCond + + -- * Promotions + , guardM, guard_, guardM_, apply, consider + + -- * Boolean logic + , matches, if_, when_, unless_, or_, and_, not_ + + -- * Basic conditionals + , ignore, norecurse, prune + + -- * Helper functions + , recurse, test + + -- * Isomorphism with a stateful EitherT + , CondEitherT(..), fromCondT, toCondT + ) where + +import Control.Applicative +import Control.Arrow (first) +import Control.Monad hiding (mapM_, sequence_) +import Control.Monad.Base +import Control.Monad.Catch +import Control.Monad.Morph +import Control.Monad.Reader.Class +import Control.Monad.State.Class +import Control.Monad.Trans +import Control.Monad.Trans.Control +import Control.Monad.Trans.Either +import Control.Monad.Trans.State (StateT(..), withStateT, evalStateT) +import Data.Foldable +import Data.Functor.Identity +import Data.Maybe (fromMaybe, isJust) +import Data.Monoid hiding ((<>)) +import Data.Semigroup +import Prelude hiding (mapM_, foldr1, sequence_) + +-- | 'Result' is an enriched 'Maybe' type which also specifies whether +-- recursion should occur from the given input, and if so, how such +-- recursion should be performed. +data Result a m b = Ignore + | Keep b + | RecurseOnly (Maybe (CondT a m b)) + | KeepAndRecurse b (Maybe (CondT a m b)) + +instance Show b => Show (Result a m b) where + show Ignore = "Ignore" + show (Keep a) = "Keep " ++ show a + show (RecurseOnly _) = "RecurseOnly" + show (KeepAndRecurse a _) = "KeepAndRecurse " ++ show a + +instance Monad m => Functor (Result a m) where + fmap _ Ignore = Ignore + fmap f (Keep a) = Keep (f a) + fmap f (RecurseOnly l) = RecurseOnly (liftM (fmap f) l) + fmap f (KeepAndRecurse a l) = KeepAndRecurse (f a) (liftM (fmap f) l) + {-# INLINE fmap #-} + +instance MFunctor (Result a) where + hoist _ Ignore = Ignore + hoist _ (Keep a) = Keep a + hoist nat (RecurseOnly l) = RecurseOnly (fmap (hoist nat) l) + hoist nat (KeepAndRecurse a l) = KeepAndRecurse a (fmap (hoist nat) l) + {-# INLINE hoist #-} + +instance Semigroup (Result a m b) where + Ignore <> _ = Ignore + _ <> Ignore = Ignore + RecurseOnly _ <> Keep _ = Ignore + RecurseOnly _ <> KeepAndRecurse _ m = RecurseOnly m + RecurseOnly m <> _ = RecurseOnly m + Keep _ <> RecurseOnly _ = Ignore + _ <> RecurseOnly m = RecurseOnly m + _ <> Keep b = Keep b + Keep _ <> KeepAndRecurse b _ = Keep b + _ <> KeepAndRecurse b m = KeepAndRecurse b m + {-# INLINE (<>) #-} + +instance Monoid b => Monoid (Result a m b) where + mempty = KeepAndRecurse mempty Nothing + {-# INLINE mempty #-} + mappend = (<>) + {-# INLINE mappend #-} + +getResult :: Result a m b -> (Maybe b, Maybe (CondT a m b)) +getResult Ignore = (Nothing, Nothing) +getResult (Keep b) = (Just b, Nothing) +getResult (RecurseOnly c) = (Nothing, c) +getResult (KeepAndRecurse b c) = (Just b, c) + +setRecursion :: CondT a m b -> Result a m b -> Result a m b +setRecursion _ Ignore = Ignore +setRecursion _ (Keep b) = Keep b +setRecursion c (RecurseOnly _) = RecurseOnly (Just c) +setRecursion c (KeepAndRecurse b _) = KeepAndRecurse b (Just c) + +accept' :: b -> Result a m b +accept' = flip KeepAndRecurse Nothing + +recurse' :: Result a m b +recurse' = RecurseOnly Nothing + +-- | Convert from a 'Maybe' value to its corresponding 'Result'. +-- +-- >>> maybeToResult Nothing :: Result () Identity () +-- RecurseOnly +-- >>> maybeToResult (Just ()) :: Result () Identity () +-- KeepAndRecurse () +maybeToResult :: Maybe a -> Result r m a +maybeToResult Nothing = recurse' +maybeToResult (Just a) = accept' a + +maybeFromResult :: Result r m a -> Maybe a +maybeFromResult Ignore = Nothing +maybeFromResult (Keep a) = Just a +maybeFromResult (RecurseOnly _) = Nothing +maybeFromResult (KeepAndRecurse a _) = Just a + +-- | 'CondT' is a kind of @StateT a (MaybeT m) b@, which uses a special +-- 'Result' type instead of 'Maybe' to express whether recursion should be +-- performed from the item under consideration. This is used to build +-- predicates that can guide recursive traversals. +-- +-- Several different types may be promoted to 'CondT': +-- +-- [@Bool@] Using 'guard' +-- +-- [@m Bool@] Using 'guardM' +-- +-- [@a -> Bool@] Using 'guard_' +-- +-- [@a -> m Bool@] Using 'guardM_' +-- +-- [@a -> m (Maybe b)@] Using 'apply' +-- +-- [@a -> m (Maybe (b, a))@] Using 'consider' +-- +-- Here is a trivial example: +-- +-- @ +-- flip runCondT 42 $ do +-- guard_ even +-- liftIO $ putStrLn "42 must be even to reach here" +-- guard_ odd \<|\> guard_ even +-- guard_ (== 42) +-- @ +-- +-- If 'CondT' is executed using 'runCondT', it return a @Maybe b@ if the +-- predicate matched. It can also be run with 'applyCondT', which does case +-- analysis on the 'Result', specifying how recursion should be performed from +-- the given 'a' value. +newtype CondT a m b = CondT { getCondT :: StateT a m (Result a m b) } + +type Cond a = CondT a Identity + +instance Show (CondT a m b) where + show _ = "CondT" + +instance (Monad m, Semigroup b) => Semigroup (CondT a m b) where + (<>) = liftM2 (<>) + {-# INLINE (<>) #-} + +instance (Monad m, Monoid b) => Monoid (CondT a m b) where + mempty = CondT $ return $ accept' mempty + {-# INLINE mempty #-} + mappend = liftM2 mappend + {-# INLINE mappend #-} + +instance Monad m => Functor (CondT a m) where + fmap f (CondT g) = CondT (liftM (fmap f) g) + {-# INLINE fmap #-} + +instance Monad m => Applicative (CondT a m) where + pure = return + {-# INLINE pure #-} + (<*>) = ap + {-# INLINE (<*>) #-} + +instance Monad m => Monad (CondT a m) where + return = CondT . return . accept' + {-# INLINE return #-} + fail _ = mzero + {-# INLINE fail #-} + CondT f >>= k = CondT $ do + r <- f + case r of + Ignore -> return Ignore + Keep b -> do + n <- getCondT (k b) + return $ case n of + RecurseOnly _ -> Ignore + KeepAndRecurse c _ -> Keep c + _ -> n + RecurseOnly l -> return $ RecurseOnly (fmap (>>= k) l) + KeepAndRecurse b _ -> getCondT (k b) + +instance Monad m => MonadReader a (CondT a m) where + ask = CondT $ gets accept' + {-# INLINE ask #-} + local f (CondT m) = CondT $ withStateT f m + {-# INLINE local #-} + reader f = liftM f ask + {-# INLINE reader #-} + +instance Monad m => MonadState a (CondT a m) where + get = CondT $ gets accept' + {-# INLINE get #-} + put s = CondT $ liftM accept' $ put s + {-# INLINE put #-} + state f = CondT $ state (fmap (first accept') f) + {-# INLINE state #-} + +instance Monad m => Alternative (CondT a m) where + empty = CondT $ return recurse' + {-# INLINE empty #-} + CondT f <|> CondT g = CondT $ do + r <- f + case r of + x@(Keep _) -> return x + x@(KeepAndRecurse _ _) -> return x + _ -> g + {-# INLINE (<|>) #-} + +instance Monad m => MonadPlus (CondT a m) where + mzero = empty + {-# INLINE mzero #-} + mplus = (<|>) + {-# INLINE mplus #-} + +instance MonadThrow m => MonadThrow (CondT a m) where + throwM = CondT . throwM + {-# INLINE throwM #-} + +instance MonadCatch m => MonadCatch (CondT a m) where + catch (CondT m) c = CondT $ m `catch` \e -> getCondT (c e) + +instance MonadMask m => MonadMask (CondT a m) where + mask a = CondT $ mask $ \u -> getCondT (a $ q u) + where q u = CondT . u . getCondT + uninterruptibleMask a = + CondT $ uninterruptibleMask $ \u -> getCondT (a $ q u) + where q u = CondT . u . getCondT + +instance MonadBase b m => MonadBase b (CondT a m) where + liftBase m = CondT $ liftM accept' $ liftBase m + {-# INLINE liftBase #-} + +instance MonadIO m => MonadIO (CondT a m) where + liftIO m = CondT $ liftM accept' $ liftIO m + {-# INLINE liftIO #-} + +instance MonadTrans (CondT a) where + lift m = CondT $ liftM accept' $ lift m + {-# INLINE lift #-} + +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 #-} + +instance MFunctor (CondT a) where + hoist nat (CondT m) = CondT $ hoist nat (liftM (hoist nat) m) + {-# INLINE hoist #-} + +runCondT :: Monad m => CondT a m b -> a -> m (Maybe b) +runCondT (CondT f) a = maybeFromResult `liftM` evalStateT f a +{-# INLINE runCondT #-} + +runCond :: Cond a b -> a -> Maybe b +runCond = (runIdentity .) . runCondT +{-# INLINE runCond #-} + +-- | Case analysis of applying a condition to an input value. The result is a +-- pair whose first part is a pair of Maybes specifying if the input matched +-- and if recursion is expected from this value, and whose second part is +-- the (possibly) mutated input value. +applyCondT :: Monad m + => a + -> CondT a m b + -> m ((Maybe b, Maybe (CondT a m b)), a) +applyCondT a cond = do + -- Apply a condition to the input value, determining the result and the + -- mutated value. + (r, a') <- runStateT (getCondT cond) a + + -- Convert from the 'Result' to a pair of Maybes: one to specify if the + -- predicate succeeded, and the other to specify if recursion should be + -- performed. If there is no sub-recursion specified, return 'cond'. + return (fmap (Just . fromMaybe cond) (getResult r), a') +{-# INLINE applyCondT #-} + +-- | Case analysis of applying a pure condition to an input value. The result +-- is a pair whose first part is a pair of Maybes specifying if the input +-- matched and if recursion is expected from this value, and whose second +-- part is the (possibly) mutated input value. +applyCond :: a -> Cond a b -> ((Maybe b, Maybe (Cond a b)), a) +applyCond a cond = first (fmap (Just . fromMaybe cond) . getResult) + (runIdentity (runStateT (getCondT cond) a)) +{-# INLINE applyCond #-} + +guardM :: Monad m => m Bool -> CondT a m () +guardM m = lift m >>= guard +{-# INLINE guardM #-} + +guard_ :: Monad m => (a -> Bool) -> CondT a m () +guard_ f = asks f >>= guard +{-# INLINE guard_ #-} + +guardM_ :: Monad m => (a -> m Bool) -> CondT a m () +guardM_ f = ask >>= lift . f >>= guard +{-# INLINE guardM_ #-} + +apply :: Monad m => (a -> m (Maybe b)) -> CondT a m b +apply f = CondT $ get >>= liftM maybeToResult . lift . f +{-# INLINE apply #-} + +consider :: Monad m => (a -> m (Maybe (b, a))) -> CondT a m b +consider f = CondT $ do + mres <- lift . f =<< get + case mres of + Nothing -> return Ignore + Just (b, a') -> put a' >> return (accept' b) +{-# INLINE consider #-} + +-- | Return True or False depending on whether the given condition matches or +-- not. This differs from simply stating the condition in that it itself +-- always succeeds. +-- +-- >>> flip runCond "foo.hs" $ matches (guard =<< asks (== "foo.hs")) +-- Just True +-- >>> flip runCond "foo.hs" $ matches (guard =<< asks (== "foo.hi")) +-- Just False +matches :: Monad m => CondT a m b -> CondT a m Bool +matches = fmap isJust . optional +{-# INLINE matches #-} + +-- | A variant of ifM which branches on whether the condition succeeds or not. +-- Note that @if_ x@ is equivalent to @ifM (matches x)@, and is provided +-- solely for convenience. +-- +-- >>> let good = guard_ (== "foo.hs") :: Cond String () +-- >>> let bad = guard_ (== "foo.hi") :: Cond String () +-- >>> flip runCond "foo.hs" $ if_ good (return "Success") (return "Failure") +-- Just "Success" +-- >>> flip runCond "foo.hs" $ if_ bad (return "Success") (return "Failure") +-- Just "Failure" +if_ :: Monad m => CondT a m r -> CondT a m b -> CondT a m b -> CondT a m b +if_ c x y = + CondT $ getCondT . maybe y (const x) . maybeFromResult =<< getCondT c +{-# INLINE if_ #-} + +-- | 'when_' is just like 'when', except that it executes the body if the +-- condition passes, rather than based on a Bool value. +-- +-- >>> let good = guard_ (== "foo.hs") :: Cond String () +-- >>> let bad = guard_ (== "foo.hi") :: Cond String () +-- >>> flip runCond "foo.hs" $ when_ good ignore +-- Nothing +-- >>> flip runCond "foo.hs" $ when_ bad ignore +-- Just () +when_ :: Monad m => CondT a m r -> CondT a m () -> CondT a m () +when_ c x = if_ c (void x) (return ()) +{-# INLINE when_ #-} + +-- | 'when_' is just like 'when', except that it executes the body if the +-- condition fails, rather than based on a Bool value. +-- +-- >>> let good = guard_ (== "foo.hs") :: Cond String () +-- >>> let bad = guard_ (== "foo.hi") :: Cond String () +-- >>> flip runCond "foo.hs" $ unless_ bad ignore +-- Nothing +-- >>> flip runCond "foo.hs" $ unless_ good ignore +-- Just () +unless_ :: Monad m => CondT a m r -> CondT a m () -> CondT a m () +unless_ c = if_ c (return ()) . void +{-# INLINE unless_ #-} + +-- | Check whether at least one of the given conditions is true. This is a +-- synonym for 'Data.Foldable.asum'. +-- +-- >>> let good = guard_ (== "foo.hs") :: Cond String () +-- >>> let bad = guard_ (== "foo.hi") :: Cond String () +-- >>> flip runCond "foo.hs" $ or_ [bad, good] +-- Just () +-- >>> flip runCond "foo.hs" $ or_ [bad] +-- Nothing +or_ :: Monad m => [CondT a m b] -> CondT a m b +or_ = asum +{-# INLINE or_ #-} + +-- | Check that all of the given conditions are true. This is a synonym for +-- 'Data.Foldable.sequence_'. +-- +-- >>> let good = guard_ (== "foo.hs") :: Cond String () +-- >>> let bad = guard_ (== "foo.hi") :: Cond String () +-- >>> flip runCond "foo.hs" $ and_ [bad, good] +-- Nothing +-- >>> flip runCond "foo.hs" $ and_ [good] +-- Just () +and_ :: Monad m => [CondT a m b] -> CondT a m () +and_ = sequence_ +{-# INLINE and_ #-} + +-- | 'not_' inverts the meaning of the given predicate. +-- +-- >>> let good = guard_ (== "foo.hs") :: Cond String () +-- >>> let bad = guard_ (== "foo.hi") :: Cond String () +-- >>> flip runCond "foo.hs" $ not_ bad >> return "Success" +-- Just "Success" +-- >>> flip runCond "foo.hs" $ not_ good >> return "Shouldn't reach here" +-- Nothing +not_ :: Monad m => CondT a m b -> CondT a m () +not_ c = when_ c ignore +{-# INLINE not_ #-} + +-- | 'ignore' ignores the current entry, but allows recursion into its +-- descendents. This is the same as 'mzero'. +ignore :: Monad m => CondT a m b +ignore = mzero +{-# INLINE ignore #-} + +-- | 'norecurse' prevents recursion into the current entry's descendents, but +-- does not ignore the entry itself. +norecurse :: Monad m => CondT a m () +norecurse = CondT $ return $ Keep () +{-# INLINE norecurse #-} + +-- | 'prune' is a synonym for both ignoring an entry and its descendents. It +-- is the same as @ignore >> norecurse@. +prune :: Monad m => CondT a m b +prune = CondT $ return Ignore +{-# INLINE prune #-} + +-- | 'recurse' changes the recursion predicate for any child elements. For +-- example, the following file-finding predicate looks for all @*.hs@ files, +-- but under any @.git@ directory looks only for a file named @config@: +-- +-- @ +-- if_ (name_ \".git\" \>\> directory) +-- (ignore \>\> recurse (name_ \"config\")) +-- (glob \"*.hs\") +-- @ +-- +-- NOTE: If this code had used @recurse (glob \"*.hs\"))@ instead in the else +-- case, it would have meant that @.git@ is only looked for at the top-level +-- of the search (i.e., the top-most element). +recurse :: Monad m => CondT a m b -> CondT a m b +recurse c = CondT $ setRecursion c `liftM` getCondT c +{-# INLINE recurse #-} + +-- | A specialized variant of 'runCondT' that simply returns True or False. +-- +-- >>> let good = guard_ (== "foo.hs") :: Cond String () +-- >>> let bad = guard_ (== "foo.hi") :: Cond String () +-- >>> runIdentity $ test "foo.hs" $ not_ bad >> return "Success" +-- True +-- >>> runIdentity $ test "foo.hs" $ not_ good >> return "Shouldn't reach here" +-- False +test :: Monad m => a -> CondT a m b -> m Bool +test = (liftM isJust .) . flip runCondT +{-# INLINE test #-} + +-- | This type is for documentation only, and shows the isomorphism between +-- 'CondT' and 'CondEitherT'. The reason for using 'Result' is that it +-- makes meaning of the constructors more explicit. +newtype CondEitherT a m b = CondEitherT + (StateT a (EitherT (Maybe (Maybe (CondEitherT a m b))) m) + (b, Maybe (Maybe (CondEitherT a m b)))) + +-- | Witness one half of the isomorphism from 'CondT' to 'CondEitherT'. +fromCondT :: Monad m => CondT a m b -> CondEitherT a m b +fromCondT (CondT f) = CondEitherT $ do + s <- get + (r, s') <- lift $ lift $ runStateT f s + case r of + Ignore -> lift $ left Nothing + Keep a -> put s' >> return (a, Nothing) + RecurseOnly m -> lift $ left (Just (fmap fromCondT m)) + KeepAndRecurse a m -> put s' >> return (a, Just (fmap fromCondT m)) + +-- | Witness the other half of the isomorphism from 'CondEitherT' to 'CondT'. +toCondT :: Monad m => CondEitherT a m b -> CondT a m b +toCondT (CondEitherT f) = CondT $ do + s <- get + eres <- lift $ runEitherT $ runStateT f s + case eres of + Left Nothing -> return Ignore + Right ((a, Nothing), s') -> put s' >> return (Keep a) + Left (Just m) -> return $ RecurseOnly (fmap toCondT m) + Right ((a, Just m), s') -> + put s' >> return (KeepAndRecurse a (fmap toCondT m)) diff --git a/Data/Conduit/Find.hs b/Data/Conduit/Find.hs new file mode 100644 --- /dev/null +++ b/Data/Conduit/Find.hs @@ -0,0 +1,610 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Conduit.Find + ( + -- * Introduction + -- $intro + + -- ** Basic comparison with GNU find + -- $gnufind + + -- ** Performance + -- $performance + + -- ** Other notes + -- $notes + + -- * Finding functions + sourceFindFiles + , find + , findFiles + , findFilePaths + , FindOptions(..) + , defaultFindOptions + , test + , ltest + , stat + , lstat + , hasStatus + + -- * File path predicates + , glob + , regex + , ignoreVcs + + -- * GNU find compatibility predicates + , depth_ + , follow_ + , noleaf_ + , prune_ + , maxdepth_ + , mindepth_ + , ignoreErrors_ + , noIgnoreErrors_ + , amin_ + , atime_ + , anewer_ + , empty_ + , executable_ + , gid_ + , name_ + , getDepth + , filename_ + , pathname_ + , getFilePath + + -- * File entry predicates (uses stat information) + , regular + , directory + , hasMode + , executable + , lastAccessed_ + , lastModified_ + + -- * Predicate combinators + , module Cond + , (=~) + + -- * Types and type classes + , FileEntry(..) + ) where + +import Conduit +import Control.Applicative +import Control.Exception +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 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 qualified System.FilePath as FP +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. +-} + +data FindOptions = FindOptions + { findFollowSymlinks :: !Bool + , findContentsFirst :: !Bool + , findIgnoreErrors :: !Bool + , findIgnoreResults :: !Bool + , findLeafOptimization :: !Bool + } + +defaultFindOptions :: FindOptions +defaultFindOptions = FindOptions + { findFollowSymlinks = True + , findContentsFirst = False + , findIgnoreErrors = False + , findIgnoreResults = False + , findLeafOptimization = True + } + +data FileEntry = FileEntry + { entryPath :: !FP.FilePath + , entryDepth :: !Int + , entryFindOptions :: !FindOptions + , entryStatus :: !(Maybe FileStatus) + -- ^ This is Nothing until we determine stat should be called. + } + +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 FP.FilePath +getFilePath = gets entryPath + +pathname_ :: Monad m => (FP.FilePath -> Bool) -> CondT FileEntry m () +pathname_ f = guard . f =<< getFilePath + +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 + +modifyFindOptions :: Monad m + => (FindOptions -> FindOptions) + -> CondT FileEntry m () +modifyFindOptions f = + modify $ \e -> e { entryFindOptions = f (entryFindOptions e) } + +------------------------------------------------------------------------ +-- Workalike options for emulating GNU find. +------------------------------------------------------------------------ + +depth_ :: Monad m => CondT FileEntry m () +depth_ = modifyFindOptions $ \opts -> opts { findContentsFirst = True } + +follow_ :: Monad m => CondT FileEntry m () +follow_ = modifyFindOptions $ \opts -> opts { findFollowSymlinks = True } + +noleaf_ :: Monad m => CondT FileEntry m () +noleaf_ = modifyFindOptions $ \opts -> opts { findLeafOptimization = 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) + +-- xdev_ = error "NYI" + +timeComp :: MonadIO m + => ((UTCTime -> Bool) -> CondT FileEntry m ()) -> Int + -> CondT FileEntry m () +timeComp f n = do + now <- liftIO getCurrentTime + f (\t -> diffUTCTime now t > fromIntegral n) + +amin_ :: MonadIO m => Int -> CondT FileEntry m () +amin_ n = timeComp lastAccessed_ (n * 60) + +atime_ :: MonadIO m => Int -> CondT FileEntry m () +atime_ n = timeComp lastAccessed_ (n * 24 * 3600) + +anewer_ :: MonadIO m => FP.FilePath -> CondT FileEntry m () +anewer_ path = do + e <- get + es <- applyStat Nothing + ms <- getStat Nothing e { entryPath = 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 m () +empty_ = (regular >> hasStatus ((== 0) . fileSize)) + <|> (directory >> hasStatus ((== 2) . linkCount)) + +executable_ :: MonadIO m => CondT FileEntry m () +executable_ = executable + +gid_ :: MonadIO m => Int -> CondT FileEntry 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 => FP.FilePath -> CondT FileEntry 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 +-} + +------------------------------------------------------------------------ + +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 + => Maybe Bool + -> FileEntry + -> m (Maybe (FileStatus, FileEntry)) +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 = 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 + ms <- lift . getStat mfollow =<< get + case ms of + Nothing -> prune >> error "This is never reached" + Just (s, e') -> s <$ put e' + +lstat :: MonadIO m => CondT FileEntry m FileStatus +lstat = applyStat (Just False) + +stat :: MonadIO m => CondT FileEntry m FileStatus +stat = applyStat (Just True) + +hasStatus :: MonadIO m => (FileStatus -> Bool) -> CondT FileEntry m () +hasStatus f = guard . f =<< applyStat Nothing + +regular :: MonadIO m => CondT FileEntry m () +regular = hasStatus isRegularFile + +executable :: MonadIO m => CondT FileEntry m () +executable = hasMode ownerExecuteMode + +directory :: MonadIO m => CondT FileEntry m () +directory = hasStatus isDirectory + +hasMode :: MonadIO m => FileMode -> CondT FileEntry m () +hasMode m = hasStatus (\s -> fileMode s .&. m /= 0) + +withStatusTime :: MonadIO m + => (FileStatus -> EpochTime) -> (UTCTime -> Bool) + -> CondT FileEntry m () +withStatusTime g f = hasStatus (f . posixSecondsToUTCTime . realToFrac . g) + +lastAccessed_ :: MonadIO m => (UTCTime -> Bool) -> CondT FileEntry m () +lastAccessed_ = withStatusTime accessTime + +lastModified_ :: MonadIO m => (UTCTime -> Bool) -> CondT FileEntry m () +lastModified_ = withStatusTime modificationTime + +regex :: Monad m => String -> CondT FileEntry m () +regex pat = filename_ (=~ pat) + +-- | Return all entries, except for those within version-control metadata +-- directories (and not including the version control directory itself either). +ignoreVcs :: Monad m => CondT FileEntry 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 => String -> CondT FileEntry m () +glob g = case parseOnly globParser (pack g) of + Left e -> error $ "Failed to parse glob: " ++ e + Right x -> regex ("^" <> unpack 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] + +#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. +sourceFindFiles :: MonadResource m + => FindOptions + -> FilePath + -> CondT FileEntry m a + -> Producer m (FileEntry, a) +sourceFindFiles findOptions startPath predicate = do + startDc <- newDirCounter + walk startDc + (newFileEntry startPath 0 findOptions) + startPath + predicate + where + 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 dc entry' path mcond + if findContentsFirst opts' + then next >> this + else this >> next + where + yieldEntry _ Nothing = return () + yieldEntry entry' (Just res) = yield (entry', res) + + 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 + + -- 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 + -> FilePath + -> CondT FileEntry m a + -> m () +findFiles opts path predicate = + 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. +findFilePaths :: (MonadIO m, MonadResource m) + => FindOptions + -> FilePath + -> CondT FileEntry m a + -> Producer m FilePath +findFilePaths opts path predicate = + sourceFindFiles opts path predicate =$= mapC (entryPath . fst) + +-- | Calls 'findFilePaths' with the default set of finding options. +-- Equivalent to @findFilePaths defaultFindOptions@. +find :: MonadResource m + => FilePath -> CondT FileEntry m a -> Producer m FilePath +find = findFilePaths defaultFindOptions + +-- | Test a file path using the same type of predicate that is accepted by +-- 'findFiles'. +test :: MonadIO m => CondT FileEntry m () -> FilePath -> m Bool +test matcher path = + Cond.test (newFileEntry 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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +opyright (c) 2014 John Wiegley + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. 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/conduit-find.cabal b/conduit-find.cabal new file mode 100644 --- /dev/null +++ b/conduit-find.cabal @@ -0,0 +1,120 @@ +Name: conduit-find +Version: 0.1.0 +Synopsis: A file-finding conduit that allows user control over traversals. +License-file: LICENSE +License: MIT +Author: John Wiegley +Maintainer: Erik de Castro Lopo +Build-Type: Simple +Cabal-Version: >= 1.10 +Category: System + +Homepage: https://github.com/erikd/conduit-find +Bug-Reports: https://github.com/erikd/conduit-find/issues + +Description: + A file-finding conduit that allows user control over traversals. Please see + the module 'Data.Conduit.Find' for more information. + +Source-repository head + type: git + location: https://github.com/erikd/conduit-find.git + +Flag leafopt + Description: Enable leaf optimization + Default: True + +Library + default-language: Haskell2010 + 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 + , unix-compat >= 0.4.1.1 + , text >= 0.11.3.1 + , regex-posix + , mtl + , semigroups + , exceptions >= 0.6 + , time + , streaming-commons + , transformers + , transformers-base + , mmorph + , either + , monad-control >= 1.0 + , filepath + exposed-modules: + Data.Cond, Data.Conduit.Find + +test-suite test + hs-source-dirs: test + default-language: Haskell2010 + main-is: main.hs + type: exitcode-stdio-1.0 + ghc-options: -Wall -threaded + build-depends: + base + , conduit-find + , conduit + , conduit-combinators + , attoparsec + , 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 + Default-language: Haskell2010 + 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 + +Executable find-hs + Main-is: find-hs.hs + default-language: Haskell2010 + Ghc-options: -threaded -O2 + Hs-source-dirs: test + Build-depends: + base + , conduit-find + , conduit + , conduit-extra + , conduit-combinators + , attoparsec + , 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 new file mode 100644 --- /dev/null +++ b/test/doctest.hs @@ -0,0 +1,29 @@ +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 $ + "-iData" + : "-idist/build/autogen" + : "-optP-include" + : "-optPdist/build/autogen/cabal_macros.h" + : sources + +getSources :: IO [FilePath] +getSources = + filter (\n -> ".hs" `isSuffixOf` n) <$> go "./Data" + 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,41 @@ +module Main where + +import Conduit +import Control.Monad +import Control.Monad.Reader.Class +import Data.Conduit.Find +import Data.List +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 dir + =$ filterC (".hs" `isSuffixOf`) + $$ mapM_C (liftIO . putStrLn) + + "find-conduit" -> do + putStrLn "Running findFiles from find-conduit" + findFiles defaultFindOptions { findFollowSymlinks = False } + 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 } + 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 diff --git a/test/main.hs b/test/main.hs new file mode 100644 --- /dev/null +++ b/test/main.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Conduit +import Data.Conduit.Find +import Test.Hspec + +main :: IO () +main = hspec $ do + describe "basic tests" $ do + it "file passes a test" $ do + res <- test (regular >> not_ executable) "README.md" + res `shouldBe` True + + it "file fails a test" $ do + res <- test (not_ regular) "README.md" + res `shouldBe` False + + it "file fails another test" $ do + res <- test (regular >> executable) "README.md" + res `shouldBe` False + + it "finds files" $ do + xs <- runResourceT $ + find "." + (do ignoreVcs + when_ (name_ "dist") prune + glob "*.hs" + not_ (glob "Setup*") + regular + not_ executable) + $$ sinkList + + "./Data/Conduit/Find.hs" `elem` xs `shouldBe` True + "./dist/setup-config" `elem` xs `shouldBe` False + "./Setup.hs" `elem` xs `shouldBe` False + "./.git/config" `elem` xs `shouldBe` False + + it "finds files with a different ordering" $ do + xs <- runResourceT $ + find "." + (do ignoreVcs + glob "*.hs" + not_ (glob "Setup*") + -- This applies only to .hs files now, so it won't + -- match anything, thus having no effect but burning + -- CPU! + when_ (name_ "dist") prune + regular + not_ executable) + $$ sinkList + + "./Data/Conduit/Find.hs" `elem` xs `shouldBe` True + "./dist/setup-config" `elem` xs `shouldBe` False + "./Setup.hs" `elem` xs `shouldBe` False + "./.git/config" `elem` xs `shouldBe` False + + it "finds files using a pre-pass filter" $ do + xs <- runResourceT $ + find "." + (do ignoreVcs + when_ (name_ "dist") prune + glob "*.hs" + not_ (glob "Setup*") + regular + not_ executable) + $$ sinkList + + "./Data/Conduit/Find.hs" `elem` xs `shouldBe` True + "./dist/setup-config" `elem` xs `shouldBe` False + "./Setup.hs" `elem` xs `shouldBe` False + "./.git/config" `elem` xs `shouldBe` False + + it "properly applies post-pass pruning" $ do + xs <- runResourceT $ + find "." + (do ignoreVcs + maxdepth_ 1 + when_ (name_ "dist") prune + glob "*.hs" + not_ (glob "Setup*") + regular + not_ executable) + $$ sinkList + + "./Data/Conduit/Find.hs" `elem` xs `shouldBe` False + "./dist/setup-config" `elem` xs `shouldBe` False + "./Setup.hs" `elem` xs `shouldBe` False + "./.git/config" `elem` xs `shouldBe` False