Add PosixFilePath and friends support (for AFPP)

.github/workflows/ci.yml

@@ -108,7 +108,7 @@ jobs:
     steps:
     - uses: actions/checkout@v2
     - uses: uraimo/run-on-arch-action@v2.1.1
-      timeout-minutes: 60
+      timeout-minutes: 120
       with:
         arch: ${{ matrix.arch }}
         distro: ubuntu20.04

System/Posix/Directory/PosixPath.hsc

@@ -0,0 +1,166 @@
+{-# LANGUAGE CApiFFI #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Directory.PosixPath
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- PosixPath based POSIX directory support
+--
+-----------------------------------------------------------------------------
+
+#include "HsUnix.h"
+
+-- hack copied from System.Posix.Files
+#if !defined(PATH_MAX)
+# define PATH_MAX 4096
+#endif
+
+module System.Posix.Directory.PosixPath (
+   -- * Creating and removing directories
+   createDirectory, removeDirectory,
+
+   -- * Reading directories
+   DirStream,
+   openDirStream,
+   readDirStream,
+   rewindDirStream,
+   closeDirStream,
+   DirStreamOffset,
+#ifdef HAVE_TELLDIR
+   tellDirStream,
+#endif
+#ifdef HAVE_SEEKDIR
+   seekDirStream,
+#endif
+
+   -- * The working directory
+   getWorkingDirectory,
+   changeWorkingDirectory,
+   changeWorkingDirectoryFd,
+  ) where
+
+import System.IO.Error
+import System.Posix.Types
+import Foreign
+import Foreign.C
+
+import System.OsPath.Types
+import GHC.IO.Encoding.UTF8 ( mkUTF8 )
+import GHC.IO.Encoding.Failure ( CodingFailureMode(..) )
+import System.OsPath.Posix
+import System.Posix.Directory hiding (createDirectory, openDirStream, readDirStream, getWorkingDirectory, changeWorkingDirectory, removeDirectory)
+import qualified System.Posix.Directory.Common as Common
+import System.Posix.PosixPath.FilePath
+
+-- | @createDirectory dir mode@ calls @mkdir@ to
+--   create a new directory, @dir@, with permissions based on
+--  @mode@.
+createDirectory :: PosixPath -> FileMode -> IO ()
+createDirectory name mode =
+  withFilePath name $ \s ->
+    throwErrnoPathIfMinus1Retry_ "createDirectory" name (c_mkdir s mode)
+    -- POSIX doesn't allow mkdir() to return EINTR, but it does on
+    -- OS X (#5184), so we need the Retry variant here.
+
+foreign import ccall unsafe "mkdir"
+  c_mkdir :: CString -> CMode -> IO CInt
+
+-- | @openDirStream dir@ calls @opendir@ to obtain a
+--   directory stream for @dir@.
+openDirStream :: PosixPath -> IO DirStream
+openDirStream name =
+  withFilePath name $ \s -> do
+    dirp <- throwErrnoPathIfNullRetry "openDirStream" name $ c_opendir s
+    return (Common.DirStream dirp)
+
+foreign import capi unsafe "HsUnix.h opendir"
+   c_opendir :: CString  -> IO (Ptr Common.CDir)
+
+-- | @readDirStream dp@ calls @readdir@ to obtain the
+--   next directory entry (@struct dirent@) for the open directory
+--   stream @dp@, and returns the @d_name@ member of that
+--  structure.
+readDirStream :: DirStream -> IO PosixPath
+readDirStream (Common.DirStream dirp) = alloca $ \ptr_dEnt  -> loop ptr_dEnt
+ where
+  loop ptr_dEnt = do
+    resetErrno
+    r <- c_readdir dirp ptr_dEnt
+    if (r == 0)
+         then do dEnt <- peek ptr_dEnt
+                 if (dEnt == nullPtr)
+                    then return mempty
+                    else do
+                     entry <- (d_name dEnt >>= peekFilePath)
+                     c_freeDirEnt dEnt
+                     return entry
+         else do errno <- getErrno
+                 if (errno == eINTR) then loop ptr_dEnt else do
+                 let (Errno eo) = errno
+                 if (eo == 0)
+                    then return mempty
+                    else throwErrno "readDirStream"
+
+-- traversing directories
+foreign import ccall unsafe "__hscore_readdir"
+  c_readdir  :: Ptr Common.CDir -> Ptr (Ptr Common.CDirent) -> IO CInt
+
+foreign import ccall unsafe "__hscore_free_dirent"
+  c_freeDirEnt  :: Ptr Common.CDirent -> IO ()
+
+foreign import ccall unsafe "__hscore_d_name"
+  d_name :: Ptr Common.CDirent -> IO CString
+
+
+-- | @getWorkingDirectory@ calls @getcwd@ to obtain the name
+--   of the current working directory.
+getWorkingDirectory :: IO PosixPath
+getWorkingDirectory = go (#const PATH_MAX)
+  where
+    go bytes = do
+        r <- allocaBytes bytes $ \buf -> do
+            buf' <- c_getcwd buf (fromIntegral bytes)
+            if buf' /= nullPtr
+                then do s <- peekFilePath buf
+                        return (Just s)
+                else do errno <- getErrno
+                        if errno == eRANGE
+                            -- we use Nothing to indicate that we should
+                            -- try again with a bigger buffer
+                            then return Nothing
+                            else throwErrno "getWorkingDirectory"
+        maybe (go (2 * bytes)) return r
+
+foreign import ccall unsafe "getcwd"
+   c_getcwd   :: Ptr CChar -> CSize -> IO (Ptr CChar)
+
+-- | @changeWorkingDirectory dir@ calls @chdir@ to change
+--   the current working directory to @dir@.
+changeWorkingDirectory :: PosixPath -> IO ()
+changeWorkingDirectory path =
+  modifyIOError (`ioeSetFileName` (_toStr path)) $
+    withFilePath path $ \s ->
+       throwErrnoIfMinus1Retry_ "changeWorkingDirectory" (c_chdir s)
+
+foreign import ccall unsafe "chdir"
+   c_chdir :: CString -> IO CInt
+
+removeDirectory :: PosixPath -> IO ()
+removeDirectory path =
+  modifyIOError (`ioeSetFileName` _toStr path) $
+    withFilePath path $ \s ->
+       throwErrnoIfMinus1Retry_ "removeDirectory" (c_rmdir s)
+
+foreign import ccall unsafe "rmdir"
+   c_rmdir :: CString -> IO CInt
+
+_toStr :: PosixPath -> String
+_toStr fp = either (error . show) id $ decodeWith (mkUTF8 TransliterateCodingFailure) fp
+

System/Posix/Env/PosixString.hsc

@@ -0,0 +1,206 @@
+{-# LANGUAGE CApiFFI #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Env.PosixString
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX environment support
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.Env.PosixString (
+       -- * Environment Variables
+        getEnv
+        , getEnvDefault
+        , getEnvironmentPrim
+        , getEnvironment
+        , setEnvironment
+        , putEnv
+        , setEnv
+        , unsetEnv
+        , clearEnv
+
+       -- * Program arguments
+       , getArgs
+) where
+
+#include "HsUnix.h"
+
+import Control.Monad
+import Foreign
+import Foreign.C
+import Data.Maybe       ( fromMaybe )
+
+import GHC.IO.Encoding.UTF8 ( mkUTF8 )
+import GHC.IO.Encoding.Failure ( CodingFailureMode(..) )
+import System.Posix.Env ( clearEnv )
+import System.OsPath.Posix
+import System.OsString.Internal.Types
+import qualified System.OsPath.Data.ByteString.Short as B
+import Data.ByteString.Short.Internal ( copyToPtr )
+
+-- |'getEnv' looks up a variable in the environment.
+
+getEnv ::
+  PosixString            {- ^ variable name  -} ->
+  IO (Maybe PosixString) {- ^ variable value -}
+getEnv (PS name) = do
+  litstring <- B.useAsCString name c_getenv
+  if litstring /= nullPtr
+     then (Just . PS) <$> B.packCString litstring
+     else return Nothing
+
+-- |'getEnvDefault' is a wrapper around 'getEnv' where the
+-- programmer can specify a fallback as the second argument, which will be
+-- used if the variable is not found in the environment.
+
+getEnvDefault ::
+  PosixString    {- ^ variable name                    -} ->
+  PosixString    {- ^ fallback value                   -} ->
+  IO PosixString {- ^ variable value or fallback value -}
+getEnvDefault name fallback = fromMaybe fallback <$> getEnv name
+
+foreign import ccall unsafe "getenv"
+   c_getenv :: CString -> IO CString
+
+getEnvironmentPrim :: IO [PosixString]
+getEnvironmentPrim = do
+  c_environ <- getCEnviron
+  arr <- peekArray0 nullPtr c_environ
+  mapM (fmap PS . B.packCString) arr
+
+getCEnviron :: IO (Ptr CString)
+#if HAVE__NSGETENVIRON
+-- You should not access @char **environ@ directly on Darwin in a bundle/shared library.
+-- See #2458 and http://developer.apple.com/library/mac/#documentation/Darwin/Reference/ManPages/man7/environ.7.html
+getCEnviron = nsGetEnviron >>= peek
+
+foreign import ccall unsafe "_NSGetEnviron"
+   nsGetEnviron :: IO (Ptr (Ptr CString))
+#else
+getCEnviron = peek c_environ_p
+
+foreign import ccall unsafe "&environ"
+   c_environ_p :: Ptr (Ptr CString)
+#endif
+
+-- |'getEnvironment' retrieves the entire environment as a
+-- list of @(key,value)@ pairs.
+
+getEnvironment :: IO [(PosixString,PosixString)] {- ^ @[(key,value)]@ -}
+getEnvironment = do
+  env <- getEnvironmentPrim
+  return $ map (dropEq . (B.break ((==) _equal)) . getPosixString) env
+ where
+   dropEq (x,y)
+      | B.head y == _equal = (PS x, PS (B.tail y))
+      | otherwise          = error $ "getEnvironment: insane variable " ++ _toStr x
+
+-- |'setEnvironment' resets the entire environment to the given list of
+-- @(key,value)@ pairs.
+setEnvironment ::
+  [(PosixString,PosixString)] {- ^ @[(key,value)]@ -} ->
+  IO ()
+setEnvironment env = do
+  clearEnv
+  forM_ env $ \(key,value) ->
+    setEnv key value True {-overwrite-}
+
+-- |The 'unsetEnv' function deletes all instances of the variable name
+-- from the environment.
+
+unsetEnv :: PosixString {- ^ variable name -} -> IO ()
+#if HAVE_UNSETENV
+# if !UNSETENV_RETURNS_VOID
+unsetEnv (PS name) = B.useAsCString name $ \ s ->
+  throwErrnoIfMinus1_ "unsetenv" (c_unsetenv s)
+
+-- POSIX.1-2001 compliant unsetenv(3)
+foreign import capi unsafe "HsUnix.h unsetenv"
+   c_unsetenv :: CString -> IO CInt
+# else
+unsetEnv name = B.useAsCString name c_unsetenv
+
+-- pre-POSIX unsetenv(3) returning @void@
+foreign import capi unsafe "HsUnix.h unsetenv"
+   c_unsetenv :: CString -> IO ()
+# endif
+#else
+unsetEnv name = putEnv (name <> PosixString (B.pack "="))
+#endif
+
+-- |'putEnv' function takes an argument of the form @name=value@
+-- and is equivalent to @setEnv(key,value,True{-overwrite-})@.
+putEnv :: PosixString {- ^ "key=value" -} -> IO ()
+putEnv (PS sbs) = do
+  buf <- mallocBytes (l+1)
+  copyToPtr sbs 0 buf (fromIntegral l)
+  pokeByteOff buf l (0::Word8)
+  throwErrnoIfMinus1_ "putenv" (c_putenv buf)
+ where l = B.length sbs
+
+
+foreign import ccall unsafe "putenv"
+   c_putenv :: CString -> IO CInt
+
+{- |The 'setEnv' function inserts or resets the environment variable name in
+     the current environment list.  If the variable @name@ does not exist in the
+     list, it is inserted with the given value.  If the variable does exist,
+     the argument @overwrite@ is tested; if @overwrite@ is @False@, the variable is
+     not reset, otherwise it is reset to the given value.
+-}
+
+setEnv ::
+  PosixString {- ^ variable name  -} ->
+  PosixString {- ^ variable value -} ->
+  Bool       {- ^ overwrite      -} ->
+  IO ()
+#ifdef HAVE_SETENV
+setEnv (PS key) (PS value) ovrwrt = do
+  B.useAsCString key $ \ keyP ->
+    B.useAsCString value $ \ valueP ->
+      throwErrnoIfMinus1_ "setenv" $
+        c_setenv keyP valueP (fromIntegral (fromEnum ovrwrt))
+
+foreign import ccall unsafe "setenv"
+   c_setenv :: CString -> CString -> CInt -> IO CInt
+#else
+setEnv key value True = putEnv (key++"="++value)
+setEnv key value False = do
+  res <- getEnv key
+  case res of
+    Just _  -> return ()
+    Nothing -> putEnv (key++"="++value)
+#endif
+
+-- | Computation 'getArgs' returns a list of the program's command
+-- line arguments (not including the program name), as 'PosixString's.
+--
+-- Unlike 'System.Environment.getArgs', this function does no Unicode
+-- decoding of the arguments; you get the exact bytes that were passed
+-- to the program by the OS.  To interpret the arguments as text, some
+-- Unicode decoding should be applied.
+--
+getArgs :: IO [PosixString]
+getArgs =
+  alloca $ \ p_argc ->
+  alloca $ \ p_argv -> do
+   getProgArgv p_argc p_argv
+   p    <- fromIntegral <$> peek p_argc
+   argv <- peek p_argv
+   peekArray (p - 1) (advancePtr argv 1) >>= mapM (fmap PS . B.packCString)
+
+foreign import ccall unsafe "getProgArgv"
+  getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()
+
+_equal :: Word8
+_equal = 0x3d
+
+_toStr :: B.ShortByteString -> String
+_toStr = either (error . show) id . decodeWith (mkUTF8 TransliterateCodingFailure) . PosixString