Added fallback behavior to 'readDirStreamWithType'

 * Changed the assignment of values for missing DT_* constants. Since
   the 'd_type' field is of type 'unsigned char' we assign a negative
   number for each missing DT_* constant so they are distinguishable but
   do not collide with the values from the libc implementation.
 * Added a new 'DirStreamWithPath' that contains the path of the
   directory the directory stream belongs to.
 * 'readDirStreamWithType' falls back to a 'stat' if the 'd_type' is
   unknown or undetermined.
 * Added some tests for 'readDirStreamWithType'.

Author: mmhat

System/Posix/Directory.hsc

@@ -28,7 +28,8 @@ module System.Posix.Directory (
    createDirectory, removeDirectory,
 
    -- * Reading directories
-   DirStream,
+   DirStream, DirStreamWithPath,
+   fromDirStreamWithPath,
    DirType( UnknownType
           , NamedPipeType
           , CharacterDeviceType
@@ -43,6 +44,7 @@ module System.Posix.Directory (
    isRegularFileType, isDirectoryType, isSymbolicLinkType, isSocketType,
    isWhiteoutType,
    openDirStream,
+   openDirStreamWithPath,
    readDirStream,
    readDirStreamMaybe,
    readDirStreamWithType,
@@ -63,12 +65,14 @@ module System.Posix.Directory (
   ) where
 
 import Data.Maybe
+import System.FilePath ((</>))
 import System.Posix.Error
 import System.Posix.Types
 import Foreign
 import Foreign.C
 
 import System.Posix.Directory.Common
+import System.Posix.Files
 import System.Posix.Internals (withFilePath, peekFilePath)
 
 -- | @createDirectory dir mode@ calls @mkdir@ to
@@ -92,6 +96,11 @@ openDirStream name =
     dirp <- throwErrnoPathIfNullRetry "openDirStream" name $ c_opendir s
     return (DirStream dirp)
 
+-- | A version of 'openDirStream' where the path of the directory is stored in
+-- the returned 'DirStreamWithPath'.
+openDirStreamWithPath :: FilePath -> IO (DirStreamWithPath FilePath)
+openDirStreamWithPath name = toDirStreamWithPath name <$> openDirStream name
+
 foreign import capi unsafe "HsUnix.h opendir"
    c_opendir :: CString  -> IO (Ptr CDir)
 
@@ -124,12 +133,15 @@ readDirStreamMaybe = readDirStreamWith
 --
 --   __Note__: The returned 'DirType' has some limitations; Please see its
 --   documentation.
-readDirStreamWithType :: DirStream -> IO (Maybe (FilePath, DirType))
-readDirStreamWithType = readDirStreamWith
-  (\(DirEnt dEnt) -> (,)
-    <$> (d_name dEnt >>= peekFilePath)
-    <*> (DirType <$> d_type dEnt)
+readDirStreamWithType :: DirStreamWithPath FilePath -> IO (Maybe (FilePath, DirType))
+readDirStreamWithType (DirStreamWithPath (base, ptr)) = readDirStreamWith
+  (\(DirEnt dEnt) -> do
+    name <- d_name dEnt >>= peekFilePath
+    let getStat = getFileStatus (base </> name)
+    dtype <- d_type dEnt >>= getRealDirType getStat . DirType
+    return (name, dtype)
   )
+  (DirStream ptr)
 
 foreign import ccall unsafe "__hscore_d_name"
   d_name :: Ptr CDirent -> IO CString

System/Posix/Directory/ByteString.hsc

@@ -1,5 +1,6 @@
 {-# LANGUAGE CApiFFI #-}
 {-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE Safe #-}
 
 -----------------------------------------------------------------------------
@@ -28,7 +29,8 @@ module System.Posix.Directory.ByteString (
    createDirectory, removeDirectory,
 
    -- * Reading directories
-   DirStream,
+   DirStream, DirStreamWithPath,
+   fromDirStreamWithPath,
    DirType( UnknownType
           , NamedPipeType
           , CharacterDeviceType
@@ -43,6 +45,7 @@ module System.Posix.Directory.ByteString (
    isRegularFileType, isDirectoryType, isSymbolicLinkType, isSocketType,
    isWhiteoutType,
    openDirStream,
+   openDirStreamWithPath,
    readDirStream,
    readDirStreamMaybe,
    readDirStreamWithType,
@@ -70,6 +73,7 @@ import Foreign.C
 import Data.ByteString.Char8 as BC
 
 import System.Posix.Directory.Common
+import System.Posix.Files.ByteString
 import System.Posix.ByteString.FilePath
 
 -- | @createDirectory dir mode@ calls @mkdir@ to
@@ -93,6 +97,11 @@ openDirStream name =
     dirp <- throwErrnoPathIfNullRetry "openDirStream" name $ c_opendir s
     return (DirStream dirp)
 
+-- | A version of 'openDirStream' where the path of the directory is stored in
+-- the returned 'DirStreamWithPath'.
+openDirStreamWithPath :: RawFilePath -> IO (DirStreamWithPath RawFilePath)
+openDirStreamWithPath name = toDirStreamWithPath name <$> openDirStream name
+
 foreign import capi unsafe "HsUnix.h opendir"
    c_opendir :: CString  -> IO (Ptr CDir)
 
@@ -125,12 +134,15 @@ readDirStreamMaybe = readDirStreamWith
 --
 --   __Note__: The returned 'DirType' has some limitations; Please see its
 --   documentation.
-readDirStreamWithType :: DirStream -> IO (Maybe (RawFilePath, DirType))
-readDirStreamWithType = readDirStreamWith
-  (\(DirEnt dEnt) -> (,)
-    <$> (d_name dEnt >>= peekFilePath)
-    <*> (DirType <$> d_type dEnt)
+readDirStreamWithType :: DirStreamWithPath RawFilePath -> IO (Maybe (RawFilePath, DirType))
+readDirStreamWithType (DirStreamWithPath (base, ptr)) = readDirStreamWith
+  (\(DirEnt dEnt) -> do
+    name <- d_name dEnt >>= peekFilePath
+    let getStat = getFileStatus (base <> "/" <> name)
+    dtype <- d_type dEnt >>= getRealDirType getStat . DirType
+    return (name, dtype)
   )
+  (DirStream ptr)
 
 foreign import ccall unsafe "__hscore_d_name"
   d_name :: Ptr CDirent -> IO CString

System/Posix/Directory/Common.hsc

@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, Safe, CApiFFI, PatternSynonyms #-}
+{-# LANGUAGE CPP, Safe, CApiFFI, MultiWayIf, PatternSynonyms #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -19,7 +19,9 @@
 ##include "HsUnixConfig.h"
 
 module System.Posix.Directory.Common (
-       DirStream(..), DirEnt(..), CDir, CDirent, DirStreamOffset(..),
+       DirStream(..), DirStreamWithPath(..),
+       fromDirStreamWithPath, toDirStreamWithPath,
+       DirEnt(..), CDir, CDirent, DirStreamOffset(..),
        DirType( DirType
               , UnknownType
               , NamedPipeType
@@ -34,6 +36,7 @@ module System.Posix.Directory.Common (
        isUnknownType, isBlockDeviceType, isCharacterDeviceType, isNamedPipeType,
        isRegularFileType, isDirectoryType, isSymbolicLinkType, isSocketType,
        isWhiteoutType,
+       getRealDirType,
        unsafeOpenDirStreamFd,
        readDirStreamWith,
        readDirStreamWithPtr,
@@ -59,8 +62,26 @@ import System.IO.Error ( ioeSetLocation )
 import GHC.IO.Exception ( unsupportedOperation )
 #endif
 
+import System.Posix.Files.Common
+
 newtype DirStream = DirStream (Ptr CDir)
 
+newtype DirStreamWithPath a = DirStreamWithPath (a, Ptr CDir)
+
+-- | Convert a 'DirStreamWithPath' to a 'DirStream'.
+-- Note that the underlying pointer is shared by both values, hence any
+-- modification to the resulting 'DirStream' will also modify the original
+-- 'DirStreamWithPath'.
+fromDirStreamWithPath :: DirStreamWithPath a -> DirStream
+fromDirStreamWithPath (DirStreamWithPath (_, ptr)) = DirStream ptr
+
+-- | Construct a 'DirStreamWithPath' from a 'DirStream'.
+-- Note that the underlying pointer is shared by both values, hence any
+-- modification to the pointer of the resulting 'DirStreamWithPath' will also
+-- modify the original 'DirStream'.
+toDirStreamWithPath :: a -> DirStream -> DirStreamWithPath a
+toDirStreamWithPath path (DirStream ptr) = DirStreamWithPath (path, ptr)
+
 newtype DirEnt = DirEnt (Ptr CDirent)
 
 -- We provide a hand-written instance here since GeneralizedNewtypeDeriving and
@@ -97,7 +118,7 @@ data {-# CTYPE "struct dirent" #-} CDirent
 -- case none of those patterns will match and the application must handle that
 -- case accordingly.
 newtype DirType = DirType CChar
-    deriving Eq
+    deriving (Eq, Ord, Show)
 
 -- | The 'DirType' refers to an entry of unknown type.
 pattern UnknownType :: DirType
@@ -164,6 +185,26 @@ isSymbolicLinkType dtype = dtype == SymbolicLinkType
 isSocketType dtype = dtype == SocketType
 isWhiteoutType dtype = dtype == WhiteoutType
 
+getRealDirType :: IO FileStatus -> DirType -> IO DirType
+getRealDirType _ BlockDeviceType = return BlockDeviceType
+getRealDirType _ CharacterDeviceType = return CharacterDeviceType
+getRealDirType _ NamedPipeType = return NamedPipeType
+getRealDirType _ RegularFileType = return RegularFileType
+getRealDirType _ DirectoryType = return DirectoryType
+getRealDirType _ SymbolicLinkType = return SymbolicLinkType
+getRealDirType _ SocketType = return SocketType
+getRealDirType _ WhiteoutType = return WhiteoutType
+getRealDirType getFileStatus _ = do
+    stat <- getFileStatus
+    return $ if | isBlockDevice stat -> BlockDeviceType
+                | isCharacterDevice stat -> CharacterDeviceType
+                | isNamedPipe stat -> NamedPipeType
+                | isRegularFile stat -> RegularFileType
+                | isDirectory stat -> DirectoryType
+                | isSymbolicLink stat -> SymbolicLinkType
+                | isSocket stat -> SocketType
+                | otherwise -> UnknownType
+
 -- | Call @fdopendir@ to obtain a directory stream for @fd@. @fd@ must not be
 -- otherwise used after this.
 --

System/Posix/Directory/PosixPath.hsc

@@ -27,7 +27,8 @@ module System.Posix.Directory.PosixPath (
    createDirectory, removeDirectory,
 
    -- * Reading directories
-   Common.DirStream,
+   Common.DirStream, Common.DirStreamWithPath,
+   Common.fromDirStreamWithPath,
    Common.DirType( UnknownType
                  , NamedPipeType
                  , CharacterDeviceType
@@ -42,6 +43,7 @@ module System.Posix.Directory.PosixPath (
    Common.isNamedPipeType, Common.isRegularFileType, Common.isDirectoryType,
    Common.isSymbolicLinkType, Common.isSocketType, Common.isWhiteoutType,
    openDirStream,
+   openDirStreamWithPath,
    readDirStream,
    readDirStreamMaybe,
    readDirStreamWithType,
@@ -66,8 +68,9 @@ import System.Posix.Types
 import Foreign
 import Foreign.C
 
-import System.OsPath.Types
+import System.OsPath.Posix
 import qualified System.Posix.Directory.Common as Common
+import System.Posix.Files.PosixString
 import System.Posix.PosixPath.FilePath
 
 -- | @createDirectory dir mode@ calls @mkdir@ to
@@ -91,6 +94,11 @@ openDirStream name =
     dirp <- throwErrnoPathIfNullRetry "openDirStream" name $ c_opendir s
     return (Common.DirStream dirp)
 
+-- | A version of 'openDirStream' where the path of the directory is stored in
+-- the returned 'DirStreamWithPath'.
+openDirStreamWithPath :: PosixPath -> IO (Common.DirStreamWithPath PosixPath)
+openDirStreamWithPath name = Common.toDirStreamWithPath name <$> openDirStream name
+
 foreign import capi unsafe "HsUnix.h opendir"
    c_opendir :: CString  -> IO (Ptr Common.CDir)
 
@@ -123,12 +131,15 @@ readDirStreamMaybe = Common.readDirStreamWith
 --
 --   __Note__: The returned 'DirType' has some limitations; Please see its
 --   documentation.
-readDirStreamWithType :: Common.DirStream -> IO (Maybe (PosixPath, Common.DirType))
-readDirStreamWithType = Common.readDirStreamWith
-  (\(Common.DirEnt dEnt) -> (,)
-    <$> (d_name dEnt >>= peekFilePath)
-    <*> (Common.DirType <$> d_type dEnt)
+readDirStreamWithType :: Common.DirStreamWithPath PosixPath -> IO (Maybe (PosixPath, Common.DirType))
+readDirStreamWithType (Common.DirStreamWithPath (base, ptr))= Common.readDirStreamWith
+  (\(Common.DirEnt dEnt) -> do
+    name <- d_name dEnt >>= peekFilePath
+    let getStat = getFileStatus (base </> name)
+    dtype <- d_type dEnt >>= Common.getRealDirType getStat . Common.DirType
+    return (name, dtype)
   )
+  (Common.DirStream ptr)
 
 foreign import ccall unsafe "__hscore_d_name"
   d_name :: Ptr Common.CDirent -> IO CString

configure.ac

@@ -28,10 +28,42 @@ AC_CHECK_HEADERS([bsd/libutil.h libutil.h pty.h utmp.h])
 AC_CHECK_HEADERS([termios.h time.h unistd.h utime.h])
 
 AC_STRUCT_DIRENT_D_TYPE
-FP_CHECK_CONSTS([DT_UNKNOWN DT_FIFO DT_CHR DT_DIR DT_BLK DT_REG DT_LNK DT_SOCK DT_WHT], [
+FP_CHECK_CONST([DT_UNKNOWN], [
 #if HAVE_STRUCT_DIRENT_D_TYPE
 #include <dirent.h>
-#endif])
+#endif], [-1])
+FP_CHECK_CONST([DT_FIFO], [
+#if HAVE_STRUCT_DIRENT_D_TYPE
+#include <dirent.h>
+#endif], [-2])
+FP_CHECK_CONST([DT_CHR], [
+#if HAVE_STRUCT_DIRENT_D_TYPE
+#include <dirent.h>
+#endif], [-3])
+FP_CHECK_CONST([DT_DIR], [
+#if HAVE_STRUCT_DIRENT_D_TYPE
+#include <dirent.h>
+#endif], [-4])
+FP_CHECK_CONST([DT_BLK], [
+#if HAVE_STRUCT_DIRENT_D_TYPE
+#include <dirent.h>
+#endif], [-5])
+FP_CHECK_CONST([DT_REG], [
+#if HAVE_STRUCT_DIRENT_D_TYPE
+#include <dirent.h>
+#endif], [-6])
+FP_CHECK_CONST([DT_LNK], [
+#if HAVE_STRUCT_DIRENT_D_TYPE
+#include <dirent.h>
+#endif], [-7])
+FP_CHECK_CONST([DT_SOCK], [
+#if HAVE_STRUCT_DIRENT_D_TYPE
+#include <dirent.h>
+#endif], [-8])
+FP_CHECK_CONST([DT_WHT], [
+#if HAVE_STRUCT_DIRENT_D_TYPE
+#include <dirent.h>
+#endif], [-9])
 
 AC_CHECK_FUNCS([getgrgid_r getgrnam_r getpwnam_r getpwuid_r getpwnam getpwuid])
 AC_CHECK_FUNCS([getpwent getgrent])

tests/ReadDirStream.hs

@@ -1,8 +1,10 @@
 module ReadDirStream
   ( emptyDirStream
   , nonEmptyDirStream
+  , dirStreamWithTypes
   ) where
 
+import qualified Data.List
 import System.Posix.Files
 import System.Posix.Directory
 import System.Posix.IO
@@ -33,6 +35,18 @@ nonEmptyDirStream = do
   cleanup
   entries @?= ["file"]
 
+dirStreamWithTypes :: IO ()
+dirStreamWithTypes = do
+  cleanup
+  createDirectory dir ownerModes
+  createDirectory (dir ++ "/somedir") ownerModes
+  _ <- createFile (dir ++ "/somefile") ownerReadMode
+  dir_p <- openDirStreamWithPath dir
+  entries <- readDirStreamEntriesWithTypes dir_p
+  closeDirStream (fromDirStreamWithPath dir_p)
+  cleanup
+  Data.List.sort entries @?= [("somedir", DirectoryType), ("somefile", RegularFileType)]
+
 readDirStreamEntries :: DirStream -> IO [FilePath]
 readDirStreamEntries dir_p = do
   ment <- readDirStreamMaybe dir_p
@@ -42,6 +56,15 @@ readDirStreamEntries dir_p = do
     Just ".." -> readDirStreamEntries dir_p
     Just ent -> (ent :) <$> readDirStreamEntries dir_p
 
+readDirStreamEntriesWithTypes :: DirStreamWithPath FilePath -> IO [(FilePath, DirType)]
+readDirStreamEntriesWithTypes dir_p = do
+  ment <- readDirStreamWithType dir_p
+  case ment of
+    Nothing -> return []
+    Just (".", _) -> readDirStreamEntriesWithTypes dir_p
+    Just ("..", _) -> readDirStreamEntriesWithTypes dir_p
+    Just ent -> (ent :) <$> readDirStreamEntriesWithTypes dir_p
+
 cleanup :: IO ()
 cleanup = do
     ignoreIOExceptions $ removeLink $ dir ++ "/file"