module Data.Conduit.Find
(
find
, find'
, lfind
, lfind'
, stat
, lstat
, test
, findRaw
, ignoreVcs
, regex
, glob
, filename_
, filenameS_
, filepath_
, filepathS_
, withPath
, regular
, hasMode
, executable
, depth
, lastAccessed
, lastModified
, withFileStatus
, module Cond
, (=~)
, FileEntry(..)
) where
import Conduit
import Control.Applicative
import Control.Monad
import Control.Monad.State.Class
import Data.Attoparsec.Text
import Data.Bits
import qualified Data.Cond as Cond
import Data.Cond hiding (test)
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 ((=~))
type Predicate m a = CondT a m ()
data FileEntry = FileEntry
{ entryPath :: FilePath
, entryDepth :: Int
, entryStatus :: Maybe FileStatus
}
instance Show FileEntry where
show entry = "FileEntry "
++ show (entryPath entry)
++ " " ++ show (entryDepth entry)
newFileEntry :: FilePath -> Int -> FileEntry
newFileEntry p d = FileEntry p d Nothing
ignoreVcs :: Monad m => Predicate m FileEntry
ignoreVcs = prune (filename_ (`elem` vcsDirs))
where
vcsDirs = [ ".git", "CVS", "RCS", "SCCS", ".svn", ".hg", "_darcs" ]
regex :: Monad m => Text -> Predicate m FileEntry
regex pat = filename_ (=~ pat)
(=~) :: FilePath -> Text -> Bool
str =~ pat = encodeString str R.=~ unpack pat
glob :: Monad m => Text -> Predicate m FileEntry
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 (try (char ']'))
<*> char ']'
<|> do
x <- anyChar
return . pack $ if x `elem` ".()^$"
then ['\\', x]
else [x]
doStat :: MonadIO m => (String -> IO FileStatus) -> Predicate m FileEntry
doStat getstatus = do
entry <- get
s <- liftIO $ getstatus (encodeString (entryPath entry))
put $ entry { entryStatus = Just s }
lstat :: MonadIO m => Predicate m FileEntry
lstat = doStat getSymbolicLinkStatus
stat :: MonadIO m => Predicate m FileEntry
stat = doStat getFileStatus
getStatus :: FileEntry -> FileStatus
getStatus e = fromMaybe
(error $ "FileStatus has not been determined for: " ++ show (entryPath e))
(entryStatus e)
withFileStatus :: Monad m
=> (FileStatus -> m Bool)
-> Predicate m FileEntry
withFileStatus f = ifM_ (f . getStatus)
status :: Monad m => (FileStatus -> Bool) -> Predicate m FileEntry
status f = withFileStatus (return . f)
regular :: Monad m => Predicate m FileEntry
regular = status isRegularFile
directory :: Monad m => Predicate m FileEntry
directory = status isDirectory
hasMode :: Monad m => FileMode -> Predicate m FileEntry
hasMode m = status (\s -> fileMode s .&. m /= 0)
executable :: Monad m => Predicate m FileEntry
executable = hasMode ownerExecuteMode
withPath :: Monad m
=> (FilePath -> m Bool)
-> Predicate m FileEntry
withPath f = ifM_ (f . entryPath)
filename_ :: Monad m => (FilePath -> Bool) -> Predicate m FileEntry
filename_ f = withPath (return . f . filename)
filenameS_ :: Monad m => (String -> Bool) -> Predicate m FileEntry
filenameS_ f = withPath (return . f . encodeString . filename)
filepath_ :: Monad m => (FilePath -> Bool) -> Predicate m FileEntry
filepath_ f = withPath (return . f)
filepathS_ :: Monad m => (String -> Bool) -> Predicate m FileEntry
filepathS_ f = withPath (return . f . encodeString)
depth :: Monad m => (Int -> Bool) -> Predicate m FileEntry
depth f = if_ (f . entryDepth)
withStatusTime :: Monad m
=> (UTCTime -> Bool) -> (FileStatus -> POSIXTime)
-> Predicate m FileEntry
withStatusTime f g = status (f . posixSecondsToUTCTime . g)
lastAccessed :: Monad m => (UTCTime -> Bool) -> Predicate m FileEntry
lastAccessed = flip withStatusTime accessTimeHiRes
lastModified :: Monad m => (UTCTime -> Bool) -> Predicate m FileEntry
lastModified = flip withStatusTime modificationTimeHiRes
findRaw :: (MonadIO m, MonadResource m)
=> FilePath -> Bool -> Predicate m FileEntry -> Source m FileEntry
findRaw path follow predicate =
traverseRecursively
(newFileEntry path 0)
predicate
(const . yield)
lift
readDirectory
where
readDirectory (FileEntry p d mst) go = do
recurse <- isDirectory <$> case mst of
Nothing -> liftIO $ (if follow
then getFileStatus
else getSymbolicLinkStatus)
$ encodeString p
Just st -> return st
when recurse $
(sourceDirectory p =$) $ awaitForever $ \fp ->
mapInput (const ()) (const Nothing) $
go $ newFileEntry fp (succ d)
basicFind :: (MonadIO m, MonadResource m)
=> Predicate m FileEntry
-> Bool
-> FilePath
-> Predicate m FileEntry
-> Source m FileEntry
basicFind f follow path pr = findRaw path follow $
f >> (directory ||: norecurse) >> pr
find' :: (MonadIO m, MonadResource m)
=> FilePath -> Predicate m FileEntry
-> Source m FileEntry
find' = basicFind stat True
find :: (MonadIO m, MonadResource m)
=> FilePath -> Predicate m FileEntry
-> Source m FilePath
find path pr = find' path pr =$= mapC entryPath
lfind' :: (MonadIO m, MonadResource m)
=> FilePath -> Predicate m FileEntry
-> Source m FileEntry
lfind' = basicFind lstat False
lfind :: (MonadIO m, MonadResource m)
=> FilePath -> Predicate m FileEntry
-> Source m FilePath
lfind path pr = lfind' path pr =$= mapC entryPath
test :: MonadIO m => Predicate m FileEntry -> FilePath -> m Bool
test matcher path = Cond.test (stat >> matcher) (newFileEntry path 0)