module Pipes.Files
(
sourceFindFiles
, find
, findFiles
, findFilesIO
, findFilePaths
, FindOptions(..)
, defaultFindOptions
, directoryFiles
, test
, ltest
, stat
, lstat
, hasStatus
, glob
, regex
, ignoreVcs
, depth_
, follow_
, prune_
, maxdepth_
, mindepth_
, ignoreErrors_
, noIgnoreErrors_
, amin_
, atime_
, anewer_
, empty_
, executable_
, gid_
, name_
, getDepth
, filename_
, pathname_
, getEntryPath
, getRawEntryPath
, regular
, directory
, hasMode
, executable
, lastAccessed_
, lastModified_
, module Cond
, (=~)
, FileEntry(..)
, IsFilePath(..)
, genericFindFiles
, genericFindFilePaths
, genericFind
, genericTest
, genericLtest
) where
import Control.Applicative
import Control.Comonad.Trans.Cofree
import qualified Control.Cond as Cond
import Control.Cond hiding (test)
import Control.Exception as E
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Morph
import Control.Monad.Trans.Control
import Data.Attoparsec.Text as A
import Data.Bits
import qualified Data.ByteString as B
import Data.Char (ord)
import Data.Monoid
import Data.String (IsString)
import Data.Text (Text, pack)
import Data.Time
import Data.Time.Clock.POSIX
import Data.Word (Word8)
import Foreign.C
import Pipes
import Pipes.Files.Directory
import Pipes.Files.Types
import qualified Pipes.Prelude as P
import Pipes.Safe
import Pipes.Tree
import Prelude
import System.Directory hiding (executable, findFiles)
import System.Posix.ByteString.FilePath
import System.Posix.FilePath
import System.PosixCompat.Files
import System.PosixCompat.Types
import Text.Regex.Posix ((=~))
getEntryPath :: (Monad m, IsFilePath f) => CondT (FileEntry f) m f
getEntryPath = queries (fromRawFilePath . entryPath)
getRawEntryPath :: Monad m => CondT (FileEntry f) m RawFilePath
getRawEntryPath = queries entryPath
pathname_ :: (Monad m, IsFilePath f) => (f -> Bool) -> CondT (FileEntry f) m ()
pathname_ f = guard . f =<< getEntryPath
filename_ :: (Monad m, IsFilePath f) => (f -> Bool) -> CondT (FileEntry f) m ()
filename_ f = pathname_ (f . fromRawFilePath . takeFileName . getRawFilePath)
getDepth :: Monad m => CondT (FileEntry f) m Int
getDepth = queries entryDepth
modifyFindOptions :: Monad m
=> (FindOptions -> FindOptions) -> CondT (FileEntry f) m ()
modifyFindOptions f =
updates $ \e -> e { entryFindOptions = f (entryFindOptions e) }
depth_ :: Monad m => CondT (FileEntry f) m ()
depth_ = modifyFindOptions $ \opts -> opts { findContentsFirst = True }
follow_ :: Monad m => CondT (FileEntry f) m ()
follow_ = modifyFindOptions $ \opts -> opts { findFollowSymlinks = True }
prune_ :: Monad m => CondT a m ()
prune_ = prune
ignoreErrors_ :: Monad m => CondT (FileEntry f) m ()
ignoreErrors_ =
modifyFindOptions $ \opts -> opts { findIgnoreErrors = True }
noIgnoreErrors_ :: Monad m => CondT (FileEntry f) m ()
noIgnoreErrors_ =
modifyFindOptions $ \opts -> opts { findIgnoreErrors = False }
maxdepth_ :: Monad m => Int -> CondT (FileEntry f) m ()
maxdepth_ l = getDepth >>= guard . (<= l)
mindepth_ :: Monad m => Int -> CondT (FileEntry f) m ()
mindepth_ l = getDepth >>= guard . (>= l)
timeComp :: MonadIO m
=> ((UTCTime -> Bool) -> CondT (FileEntry f) m ()) -> Int
-> CondT (FileEntry f) m ()
timeComp f n = do
now <- liftIO getCurrentTime
f (\t -> diffUTCTime now t > fromIntegral n)
amin_ :: MonadIO m => Int -> CondT (FileEntry f) m ()
amin_ n = timeComp lastAccessed_ (n * 60)
atime_ :: MonadIO m => Int -> CondT (FileEntry f) m ()
atime_ n = timeComp lastAccessed_ (n * 24 * 3600)
anewer_ :: (MonadIO m, IsFilePath f) => f -> CondT (FileEntry f) m ()
anewer_ path = do
e <- query
es <- applyStat Nothing
ms <- liftIO $ getStat Nothing
e { entryPath = getRawFilePath 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 f) m ()
empty_ = (regular >> hasStatus ((== 0) . fileSize))
`mplus` (directory >> hasStatus ((== 2) . linkCount))
executable_ :: MonadIO m => CondT (FileEntry f) m ()
executable_ = executable
gid_ :: MonadIO m => Int -> CondT (FileEntry f) m ()
gid_ n = hasStatus ((== n) . fromIntegral . fileGroup)
name_ :: (Monad m, IsFilePath f, Eq f) => f -> CondT (FileEntry f) m ()
name_ = filename_ . (==)
applyStat :: MonadIO m => Maybe Bool -> CondT (FileEntry f) m FileStatus
applyStat mfollow = do
ms <- liftIO . getStat mfollow =<< query
case ms of
Nothing -> prune >> error "This is never reached"
Just (s, e') -> const s `liftM` update e'
lstat :: MonadIO m => CondT (FileEntry f) m FileStatus
lstat = applyStat (Just False)
stat :: MonadIO m => CondT (FileEntry f) m FileStatus
stat = applyStat (Just True)
hasStatus :: MonadIO m => (FileStatus -> Bool) -> CondT (FileEntry f) m ()
hasStatus f = guard . f =<< applyStat Nothing
regular :: MonadIO m => CondT (FileEntry f) m ()
regular = hasStatus isRegularFile
executable :: MonadIO m => CondT (FileEntry f) m ()
executable = hasMode ownerExecuteMode
directory :: MonadIO m => CondT (FileEntry f) m ()
directory = hasStatus isDirectory
hasMode :: MonadIO m => FileMode -> CondT (FileEntry f) m ()
hasMode m = hasStatus (\s -> fileMode s .&. m /= 0)
withStatusTime :: MonadIO m
=> (FileStatus -> EpochTime) -> (UTCTime -> Bool)
-> CondT (FileEntry f) m ()
withStatusTime g f = hasStatus (f . posixSecondsToUTCTime . realToFrac . g)
lastAccessed_ :: MonadIO m => (UTCTime -> Bool) -> CondT (FileEntry f) m ()
lastAccessed_ = withStatusTime accessTime
lastModified_ :: MonadIO m => (UTCTime -> Bool) -> CondT (FileEntry f) m ()
lastModified_ = withStatusTime modificationTime
regex :: (Monad m, IsFilePath f) => String -> CondT (FileEntry f) m ()
regex pat = filename_ ((=~ pat) . getFilePath)
ignoreVcs :: (Monad m, IsString f, Eq f, IsFilePath f)
=> CondT (FileEntry f) m ()
ignoreVcs = when_ (filename_ (`elem` vcsDirs)) prune
where
vcsDirs = [ ".git", "CVS", "RCS", "SCCS", ".svn", ".hg", "_darcs" ]
glob :: (Monad m, IsString f, IsFilePath f, Monoid f)
=> String -> CondT (FileEntry f) m ()
glob g = case parseOnly globParser (pack g) of
Left e -> error $ "Failed to parse glob: " ++ e
Right x -> regex ("^" <> fromTextPath 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]
sourceFindFiles :: (MonadIO m, MonadSafe m, IsFilePath f)
=> FindOptions
-> f
-> CondT (FileEntry f) m a
-> Producer (FileEntry f, a) m ()
sourceFindFiles findOptions startPath =
walkChildren (newFileEntry (getRawFilePath startPath) 0 findOptions)
walkChildren :: MonadSafe m
=> FileEntry f
-> CondT (FileEntry f) m a
-> Producer (FileEntry f, a) m ()
walkChildren !entry !cond = do
let !path = B.snoc (entryPath entry) sep
!opts = entryFindOptions entry
!nextDepth = succ (entryDepth entry)
!worker = uncurry $ handleEntry opts path nextDepth cond
if findPreloadDirectories opts
then do
!fps <- liftIO $ getDirectoryContentsAndAttrs path
forM_ fps $ undefined (const Nothing) . worker
else
for (sourceDirectory path) worker
handleEntry :: MonadSafe m
=> FindOptions
-> RawFilePath
-> Int
-> CondT (FileEntry f) m a
-> RawFilePath
-> CUInt
-> Producer (FileEntry f, a) m ()
handleEntry opts path nextDepth cond !fp !typ = do
let childPath = B.append path fp
child = newFileEntry childPath nextDepth opts
((!mres, !mcond), !child') <- lift $ runCondT child cond
let opts' = entryFindOptions child'
this = case mres of
Nothing -> return ()
Just res
| findIgnoreResults opts' -> return ()
| otherwise -> yield (child', res)
that = case mcond of
Nothing -> return ()
Just !cond'
| typ == 10 ->
when (findFollowSymlinks opts) $ do
isDir <- liftIO $ statIsDirectory childPath
when isDir $ walkChildren child' cond'
| typ == 4 -> walkChildren child' cond'
| otherwise -> return ()
if findContentsFirst opts'
then that >> this
else this >> that
findFilesIO :: IsFilePath f
=> FindOptions -> f -> CondT (FileEntry f) IO a -> IO ()
findFilesIO findOptions startPath =
walkChildrenIO (newFileEntry (getRawFilePath startPath) 0 findOptions)
sep :: Word8
sep = fromIntegral (ord '/')
walkChildrenIO :: FileEntry f -> CondT (FileEntry f) IO a -> IO ()
walkChildrenIO !entry !cond = do
let !path = B.snoc (entryPath entry) sep
!opts = entryFindOptions entry
!nextDepth = entryDepth entry + 1
!fps <- getDirectoryContentsAndAttrs path
if findDepthFirst opts
then do
let f _ Nothing = return ()
f _ (Just x) = uncurry walkChildrenIO x
forM_ fps $ handleEntryIO opts path cond nextDepth (f ())
else do
let f acc Nothing = return acc
f acc (Just x) = return (x:acc)
dirs <- (\k -> foldM k [] fps) $ \acc ->
handleEntryIO opts path cond nextDepth (f acc)
forM_ dirs $ uncurry walkChildrenIO
handleEntryIO :: FindOptions
-> RawFilePath
-> CondT (FileEntry f) IO a
-> Int
-> (Maybe (FileEntry f, CondT (FileEntry f) IO a) -> IO b)
-> (RawFilePath, CUInt)
-> IO b
handleEntryIO opts path cond nextDepth f (!fp, !typ) = do
let !childPath = B.append path fp
!child = newFileEntry childPath nextDepth opts
((_, !mcond), !child') <- runCondT child cond
case mcond of
Nothing -> f Nothing
Just !cond'
| typ == 10 ->
if findFollowSymlinks opts
then do
isDir <- liftIO $ statIsDirectory childPath
f $ if isDir
then Just (child', cond')
else Nothing
else f Nothing
| typ == 4 -> f (Just (child', cond'))
| otherwise -> f Nothing
directoryFiles :: MonadIO m => FilePath -> TreeT m FilePath
directoryFiles path = CofreeT $ Select $ do
eres <- liftIO $ E.try $ getDirectoryContents path
case eres of
Left (_ :: IOException) -> return ()
Right entries ->
forM_ (filter (`notElem` [".", ".."]) entries) $ \entry -> do
let fullPath = path ++ "/" ++ entry
estat <- liftIO $ E.try $ getFileStatus fullPath
case estat of
Left (_ :: IOException) -> return ()
Right st ->
yield (fullPath :< if isDirectory st
then Just $ directoryFiles fullPath
else Nothing)
genericFindFiles
:: (MonadIO m, MonadBaseControl IO m,
MonadThrow m, MonadCatch m, MonadMask m, IsFilePath f)
=> FindOptions
-> f
-> CondT (FileEntry f) m a
-> m ()
genericFindFiles opts path predicate =
runSafeT $ runEffect $
sourceFindFiles opts { findIgnoreResults = True } path
(hoist lift predicate) >-> P.drain
genericFindFilePaths
:: (MonadIO m, MonadSafe m, IsFilePath f)
=> FindOptions
-> f
-> CondT (FileEntry f) m a
-> Producer f m ()
genericFindFilePaths opts path predicate =
sourceFindFiles opts path predicate
>-> P.map (fromRawFilePath . entryPath . fst)
genericFind :: (MonadIO m, MonadSafe m, IsFilePath f)
=> f -> CondT (FileEntry f) m a -> Producer f m ()
genericFind = genericFindFilePaths defaultFindOptions
genericTest :: (MonadIO m, IsFilePath f)
=> CondT (FileEntry f) m () -> f -> m Bool
genericTest matcher path =
Cond.test
(newFileEntry (getRawFilePath path) 0 defaultFindOptions
{ findFollowSymlinks = True })
matcher
genericLtest :: (MonadIO m, IsFilePath f)
=> CondT (FileEntry f) m () -> f -> m Bool
genericLtest matcher path =
Cond.test
(newFileEntry (getRawFilePath path) 0 defaultFindOptions)
matcher
findFiles :: (MonadIO m, MonadBaseControl IO m,
MonadThrow m, MonadCatch m, MonadMask m)
=> FindOptions
-> FilePath
-> CondT (FileEntry FilePath) m a
-> m ()
findFiles = genericFindFiles
findFilePaths :: (MonadIO m, MonadSafe m)
=> FindOptions
-> FilePath
-> CondT (FileEntry FilePath) m a
-> Producer FilePath m ()
findFilePaths = genericFindFilePaths
find :: (MonadIO m, MonadSafe m)
=> FilePath -> CondT (FileEntry FilePath) m a -> Producer FilePath m ()
find = genericFind
test :: MonadIO m => CondT (FileEntry FilePath) m () -> FilePath -> m Bool
test = genericTest
ltest :: MonadIO m => CondT (FileEntry FilePath) m () -> FilePath -> m Bool
ltest = genericLtest