From 1f571bc511a4a3b4591b1a6d0e74d79bf8677df2 Mon Sep 17 00:00:00 2001 From: Steven Shuck Date: Thu, 3 Jul 2025 17:50:55 -0400 Subject: [PATCH 1/4] Fix struct dirent d_type macro test Credit to Andrew Gunnerson (@chenxiaolong) --- cbits/HsUnix.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cbits/HsUnix.c b/cbits/HsUnix.c index 616f546..be46545 100644 --- a/cbits/HsUnix.c +++ b/cbits/HsUnix.c @@ -106,7 +106,7 @@ char *__hscore_d_name( struct dirent* d ) char __hscore_d_type( struct dirent* d ) { -#ifdef HAVE_DIRENT_D_TYPE +#ifdef HAVE_STRUCT_DIRENT_D_TYPE return (d->d_type); #else return CONST_DT_UNKNOWN; From c18caa05ad1d74f6fe6bc6c5635a499f5764c448 Mon Sep 17 00:00:00 2001 From: Steven Shuck Date: Thu, 3 Jul 2025 21:36:21 -0400 Subject: [PATCH 2/4] Add test for dirEntType --- tests/DirEnt.c | 49 +++++++++++++++++++++++++++++++++++++++++ tests/DirEnt.hs | 58 +++++++++++++++++++++++++++++++++++++++++++++++++ unix.cabal | 8 +++++++ 3 files changed, 115 insertions(+) create mode 100644 tests/DirEnt.c create mode 100644 tests/DirEnt.hs diff --git a/tests/DirEnt.c b/tests/DirEnt.c new file mode 100644 index 0000000..4afc237 --- /dev/null +++ b/tests/DirEnt.c @@ -0,0 +1,49 @@ +#include +#include +#include +#include +#include +#include + +void check_error(const char *msg) { + if (errno) { + perror(msg); + exit(1); + } +} + +int main() { + printf("Testing struct dirent d_type in C\n"); + + DIR *dir = opendir("."); + check_error("opendir"); + + struct dirent *de = NULL; + + do { + de = readdir(dir); + check_error("readdir"); + } while (de && strcmp(de->d_name, ".") != 0); + // We found the . dir or encountered end of dir stream + + int status = 0; + + if (!de) { + printf("Read the whole . dir without encountering \".\"!\n"); + status = 1; + } else if (de->d_type == DT_DIR) { + printf("Got DT_DIR for d_type for \".\"\n"); + } else if (de->d_type == DT_UNKNOWN) { + printf("Got DT_UNKNOWN for d_type for \".\"\n"); + // Signal that we should skip test for non-zero d_type + status = 2; + } else { + printf("Got %d for d_type for \".\"!\n", (int)de->d_type); + status = 1; + } + + closedir(dir); + check_error("closedir"); + + exit(status); +} diff --git a/tests/DirEnt.hs b/tests/DirEnt.hs new file mode 100644 index 0000000..f7e66ea --- /dev/null +++ b/tests/DirEnt.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE LambdaCase #-} + +module Main (main) where + +import Control.Exception (bracket, finally) +import Foreign.C.String (peekCString) +import System.Exit +import System.Posix.Directory +import System.Posix.Directory.Internals +import System.Process (system) + +system_x :: String -> IO ExitCode +system_x cmd = system $ "set -x; " ++ cmd + +onFailure :: IO ExitCode -> (ExitCode -> IO ()) -> IO () +action `onFailure` after = action >>= \case + ExitSuccess -> return () + ec -> after ec +infixr 9 `onFailure` + +prepareTest :: IO () +prepareTest = do + system_x "cc --version" `onFailure` exitWith + system_x "[ -f tests/DirEnt.c ]" `onFailure` \ec -> do + putStrLn "Not running tests from root of repo?" + exitWith ec + system_x "cc tests/DirEnt.c -o DirEnt-test" `onFailure` \_ -> do + putStrLn "d_type not available? Skipping Haskell test" + exitSuccess + -- As written, this C code exits with 2 if it determines the Haskell test + -- for broken dirEntType will be a false positive + system_x "./DirEnt-test" `onFailure` \case + ExitFailure 2 -> putStrLn "Skipping Haskell test" >> exitSuccess + ec -> exitWith ec + +peekDirEnt :: DirEnt -> IO (String, DirType) +peekDirEnt dirEnt = do + dName <- dirEntName dirEnt >>= peekCString + dType <- dirEntType dirEnt + return (dName, dType) + +testDirTypeOfDot :: DirStream -> IO () +testDirTypeOfDot dirStream = go where + go = readDirStreamWith peekDirEnt dirStream >>= \case + Just (".", DirectoryType) -> do + putStrLn "Got DirectoryType for . dir" + exitSuccess + Just (".", dType) -> die $ "Got " ++ show dType ++ " for . dir!" + Just _ -> go + Nothing -> die "Read cwd in Haskell and didn't find . dir!" + +main :: IO () +main = do + putStrLn "Preparing Haskell test of dirEntType" + prepareTest `finally` system_x "rm -f DirEnt-test" + + putStrLn "Running Haskell test of dirEntType" + bracket (openDirStream ".") closeDirStream testDirTypeOfDot diff --git a/unix.cabal b/unix.cabal index 7df7270..669c3cb 100644 --- a/unix.cabal +++ b/unix.cabal @@ -382,3 +382,11 @@ test-suite T13660 else build-depends: filepath >= 1.4.100.0 && < 1.5.0.0 ghc-options: -Wall + +test-suite DirEnt + hs-source-dirs: tests + main-is: DirEnt.hs + type: exitcode-stdio-1.0 + default-language: Haskell2010 + build-depends: base, unix, process + ghc-options: -Wall From ea507b6e0b36d95be9d9a2ff60d0c3555e7a9b71 Mon Sep 17 00:00:00 2001 From: Steven Shuck Date: Fri, 4 Jul 2025 00:27:17 -0400 Subject: [PATCH 3/4] Explain what tests/DirEnt.c is for --- tests/DirEnt.c | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/tests/DirEnt.c b/tests/DirEnt.c index 4afc237..a80f935 100644 --- a/tests/DirEnt.c +++ b/tests/DirEnt.c @@ -1,3 +1,27 @@ +/* + * The purpose of this C program is to do one of 4 things. Which one it does, + * indicates to the DirEnt test suite something it ought to do. + * + * fail to compile + * This means d_type is undefined. It should be enough to test for + * HAVE_STRUCT_DIRENT_D_TYPE, but this test suite came about because of + * https://github.com/haskell/unix/issues/347 which was caused by a + * misspelling of that macro, so we're testing it another way. + * Absence of d_type means the test suite ought to skip testing for non- + * DT_UNKNOWN values for d_type, since dirEntType returns UnknownType in this + * case. + * exit with status 0 + * This means the "." entry in the DIR stream opened at ".", guaranteed to be + * a directory, has a d_type of DT_DIR. We should proceed with a test for it + * in Haskell. + * exit with status 1 + * This means something unexpected went wrong. Fail the Haskell test also. + * exit with stauts 2 + * This means the "." entry has a d_type of DT_UNKNOWN. This is valid; no + * filesystem or operating system is required to yield a useful d_type. + * We should skip testing for non-DT_UNKNOWN values in Haskell. + */ + #include #include #include From 0935635ccfc930ef3da199f03bf287bcd9a2d9a6 Mon Sep 17 00:00:00 2001 From: Steven Shuck Date: Fri, 4 Jul 2025 22:14:13 -0400 Subject: [PATCH 4/4] Make dirEntType test Linux-only and check /proc/self for SymbolicLinkType /proc/self is guaranteed to exist as a symlink on Linux and procfs has emitted its d_type for decades. --- tests/DirEnt.c | 73 --------------------------------------------- tests/DirEnt.hs | 58 ----------------------------------- tests/DirEntType.hs | 33 ++++++++++++++++++++ unix.cabal | 10 +++++-- 4 files changed, 40 insertions(+), 134 deletions(-) delete mode 100644 tests/DirEnt.c delete mode 100644 tests/DirEnt.hs create mode 100644 tests/DirEntType.hs diff --git a/tests/DirEnt.c b/tests/DirEnt.c deleted file mode 100644 index a80f935..0000000 --- a/tests/DirEnt.c +++ /dev/null @@ -1,73 +0,0 @@ -/* - * The purpose of this C program is to do one of 4 things. Which one it does, - * indicates to the DirEnt test suite something it ought to do. - * - * fail to compile - * This means d_type is undefined. It should be enough to test for - * HAVE_STRUCT_DIRENT_D_TYPE, but this test suite came about because of - * https://github.com/haskell/unix/issues/347 which was caused by a - * misspelling of that macro, so we're testing it another way. - * Absence of d_type means the test suite ought to skip testing for non- - * DT_UNKNOWN values for d_type, since dirEntType returns UnknownType in this - * case. - * exit with status 0 - * This means the "." entry in the DIR stream opened at ".", guaranteed to be - * a directory, has a d_type of DT_DIR. We should proceed with a test for it - * in Haskell. - * exit with status 1 - * This means something unexpected went wrong. Fail the Haskell test also. - * exit with stauts 2 - * This means the "." entry has a d_type of DT_UNKNOWN. This is valid; no - * filesystem or operating system is required to yield a useful d_type. - * We should skip testing for non-DT_UNKNOWN values in Haskell. - */ - -#include -#include -#include -#include -#include -#include - -void check_error(const char *msg) { - if (errno) { - perror(msg); - exit(1); - } -} - -int main() { - printf("Testing struct dirent d_type in C\n"); - - DIR *dir = opendir("."); - check_error("opendir"); - - struct dirent *de = NULL; - - do { - de = readdir(dir); - check_error("readdir"); - } while (de && strcmp(de->d_name, ".") != 0); - // We found the . dir or encountered end of dir stream - - int status = 0; - - if (!de) { - printf("Read the whole . dir without encountering \".\"!\n"); - status = 1; - } else if (de->d_type == DT_DIR) { - printf("Got DT_DIR for d_type for \".\"\n"); - } else if (de->d_type == DT_UNKNOWN) { - printf("Got DT_UNKNOWN for d_type for \".\"\n"); - // Signal that we should skip test for non-zero d_type - status = 2; - } else { - printf("Got %d for d_type for \".\"!\n", (int)de->d_type); - status = 1; - } - - closedir(dir); - check_error("closedir"); - - exit(status); -} diff --git a/tests/DirEnt.hs b/tests/DirEnt.hs deleted file mode 100644 index f7e66ea..0000000 --- a/tests/DirEnt.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module Main (main) where - -import Control.Exception (bracket, finally) -import Foreign.C.String (peekCString) -import System.Exit -import System.Posix.Directory -import System.Posix.Directory.Internals -import System.Process (system) - -system_x :: String -> IO ExitCode -system_x cmd = system $ "set -x; " ++ cmd - -onFailure :: IO ExitCode -> (ExitCode -> IO ()) -> IO () -action `onFailure` after = action >>= \case - ExitSuccess -> return () - ec -> after ec -infixr 9 `onFailure` - -prepareTest :: IO () -prepareTest = do - system_x "cc --version" `onFailure` exitWith - system_x "[ -f tests/DirEnt.c ]" `onFailure` \ec -> do - putStrLn "Not running tests from root of repo?" - exitWith ec - system_x "cc tests/DirEnt.c -o DirEnt-test" `onFailure` \_ -> do - putStrLn "d_type not available? Skipping Haskell test" - exitSuccess - -- As written, this C code exits with 2 if it determines the Haskell test - -- for broken dirEntType will be a false positive - system_x "./DirEnt-test" `onFailure` \case - ExitFailure 2 -> putStrLn "Skipping Haskell test" >> exitSuccess - ec -> exitWith ec - -peekDirEnt :: DirEnt -> IO (String, DirType) -peekDirEnt dirEnt = do - dName <- dirEntName dirEnt >>= peekCString - dType <- dirEntType dirEnt - return (dName, dType) - -testDirTypeOfDot :: DirStream -> IO () -testDirTypeOfDot dirStream = go where - go = readDirStreamWith peekDirEnt dirStream >>= \case - Just (".", DirectoryType) -> do - putStrLn "Got DirectoryType for . dir" - exitSuccess - Just (".", dType) -> die $ "Got " ++ show dType ++ " for . dir!" - Just _ -> go - Nothing -> die "Read cwd in Haskell and didn't find . dir!" - -main :: IO () -main = do - putStrLn "Preparing Haskell test of dirEntType" - prepareTest `finally` system_x "rm -f DirEnt-test" - - putStrLn "Running Haskell test of dirEntType" - bracket (openDirStream ".") closeDirStream testDirTypeOfDot diff --git a/tests/DirEntType.hs b/tests/DirEntType.hs new file mode 100644 index 0000000..889bc6f --- /dev/null +++ b/tests/DirEntType.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE LambdaCase #-} + +module Main (main) where + +import Control.Exception (bracket) +import Foreign.C.String (peekCString) +import System.Exit (die) +import System.Posix.Directory +import System.Posix.Directory.Internals +import Text.Printf (printf) + +peekDirEnt :: DirEnt -> IO (String, DirType) +peekDirEnt dirEnt = do + dName <- dirEntName dirEnt >>= peekCString + dType <- dirEntType dirEnt + return (dName, dType) + +testDirTypeOfProcSelf :: DirStream -> IO () +testDirTypeOfProcSelf dirStream = go where + go = readDirStreamWith peekDirEnt dirStream >>= \case + Just (dName, dType) -> case dName of + "self" -> case dType of + SymbolicLinkType -> return () + _ -> die $ + printf "DirEnt of /proc/self has %s; expected %s!" + (show dType) + (show SymbolicLinkType) + _ -> go + Nothing -> die + "Didn't find \"self\" DirEnt while reading /proc DirStream!" + +main :: IO () +main = bracket (openDirStream "/proc") closeDirStream testDirTypeOfProcSelf diff --git a/unix.cabal b/unix.cabal index 669c3cb..e8ef1c2 100644 --- a/unix.cabal +++ b/unix.cabal @@ -383,10 +383,14 @@ test-suite T13660 build-depends: filepath >= 1.4.100.0 && < 1.5.0.0 ghc-options: -Wall -test-suite DirEnt +test-suite DirEntType + if !os(linux) + build-depends: unbuildable<0 + buildable: False + hs-source-dirs: tests - main-is: DirEnt.hs + main-is: DirEntType.hs type: exitcode-stdio-1.0 default-language: Haskell2010 - build-depends: base, unix, process + build-depends: base, unix ghc-options: -Wall