module Data.Conduit.Find
(
find
, findFilesSource
, findFiles
, findFilePaths
, test
, ltest
, stat
, lstat
, hasStatus
, glob
, regex
, ignoreVcs
, depth_
, maxdepth_
, mindepth_
, ignoreReaddirRace_
, noIgnoreReaddirRace_
, amin_
, atime_
, anewer_
, empty_
, executable_
, gid_
, name_
, getDepth
, filename_
, filenameS_
, pathname_
, pathnameS_
, getFilePath
, follow_
, prune_
, regular
, directory
, hasMode
, executable
, lastAccessed_
, lastModified_
, module Cond
, (=~)
, FileEntry(..)
) where
import Conduit
import Control.Applicative
import Control.Exception
import Control.Monad hiding (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 Data.Monoid
import Data.Text (Text, unpack, pack)
import Data.Time
import Data.Time.Clock.POSIX
import Filesystem.Path.CurrentOS (FilePath, encodeString, filename)
import Prelude hiding (FilePath)
import System.Posix.Files
import System.Posix.Types
import qualified Text.Regex.Posix as R ((=~))
data FindOptions = FindOptions
{ findFollowSymlinks :: Bool
, findContentsFirst :: Bool
, findIgnoreReaddirRace :: Bool
, findIgnoreResults :: Bool
}
defaultFindOptions :: FindOptions
defaultFindOptions = FindOptions
{ findFollowSymlinks = True
, findContentsFirst = False
, findIgnoreReaddirRace = False
, findIgnoreResults = False
}
data FileEntry = FileEntry
{ entryPath :: !FilePath
, entryDepth :: !Int
, entryFindOptions :: !(FindOptions)
, entryStatus :: !(Maybe FileStatus)
}
newFileEntry :: FilePath -> Int -> FindOptions -> FileEntry
newFileEntry p d f = FileEntry p d f Nothing
instance Show FileEntry where
show entry = "FileEntry "
++ show (entryPath entry)
++ " " ++ show (entryDepth entry)
getFilePath :: Monad m => CondT FileEntry m FilePath
getFilePath = gets entryPath
pathname_ :: Monad m => (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)
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 }
ignoreReaddirRace_ :: Monad m => CondT FileEntry m ()
ignoreReaddirRace_ =
modifyFindOptions $ \opts -> opts { findIgnoreReaddirRace = True }
noIgnoreReaddirRace_ :: Monad m => CondT FileEntry m ()
noIgnoreReaddirRace_ =
modifyFindOptions $ \opts -> opts { findIgnoreReaddirRace = 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
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 => 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 . accessTimeHiRes
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 => FilePath -> CondT FileEntry m ()
name_ = filename_ . (==)
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
case ms of
Just s -> return $ Just (s, entry { entryStatus = Just s })
Nothing -> return 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)
where
opts = entryFindOptions entry
applyStat :: MonadIO m => Maybe Bool -> CondT FileEntry m FileStatus
applyStat mfollow = do
e <- get
ms <- lift (getStat mfollow e)
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 -> POSIXTime) -> (UTCTime -> Bool)
-> CondT FileEntry m ()
withStatusTime g f = hasStatus (f . posixSecondsToUTCTime . g)
lastAccessed_ :: MonadIO m => (UTCTime -> Bool) -> CondT FileEntry m ()
lastAccessed_ = withStatusTime accessTimeHiRes
lastModified_ :: MonadIO m => (UTCTime -> Bool) -> CondT FileEntry m ()
lastModified_ = withStatusTime modificationTimeHiRes
(=~) :: FilePath -> Text -> Bool
str =~ pat = encodeString str R.=~ unpack pat
regex :: Monad m => Text -> 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 => Text -> CondT FileEntry m ()
glob g = case parseOnly globParser g of
Left e -> error $ "Failed to parse glob: " ++ e
Right x -> regex ("^" <> 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` ".()^$"
then ['\\', x]
else [x]
findFilesSource :: (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
where
wrap = mapInput (const ()) (const Nothing)
go x pr = do
((mres, mcond), entry) <- applyCondT x pr
let opts' = entryFindOptions entry
this = unless (findIgnoreResults opts') $ yieldEntry entry mres
next = walkChildren entry mcond
if findContentsFirst opts'
then next >> this
else this >> next
yieldEntry entry mres =
forM_ mres $ yield . (entry,)
walkChildren entry@(FileEntry path depth opts' _) mcond =
forM_ mcond $ \cond -> do
descend <- fmap (isDirectory . fst) <$> getStat Nothing entry
when (descend == Just True) $
(sourceDirectory path =$) $ awaitForever $ \fp ->
wrap $ go (newFileEntry fp (succ depth) opts') cond
findFiles :: (MonadIO m, MonadBaseControl IO m, MonadThrow m)
=> FindOptions
-> FilePath
-> CondT FileEntry m a
-> m ()
findFiles opts path predicate =
runResourceT $ findFilesSource
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 =
findFilesSource 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