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 Filesystem.Path.CurrentOS (FilePath,
encodeString, decodeString)
import Prelude hiding (FilePath)
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 (encodeString startPath) 0 findOptions)
(encodeString 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 =
mapOutput decodeString $
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 (encodeString path) 0 defaultFindOptions) matcher
ltest :: MonadIO m => CondT FileEntry m () -> FilePath -> m Bool
ltest matcher path =
Cond.test
(newFileEntry (encodeString path) 0 defaultFindOptions
{ findFollowSymlinks = False })
matcher