-- |
-- Module      :  System.Posix.Directory.Traversals
-- Copyright   :  © 2016 Julian Ospald
-- License     :  BSD3
--
-- Maintainer  :  Julian Ospald <hasufell@posteo.de>
-- Stability   :  experimental
-- Portability :  portable
--
-- Traversal and read operations on directories.


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

{-# OPTIONS_GHC -Wall #-}


module System.Posix.Directory.Traversals (

  getDirectoryContents
, getDirectoryContents'

, allDirectoryContents
, allDirectoryContents'
, traverseDirectory

-- lower-level stuff
, readDirEnt
, packDirStream
, unpackDirStream
, fdOpendir

, realpath
) where


#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
import Control.Monad
import System.Posix.FilePath ((</>))
import System.Posix.Directory.Foreign

import qualified System.Posix as Posix
import System.IO.Error
import Control.Exception
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 System.IO.Unsafe
import "unix" System.Posix.IO.ByteString (closeFd)
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.
--
-- Follows symbolic links for the input dir.
allDirectoryContents :: RawFilePath -> IO [RawFilePath]
allDirectoryContents :: RawFilePath -> IO [RawFilePath]
allDirectoryContents topdir :: 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 -> 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
$ \(typ :: DirType
typ,name :: 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.
--
-- Follows symbolic links for the input dir.
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 s. (s -> RawFilePath -> IO s) -> s -> RawFilePath -> IO s
traverseDirectory (\acc :: [RawFilePath]
acc fp :: 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 directory and all
-- files/subdirectories.
--
-- This function allows for memory-efficient traversals.
--
-- Follows symbolic links for the input dir.
traverseDirectory :: (s -> RawFilePath -> IO s) -> s -> RawFilePath -> IO s
traverseDirectory :: (s -> RawFilePath -> IO s) -> s -> RawFilePath -> IO s
traverseDirectory act :: s -> RawFilePath -> IO s
act s0 :: s
s0 topdir :: RawFilePath
topdir = IO s
toploop
  where
    toploop :: IO s
toploop = 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
topdir
        s
s' <- s -> RawFilePath -> IO s
act s
s0 RawFilePath
topdir
        if Bool
isDir then RawFilePath -> s -> (DirType -> RawFilePath -> s -> IO s) -> IO s
forall b.
RawFilePath -> b -> (DirType -> RawFilePath -> b -> IO b) -> IO b
actOnDirContents RawFilePath
topdir s
s' DirType -> RawFilePath -> s -> IO s
loop
                 else s -> IO s
forall (m :: * -> *) a. Monad m => a -> m a
return s
s'
    loop :: DirType -> RawFilePath -> s -> IO s
loop typ :: DirType
typ path :: RawFilePath
path acc :: s
acc = do
        Bool
isDir <- 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 -> IO s
act s
acc RawFilePath
path IO s -> (s -> IO s) -> IO s
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \acc' :: s
acc' -> RawFilePath -> s -> (DirType -> RawFilePath -> s -> IO s) -> IO s
forall b.
RawFilePath -> b -> (DirType -> RawFilePath -> b -> IO b) -> IO b
actOnDirContents RawFilePath
path s
acc' DirType -> RawFilePath -> s -> IO s
loop
          else s -> RawFilePath -> IO s
act s
acc RawFilePath
path

actOnDirContents :: RawFilePath
                 -> b
                 -> (DirType -> RawFilePath -> b -> IO b)
                 -> IO b
actOnDirContents :: RawFilePath -> b -> (DirType -> RawFilePath -> b -> IO b) -> IO b
actOnDirContents pathRelToTop :: RawFilePath
pathRelToTop b :: b
b f :: DirType -> RawFilePath -> b -> IO b
f =
  (IOError -> IOError) -> IO b -> IO b
forall a. (IOError -> IOError) -> IO a -> IO a
modifyIOError ((IOError -> FilePath -> IOError
`ioeSetFileName` (RawFilePath -> FilePath
BS.unpack RawFilePath
pathRelToTop)) (IOError -> IOError) -> (IOError -> IOError) -> IOError -> IOError
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                 (IOError -> FilePath -> IOError
`ioeSetLocation` "findBSTypRel")) (IO b -> IO b) -> IO b -> IO b
forall a b. (a -> b) -> a -> b
$
    IO DirStream -> (DirStream -> IO ()) -> (DirStream -> IO b) -> IO b
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
      (RawFilePath -> IO DirStream
openDirStream RawFilePath
pathRelToTop)
      DirStream -> IO ()
Posix.closeDirStream
      (\dirp :: DirStream
dirp -> DirStream -> b -> IO b
loop DirStream
dirp b
b)
 where
  loop :: DirStream -> b -> IO b
loop dirp :: DirStream
dirp b' :: b
b' = do
    (typ :: DirType
typ,e :: RawFilePath
e) <- DirStream -> IO (DirType, RawFilePath)
readDirEnt DirStream
dirp
    if (RawFilePath
e RawFilePath -> RawFilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "")
      then b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
b'
      else
          if (RawFilePath
e RawFilePath -> RawFilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "." Bool -> Bool -> Bool
|| RawFilePath
e RawFilePath -> RawFilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "..")
              then DirStream -> b -> IO b
loop DirStream
dirp b
b'
              else DirType -> RawFilePath -> b -> IO b
f DirType
typ (RawFilePath
pathRelToTop RawFilePath -> RawFilePath -> RawFilePath
</> RawFilePath
e) b
b' IO b -> (b -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DirStream -> b -> IO b
loop DirStream
dirp


----------------------------------------------------------
-- 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.
foreign import ccall unsafe "__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

foreign import ccall unsafe "fdopendir"
  c_fdopendir :: Posix.Fd -> IO (Ptr ())

----------------------------------------------------------
-- 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_dEnt :: Ptr (Ptr ())
ptr_dEnt  -> Ptr (Ptr ()) -> IO (DirType, RawFilePath)
loop Ptr (Ptr ())
ptr_dEnt
 where
  loop :: Ptr (Ptr ()) -> IO (DirType, RawFilePath)
loop ptr_dEnt :: 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
== 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 eo :: CInt
eo) = Errno
errno
                 if (CInt
eo CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== 0)
                    then (DirType, RawFilePath) -> IO (DirType, RawFilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (DirType
dtUnknown,RawFilePath
BS.empty)
                    else FilePath -> IO (DirType, RawFilePath)
forall a. FilePath -> IO a
throwErrno "readDirEnt"


-- |Gets all directory contents (not recursively).
getDirectoryContents :: RawFilePath -> IO [(DirType, RawFilePath)]
getDirectoryContents :: RawFilePath -> IO [(DirType, RawFilePath)]
getDirectoryContents path :: RawFilePath
path =
  (IOError -> IOError)
-> IO [(DirType, RawFilePath)] -> IO [(DirType, RawFilePath)]
forall a. (IOError -> IOError) -> IO a -> IO a
modifyIOError ((IOError -> FilePath -> IOError
`ioeSetFileName` (RawFilePath -> FilePath
BS.unpack RawFilePath
path)) (IOError -> IOError) -> (IOError -> IOError) -> IOError -> IOError
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                 (IOError -> FilePath -> IOError
`ioeSetLocation` "System.Posix.Directory.Traversals.getDirectoryContents")) (IO [(DirType, RawFilePath)] -> IO [(DirType, RawFilePath)])
-> IO [(DirType, RawFilePath)] -> IO [(DirType, RawFilePath)]
forall a b. (a -> b) -> a -> b
$
    IO DirStream
-> (DirStream -> IO ())
-> (DirStream -> IO [(DirType, RawFilePath)])
-> IO [(DirType, RawFilePath)]
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
      (RawFilePath -> IO DirStream
PosixBS.openDirStream RawFilePath
path)
      DirStream -> IO ()
PosixBS.closeDirStream
      DirStream -> IO [(DirType, RawFilePath)]
_dirloop


-- |Binding to @fdopendir(3)@.
fdOpendir :: Posix.Fd -> IO DirStream
fdOpendir :: Fd -> IO DirStream
fdOpendir fd :: Fd
fd =
    Ptr () -> DirStream
packDirStream (Ptr () -> DirStream) -> IO (Ptr ()) -> IO DirStream
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Ptr ()) -> IO (Ptr ())
forall a. FilePath -> IO (Ptr a) -> IO (Ptr a)
throwErrnoIfNull "fdOpendir" (Fd -> IO (Ptr ())
c_fdopendir Fd
fd)


-- |Like `getDirectoryContents` except for a file descriptor.
--
-- To avoid complicated error checks, the file descriptor is
-- __always__ closed, even if `fdOpendir` fails. Usually, this
-- only happens on successful `fdOpendir` and after the directory
-- stream is closed. Also see the manpage of @fdopendir(3)@ for
-- more details.
getDirectoryContents' :: Posix.Fd -> IO [(DirType, RawFilePath)]
getDirectoryContents' :: Fd -> IO [(DirType, RawFilePath)]
getDirectoryContents' fd :: Fd
fd = do
  DirStream
dirstream <- Fd -> IO DirStream
fdOpendir Fd
fd IO DirStream -> (IOError -> IO DirStream) -> IO DirStream
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` \e :: IOError
e -> do
    Fd -> IO ()
closeFd Fd
fd
    IOError -> IO DirStream
forall a. IOError -> IO a
ioError IOError
e
  -- closeDirStream closes the filedescriptor
  IO [(DirType, RawFilePath)] -> IO () -> IO [(DirType, RawFilePath)]
forall a b. IO a -> IO b -> IO a
finally (DirStream -> IO [(DirType, RawFilePath)]
_dirloop DirStream
dirstream) (DirStream -> IO ()
PosixBS.closeDirStream DirStream
dirstream)


_dirloop :: DirStream -> IO [(DirType, RawFilePath)]
{-# INLINE _dirloop #-}
_dirloop :: DirStream -> IO [(DirType, RawFilePath)]
_dirloop dirp :: DirStream
dirp = do
   t :: (DirType, RawFilePath)
t@(_typ :: DirType
_typ,e :: RawFilePath
e) <- DirStream -> IO (DirType, RawFilePath)
readDirEnt DirStream
dirp
   if RawFilePath -> Bool
BS.null RawFilePath
e then [(DirType, RawFilePath)] -> IO [(DirType, RawFilePath)]
forall (m :: * -> *) a. Monad m => a -> m a
return [] else do
     [(DirType, RawFilePath)]
es <- DirStream -> IO [(DirType, RawFilePath)]
_dirloop DirStream
dirp
     [(DirType, RawFilePath)] -> IO [(DirType, RawFilePath)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((DirType, RawFilePath)
t(DirType, RawFilePath)
-> [(DirType, RawFilePath)] -> [(DirType, RawFilePath)]
forall a. a -> [a] -> [a]
:[(DirType, RawFilePath)]
es)


-- | return the canonicalized absolute pathname
--
-- like canonicalizePath, but uses @realpath(3)@
realpath :: RawFilePath -> IO RawFilePath
realpath :: RawFilePath -> IO RawFilePath
realpath inp :: RawFilePath
inp =
    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
$ \tmp :: 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
$ \cstr :: CString
cstr -> FilePath -> IO CString -> IO CString
forall a. FilePath -> IO (Ptr a) -> IO (Ptr a)
throwErrnoIfNull "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