{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
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.Logic
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 Hierarchy
import Pipes
import Pipes.Files.Directory
import Pipes.Files.Types
import qualified Pipes.Prelude as P
import Pipes.Safe
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)
{-# INLINE sourceFindFiles #-}
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
{-# INLINE handleEntry #-}
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
{-# INLINE handleEntryIO #-}
directoryFiles :: (MonadPlus m, MonadIO m) => FilePath -> TreeT m FilePath
directoryFiles path = CofreeT $ do
Right entries <-
liftIO $ E.try @E.SomeException $ getDirectoryContents path
entry <- select (filter (`notElem` [".", ".."]) entries)
let fullPath = path ++ "/" ++ entry
Right st <- liftIO $ E.try @E.SomeException $ getFileStatus fullPath
pure $ 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
{-# INLINE genericFindFiles #-}
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)
{-# INLINE genericFindFilePaths #-}
genericFind :: (MonadIO m, MonadSafe m, IsFilePath f)
=> f -> CondT (FileEntry f) m a -> Producer f m ()
genericFind = genericFindFilePaths defaultFindOptions
{-# INLINE genericFind #-}
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
{-# INLINE genericLtest #-}
findFiles :: (MonadIO m, MonadBaseControl IO m,
MonadThrow m, MonadCatch m, MonadMask m)
=> FindOptions
-> FilePath
-> CondT (FileEntry FilePath) m a
-> m ()
findFiles = genericFindFiles
{-# INLINE findFiles #-}
findFilePaths :: (MonadIO m, MonadSafe m)
=> FindOptions
-> FilePath
-> CondT (FileEntry FilePath) m a
-> Producer FilePath m ()
findFilePaths = genericFindFilePaths
{-# INLINE findFilePaths #-}
find :: (MonadIO m, MonadSafe m)
=> FilePath -> CondT (FileEntry FilePath) m a -> Producer FilePath m ()
find = genericFind
{-# INLINE find #-}
test :: MonadIO m => CondT (FileEntry FilePath) m () -> FilePath -> m Bool
test = genericTest
ltest :: MonadIO m => CondT (FileEntry FilePath) m () -> FilePath -> m Bool
ltest = genericLtest