module Data.Conduit.Find
(
sourceFindFiles
, find
, findFiles
, findFilePaths
, FindOptions(..)
, defaultFindOptions
, test
, ltest
, stat
, lstat
, hasStatus
, glob
, regex
, ignoreVcs
, depth_
, follow_
, noleaf_
, prune_
, maxdepth_
, mindepth_
, ignoreErrors_
, noIgnoreErrors_
, amin_
, atime_
, anewer_
, empty_
, executable_
, gid_
, name_
, getDepth
, filename_
, pathname_
, getFilePath
, regular
, directory
, hasMode
, executable
, lastAccessed_
, lastModified_
, module Cond
, (=~)
, 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 ((=~))
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)
}
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) }
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)
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
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)
name_ :: Monad m => FP.FilePath -> CondT FileEntry m ()
name_ = filename_ . (==)
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)
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)
ignoreVcs :: Monad m => CondT FileEntry m ()
ignoreVcs = when_ (filename_ (`elem` vcsDirs)) prune
where
vcsDirs = [ ".git", "CVS", "RCS", "SCCS", ".svn", ".hg", "_darcs" ]
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
sourceFindFiles :: (MonadIO m, 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 ()
walkChildren !dc !entry !path (Just !cond) = do
st <- lift $ checkIfDirectory dc entry path
when (fmap isDirectory st == Just True) $ do
#if LEAFOPT
liftIO $ modifyIORef dc pred
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
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 == ()
#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
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)
find :: (MonadIO m, MonadResource m)
=> FilePath -> CondT FileEntry m a -> Producer m FilePath
find = findFilePaths defaultFindOptions
test :: MonadIO m => CondT FileEntry m () -> FilePath -> m Bool
test matcher path =
Cond.test (newFileEntry path 0 defaultFindOptions) matcher
ltest :: MonadIO m => CondT FileEntry m () -> FilePath -> m Bool
ltest matcher path =
Cond.test
(newFileEntry path 0 defaultFindOptions
{ findFollowSymlinks = False })
matcher