{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wall #-}
module System.Posix.Directory.Traversals (
getDirectoryContents
, traverseDirectoryContents
, allDirectoryContents
, allDirectoryContents'
, traverseDirectory
, readDirEnt
, packDirStream
, unpackDirStream
, realpath
) where
import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import System.Posix.FilePath ((</>))
import System.Posix.Directory.Foreign
import qualified System.Posix as Posix
import System.IO.Error
import qualified Data.ByteString.Char8 as BS
import System.Posix.ByteString.FilePath
import System.Posix.Directory.ByteString as PosixBS
import System.Posix.Files.ByteString
import UnliftIO (MonadUnliftIO, withRunInIO)
import UnliftIO.Exception
import System.IO.Unsafe
import Unsafe.Coerce (unsafeCoerce)
import Foreign.C.Error
import Foreign.C.String
import Foreign.C.Types
import Foreign.Marshal.Alloc (alloca,allocaBytes)
import Foreign.Ptr
import Foreign.Storable
allDirectoryContents :: RawFilePath -> IO [RawFilePath]
allDirectoryContents :: RawFilePath -> IO [RawFilePath]
allDirectoryContents RawFilePath
topdir = do
[(DirType, RawFilePath)]
namesAndTypes <- RawFilePath -> IO [(DirType, RawFilePath)]
getDirectoryContents RawFilePath
topdir
let properNames :: [(DirType, RawFilePath)]
properNames = ((DirType, RawFilePath) -> Bool)
-> [(DirType, RawFilePath)] -> [(DirType, RawFilePath)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((RawFilePath -> [RawFilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [RawFilePath
".", RawFilePath
".."]) (RawFilePath -> Bool)
-> ((DirType, RawFilePath) -> RawFilePath)
-> (DirType, RawFilePath)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DirType, RawFilePath) -> RawFilePath
forall a b. (a, b) -> b
snd) [(DirType, RawFilePath)]
namesAndTypes
[[RawFilePath]]
paths <- [(DirType, RawFilePath)]
-> ((DirType, RawFilePath) -> IO [RawFilePath])
-> IO [[RawFilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(DirType, RawFilePath)]
properNames (((DirType, RawFilePath) -> IO [RawFilePath])
-> IO [[RawFilePath]])
-> ((DirType, RawFilePath) -> IO [RawFilePath])
-> IO [[RawFilePath]]
forall a b. (a -> b) -> a -> b
$ \(DirType
typ,RawFilePath
name) -> IO [RawFilePath] -> IO [RawFilePath]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [RawFilePath] -> IO [RawFilePath])
-> IO [RawFilePath] -> IO [RawFilePath]
forall a b. (a -> b) -> a -> b
$ do
let path :: RawFilePath
path = RawFilePath
topdir RawFilePath -> RawFilePath -> RawFilePath
</> RawFilePath
name
case () of
() | DirType
typ DirType -> DirType -> Bool
forall a. Eq a => a -> a -> Bool
== DirType
dtDir -> RawFilePath -> IO [RawFilePath]
allDirectoryContents RawFilePath
path
| DirType
typ DirType -> DirType -> Bool
forall a. Eq a => a -> a -> Bool
== DirType
dtUnknown -> do
Bool
isDir <- FileStatus -> Bool
isDirectory (FileStatus -> Bool) -> IO FileStatus -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawFilePath -> IO FileStatus
getFileStatus RawFilePath
path
if Bool
isDir
then RawFilePath -> IO [RawFilePath]
allDirectoryContents RawFilePath
path
else [RawFilePath] -> IO [RawFilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [RawFilePath
path]
| Bool
otherwise -> [RawFilePath] -> IO [RawFilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [RawFilePath
path]
[RawFilePath] -> IO [RawFilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return (RawFilePath
topdir RawFilePath -> [RawFilePath] -> [RawFilePath]
forall a. a -> [a] -> [a]
: [[RawFilePath]] -> [RawFilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[RawFilePath]]
paths)
allDirectoryContents' :: RawFilePath -> IO [RawFilePath]
allDirectoryContents' :: RawFilePath -> IO [RawFilePath]
allDirectoryContents' = ([RawFilePath] -> [RawFilePath])
-> IO [RawFilePath] -> IO [RawFilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [RawFilePath] -> [RawFilePath]
forall a. [a] -> [a]
reverse (IO [RawFilePath] -> IO [RawFilePath])
-> (RawFilePath -> IO [RawFilePath])
-> RawFilePath
-> IO [RawFilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([RawFilePath] -> RawFilePath -> IO [RawFilePath])
-> [RawFilePath] -> RawFilePath -> IO [RawFilePath]
forall (m :: * -> *) s.
MonadUnliftIO m =>
(s -> RawFilePath -> m s) -> s -> RawFilePath -> m s
traverseDirectory (\[RawFilePath]
acc RawFilePath
fp -> [RawFilePath] -> IO [RawFilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return (RawFilePath
fpRawFilePath -> [RawFilePath] -> [RawFilePath]
forall a. a -> [a] -> [a]
:[RawFilePath]
acc)) []
traverseDirectory :: (MonadUnliftIO m) => (s -> RawFilePath -> m s) -> s -> RawFilePath -> m s
traverseDirectory :: (s -> RawFilePath -> m s) -> s -> RawFilePath -> m s
traverseDirectory s -> RawFilePath -> m s
act s
s0 RawFilePath
topDirOrFile = m s
toploop
where
toploop :: m s
toploop = do
Bool
isDir <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FileStatus -> Bool
isDirectory (FileStatus -> Bool) -> IO FileStatus -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawFilePath -> IO FileStatus
getFileStatus RawFilePath
topDirOrFile
s
s' <- s -> RawFilePath -> m s
act s
s0 RawFilePath
topDirOrFile
if Bool
isDir then RawFilePath -> s -> (DirType -> RawFilePath -> s -> m s) -> m s
forall (m :: * -> *) b.
MonadUnliftIO m =>
RawFilePath -> b -> (DirType -> RawFilePath -> b -> m b) -> m b
actOnDirContents RawFilePath
topDirOrFile s
s' DirType -> RawFilePath -> s -> m s
loop
else s -> m s
forall (m :: * -> *) a. Monad m => a -> m a
return s
s'
loop :: DirType -> RawFilePath -> s -> m s
loop DirType
typ RawFilePath
path s
acc = do
Bool
isDir <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ case () of
() | DirType
typ DirType -> DirType -> Bool
forall a. Eq a => a -> a -> Bool
== DirType
dtDir -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
| DirType
typ DirType -> DirType -> Bool
forall a. Eq a => a -> a -> Bool
== DirType
dtUnknown -> FileStatus -> Bool
isDirectory (FileStatus -> Bool) -> IO FileStatus -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawFilePath -> IO FileStatus
getFileStatus RawFilePath
path
| Bool
otherwise -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
if Bool
isDir
then s -> RawFilePath -> m s
act s
acc RawFilePath
path m s -> (s -> m s) -> m s
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \s
acc' -> RawFilePath -> s -> (DirType -> RawFilePath -> s -> m s) -> m s
forall (m :: * -> *) b.
MonadUnliftIO m =>
RawFilePath -> b -> (DirType -> RawFilePath -> b -> m b) -> m b
actOnDirContents RawFilePath
path s
acc' DirType -> RawFilePath -> s -> m s
loop
else s -> RawFilePath -> m s
act s
acc RawFilePath
path
actOnDirContents :: (MonadUnliftIO m)
=> RawFilePath
-> b
-> (DirType -> RawFilePath -> b -> m b)
-> m b
actOnDirContents :: RawFilePath -> b -> (DirType -> RawFilePath -> b -> m b) -> m b
actOnDirContents RawFilePath
pathRelToTop b
b DirType -> RawFilePath -> b -> m b
f =
(b -> (DirType, RawFilePath) -> m b) -> b -> RawFilePath -> m b
forall (m :: * -> *) s.
MonadUnliftIO m =>
(s -> (DirType, RawFilePath) -> m s) -> s -> RawFilePath -> m s
traverseDirectoryContents
(\b
b' (DirType
typ, RawFilePath
e) -> DirType -> RawFilePath -> b -> m b
f DirType
typ (RawFilePath
pathRelToTop RawFilePath -> RawFilePath -> RawFilePath
</> RawFilePath
e) b
b')
b
b
RawFilePath
pathRelToTop
modifyIOErrorUnliftIO :: (MonadUnliftIO m) => (IOError -> IOError) -> m a -> m a
modifyIOErrorUnliftIO :: (IOError -> IOError) -> m a -> m a
modifyIOErrorUnliftIO IOError -> IOError
f m a
action =
((forall a. m a -> IO a) -> IO a) -> m a
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO -> do
(IOError -> IOError) -> IO a -> IO a
forall a. (IOError -> IOError) -> IO a -> IO a
modifyIOError IOError -> IOError
f (m a -> IO a
forall a. m a -> IO a
runInIO m a
action)
type CDir = ()
type CDirent = ()
unpackDirStream :: DirStream -> Ptr CDir
unpackDirStream :: DirStream -> Ptr ()
unpackDirStream = DirStream -> Ptr ()
forall a b. a -> b
unsafeCoerce
packDirStream :: Ptr CDir -> DirStream
packDirStream :: Ptr () -> DirStream
packDirStream = Ptr () -> DirStream
forall a b. a -> b
unsafeCoerce
foreign import ccall safe "__hscore_readdir"
c_readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt
foreign import ccall unsafe "__hscore_free_dirent"
c_freeDirEnt :: Ptr CDirent -> IO ()
foreign import ccall unsafe "__hscore_d_name"
c_name :: Ptr CDirent -> IO CString
foreign import ccall unsafe "__posixdir_d_type"
c_type :: Ptr CDirent -> IO DirType
foreign import ccall "realpath"
c_realpath :: CString -> CString -> IO CString
readDirEnt :: DirStream -> IO (DirType, RawFilePath)
readDirEnt :: DirStream -> IO (DirType, RawFilePath)
readDirEnt (DirStream -> Ptr ()
unpackDirStream -> Ptr ()
dirp) =
(Ptr (Ptr ()) -> IO (DirType, RawFilePath))
-> IO (DirType, RawFilePath)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr (Ptr ()) -> IO (DirType, RawFilePath))
-> IO (DirType, RawFilePath))
-> (Ptr (Ptr ()) -> IO (DirType, RawFilePath))
-> IO (DirType, RawFilePath)
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr ())
ptr_dEnt -> Ptr (Ptr ()) -> IO (DirType, RawFilePath)
loop Ptr (Ptr ())
ptr_dEnt
where
loop :: Ptr (Ptr ()) -> IO (DirType, RawFilePath)
loop Ptr (Ptr ())
ptr_dEnt = do
IO ()
resetErrno
CInt
r <- Ptr () -> Ptr (Ptr ()) -> IO CInt
c_readdir Ptr ()
dirp Ptr (Ptr ())
ptr_dEnt
if (CInt
r CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0)
then do
Ptr ()
dEnt <- Ptr (Ptr ()) -> IO (Ptr ())
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr ())
ptr_dEnt
if (Ptr ()
dEnt Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
nullPtr)
then (DirType, RawFilePath) -> IO (DirType, RawFilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (DirType
dtUnknown,RawFilePath
BS.empty)
else do
RawFilePath
dName <- Ptr () -> IO CString
c_name Ptr ()
dEnt IO CString -> (CString -> IO RawFilePath) -> IO RawFilePath
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CString -> IO RawFilePath
peekFilePath
DirType
dType <- Ptr () -> IO DirType
c_type Ptr ()
dEnt
Ptr () -> IO ()
c_freeDirEnt Ptr ()
dEnt
(DirType, RawFilePath) -> IO (DirType, RawFilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (DirType
dType, RawFilePath
dName)
else do
Errno
errno <- IO Errno
getErrno
if (Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eINTR)
then Ptr (Ptr ()) -> IO (DirType, RawFilePath)
loop Ptr (Ptr ())
ptr_dEnt
else do
let (Errno CInt
eo) = Errno
errno
if (CInt
eo CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0)
then (DirType, RawFilePath) -> IO (DirType, RawFilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (DirType
dtUnknown,RawFilePath
BS.empty)
else String -> IO (DirType, RawFilePath)
forall a. String -> IO a
throwErrno String
"readDirEnt"
traverseDirectoryContents :: (MonadUnliftIO m) => (s -> (DirType, RawFilePath) -> m s) -> s -> RawFilePath -> m s
traverseDirectoryContents :: (s -> (DirType, RawFilePath) -> m s) -> s -> RawFilePath -> m s
traverseDirectoryContents s -> (DirType, RawFilePath) -> m s
act s
state RawFilePath
path =
(IOError -> IOError) -> m s -> m s
forall (m :: * -> *) a.
MonadUnliftIO m =>
(IOError -> IOError) -> m a -> m a
modifyIOErrorUnliftIO
((IOError -> String -> IOError
`ioeSetFileName` (RawFilePath -> String
BS.unpack RawFilePath
path)) (IOError -> IOError) -> (IOError -> IOError) -> IOError -> IOError
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(IOError -> String -> IOError
`ioeSetLocation` String
"System.Posix.Directory.Traversals.traverseDirectoryContents")) (m s -> m s) -> m s -> m s
forall a b. (a -> b) -> a -> b
$ do
m DirStream -> (DirStream -> m ()) -> (DirStream -> m s) -> m s
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
(IO DirStream -> m DirStream
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DirStream -> m DirStream) -> IO DirStream -> m DirStream
forall a b. (a -> b) -> a -> b
$ RawFilePath -> IO DirStream
PosixBS.openDirStream RawFilePath
path)
(IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (DirStream -> IO ()) -> DirStream -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DirStream -> IO ()
PosixBS.closeDirStream)
(\DirStream
dirp -> s -> DirStream -> m s
loop s
state DirStream
dirp)
where
loop :: s -> DirStream -> m s
loop s
state0 DirStream
dirp = do
t :: (DirType, RawFilePath)
t@(DirType
_typ,RawFilePath
e) <- IO (DirType, RawFilePath) -> m (DirType, RawFilePath)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (DirType, RawFilePath) -> m (DirType, RawFilePath))
-> IO (DirType, RawFilePath) -> m (DirType, RawFilePath)
forall a b. (a -> b) -> a -> b
$ DirStream -> IO (DirType, RawFilePath)
readDirEnt DirStream
dirp
if RawFilePath -> Bool
BS.null RawFilePath
e then s -> m s
forall (m :: * -> *) a. Monad m => a -> m a
return s
state0 else do
if (RawFilePath
e RawFilePath -> RawFilePath -> Bool
forall a. Eq a => a -> a -> Bool
== RawFilePath
"." Bool -> Bool -> Bool
|| RawFilePath
e RawFilePath -> RawFilePath -> Bool
forall a. Eq a => a -> a -> Bool
== RawFilePath
"..")
then s -> DirStream -> m s
loop s
state0 DirStream
dirp
else do
s
state1 <- s -> (DirType, RawFilePath) -> m s
act s
state0 (DirType, RawFilePath)
t
s -> DirStream -> m s
loop s
state1 DirStream
dirp
getDirectoryContents :: RawFilePath -> IO [(DirType, RawFilePath)]
getDirectoryContents :: RawFilePath -> IO [(DirType, RawFilePath)]
getDirectoryContents RawFilePath
path =
([(DirType, RawFilePath)]
-> (DirType, RawFilePath) -> IO [(DirType, RawFilePath)])
-> [(DirType, RawFilePath)]
-> RawFilePath
-> IO [(DirType, RawFilePath)]
forall (m :: * -> *) s.
MonadUnliftIO m =>
(s -> (DirType, RawFilePath) -> m s) -> s -> RawFilePath -> m s
traverseDirectoryContents (\[(DirType, RawFilePath)]
l (DirType, RawFilePath)
e -> [(DirType, RawFilePath)] -> IO [(DirType, RawFilePath)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((DirType, RawFilePath)
e(DirType, RawFilePath)
-> [(DirType, RawFilePath)] -> [(DirType, RawFilePath)]
forall a. a -> [a] -> [a]
:[(DirType, RawFilePath)]
l)) [] RawFilePath
path
realpath :: RawFilePath -> IO RawFilePath
realpath :: RawFilePath -> IO RawFilePath
realpath RawFilePath
inp = do
Int -> (CString -> IO RawFilePath) -> IO RawFilePath
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
pathMax ((CString -> IO RawFilePath) -> IO RawFilePath)
-> (CString -> IO RawFilePath) -> IO RawFilePath
forall a b. (a -> b) -> a -> b
$ \CString
tmp -> do
IO CString -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CString -> IO ()) -> IO CString -> IO ()
forall a b. (a -> b) -> a -> b
$ RawFilePath -> (CString -> IO CString) -> IO CString
forall a. RawFilePath -> (CString -> IO a) -> IO a
BS.useAsCString RawFilePath
inp ((CString -> IO CString) -> IO CString)
-> (CString -> IO CString) -> IO CString
forall a b. (a -> b) -> a -> b
$ \CString
cstr -> String -> IO CString -> IO CString
forall a. String -> IO (Ptr a) -> IO (Ptr a)
throwErrnoIfNull String
"realpath" (IO CString -> IO CString) -> IO CString -> IO CString
forall a b. (a -> b) -> a -> b
$ CString -> CString -> IO CString
c_realpath CString
cstr CString
tmp
CString -> IO RawFilePath
BS.packCString CString
tmp