Add test for dirEntType

Author: sjshuck

tests/DirEnt.c

@@ -0,0 +1,49 @@
+#include <dirent.h>
+#include <errno.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <sys/types.h>
+
+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);
+}

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

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