{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_GHC -Wall #-}
module System.Posix.Directory.Traversals (

  getDirectoryContents
, traverseDirectoryContents

, allDirectoryContents
, allDirectoryContents'
, traverseDirectory

-- lower-level stuff
, 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

----------------------------------------------------------

-- | Get all files from a directory and its subdirectories.
--
-- Upon entering a directory, 'allDirectoryContents' will get all entries
-- strictly.  However the returned list is lazy in that directories will only
-- be accessed on demand.
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)

-- | Get all files from a directory and its subdirectories strictly.
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)) []
-- this uses traverseDirectory because it's more efficient than forcing the
-- lazy version.

-- | Recursively apply the 'action' to the parent file or directory and all
-- files/subdirectories.
--
-- Like UNIX @find@, this includes the parent file/directory!
--
-- As for @find@, emitted file paths of subdirectories contain slashes,
-- starting with the parent directory.
--
-- This function allows for memory-efficient traversals.
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

-- | `withRunInIO` lifted to `MonadUnliftIO`.
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)

----------------------------------------------------------
-- dodgy stuff

type CDir = ()
type CDirent = ()

-- Posix doesn't export DirStream, so to re-use that type we need to use
-- unsafeCoerce.  It's just a newtype, so this is a legitimate usage.
-- ugly trick.
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

-- the __hscore_* functions are defined in the unix package.  We can import them and let
-- the linker figure it out.
--
-- In contrast to current `unix` we use `safe` calls for anything that
-- does file system IO, because it can take a substantial amount of time
-- on spinning disks or networked file systems, and `unsafe` calls block
-- a capability.
-- See https://github.com/haskell/unix/issues/34.
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

----------------------------------------------------------
-- less dodgy but still lower-level

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"

-- | Apply the 'action' to the given directory (must be a directory),
-- without recursing into subdirectories.
--
-- This function does filter out the @.@ and @..@ entries.
--
-- Emitted file paths are the directory entry names,
-- thus not prefixed with the given parent directory.
--
-- This function allows for memory-efficient traversals.
--
-- Use this if you want to implement your own recursive subdirectory
-- traversal, deciding e.g. into which directories or symlinks to traverse.
--
-- You SHOULD check if the obtained 'DirType'
-- is 'System.Posix.Directory.Foreign.dtUnknown'
-- (see comments in @man 3 readdir@ on @d_type@),
-- and do a 'System.Posix.Files.ByteString.getFileStatus'
-- in that case (results in @stat()@), as not all file systems
-- implement obtaining a 'DirType'.
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

-- | return the canonicalized absolute pathname
--
-- like canonicalizePath, but uses realpath(3)
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