From 41e1843ad7ff145397ec3d6fa1b7e8d61b765ab2 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Tue, 22 Mar 2022 21:48:00 +0100 Subject: [PATCH 1/2] Add PosixFilePath and friends support (for AFPP) --- System/Posix/Directory/PosixPath.hsc | 166 ++++++++++ System/Posix/Env/PosixString.hsc | 206 ++++++++++++ System/Posix/Files/PosixString.hsc | 453 ++++++++++++++++++++++++++ System/Posix/IO/PosixString.hsc | 116 +++++++ System/Posix/PosixPath/FilePath.hsc | 140 ++++++++ System/Posix/PosixString.hs | 70 ++++ System/Posix/Process/Common.hsc | 5 +- System/Posix/Process/PosixString.hsc | 134 ++++++++ System/Posix/Signals.hsc | 6 +- System/Posix/Temp/PosixString.hsc | 123 +++++++ System/Posix/Terminal/PosixString.hsc | 211 ++++++++++++ cabal.project | 1 + cabal.project.wasm32-wasi | 2 +- unix.cabal | 10 + 14 files changed, 1638 insertions(+), 5 deletions(-) create mode 100644 System/Posix/Directory/PosixPath.hsc create mode 100644 System/Posix/Env/PosixString.hsc create mode 100644 System/Posix/Files/PosixString.hsc create mode 100644 System/Posix/IO/PosixString.hsc create mode 100644 System/Posix/PosixPath/FilePath.hsc create mode 100644 System/Posix/PosixString.hs create mode 100644 System/Posix/Process/PosixString.hsc create mode 100644 System/Posix/Temp/PosixString.hsc create mode 100644 System/Posix/Terminal/PosixString.hsc diff --git a/System/Posix/Directory/PosixPath.hsc b/System/Posix/Directory/PosixPath.hsc new file mode 100644 index 00000000..5da1bee7 --- /dev/null +++ b/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 + diff --git a/System/Posix/Env/PosixString.hsc b/System/Posix/Env/PosixString.hsc new file mode 100644 index 00000000..224c53f6 --- /dev/null +++ b/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 diff --git a/System/Posix/Files/PosixString.hsc b/System/Posix/Files/PosixString.hsc new file mode 100644 index 00000000..92bd16a1 --- /dev/null +++ b/System/Posix/Files/PosixString.hsc @@ -0,0 +1,453 @@ +{-# LANGUAGE CApiFFI #-} + +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Files.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) +-- +-- Functions defined by the POSIX standards for manipulating and querying the +-- file system. Names of underlying POSIX functions are indicated whenever +-- possible. A more complete documentation of the POSIX functions together +-- with a more detailed description of different error conditions are usually +-- available in the system's manual pages or from +-- (free registration required). +-- +-- When a function that calls an underlying POSIX function fails, the errno +-- code is converted to an 'IOError' using 'Foreign.C.Error.errnoToIOError'. +-- For a list of which errno codes may be generated, consult the POSIX +-- documentation for the underlying function. +-- +----------------------------------------------------------------------------- + +#include "HsUnix.h" + +module System.Posix.Files.PosixString ( + -- * File modes + -- FileMode exported by System.Posix.Types + unionFileModes, intersectFileModes, + nullFileMode, + ownerReadMode, ownerWriteMode, ownerExecuteMode, ownerModes, + groupReadMode, groupWriteMode, groupExecuteMode, groupModes, + otherReadMode, otherWriteMode, otherExecuteMode, otherModes, + setUserIDMode, setGroupIDMode, + stdFileMode, accessModes, + fileTypeModes, + blockSpecialMode, characterSpecialMode, namedPipeMode, regularFileMode, + directoryMode, symbolicLinkMode, socketMode, + + -- ** Setting file modes + setFileMode, setFdMode, setFileCreationMask, + + -- ** Checking file existence and permissions + fileAccess, fileExist, + + -- * File status + FileStatus, + -- ** Obtaining file status + getFileStatus, getFdStatus, getSymbolicLinkStatus, + -- ** Querying file status + deviceID, fileID, fileMode, linkCount, fileOwner, fileGroup, + specialDeviceID, fileSize, accessTime, modificationTime, + statusChangeTime, + accessTimeHiRes, modificationTimeHiRes, statusChangeTimeHiRes, + isBlockDevice, isCharacterDevice, isNamedPipe, isRegularFile, + isDirectory, isSymbolicLink, isSocket, + + -- * Creation + createNamedPipe, + createDevice, + + -- * Hard links + createLink, removeLink, + + -- * Symbolic links + createSymbolicLink, readSymbolicLink, + + -- * Renaming files + rename, + + -- * Changing file ownership + setOwnerAndGroup, setFdOwnerAndGroup, +#if HAVE_LCHOWN + setSymbolicLinkOwnerAndGroup, +#endif + + -- * Changing file timestamps + setFileTimes, setFileTimesHiRes, + setSymbolicLinkTimesHiRes, + touchFile, touchFd, touchSymbolicLink, + + -- * Setting file sizes + setFileSize, setFdSize, + + -- * Find system-specific limits for a file + PathVar(..), getPathVar, getFdPathVar, + ) where + +import System.Posix.Types +import System.Posix.Internals hiding (withFilePath, peekFilePathLen) +import qualified System.Posix.Files.Common as Common +import Foreign +import Foreign.C hiding ( + throwErrnoPath, + throwErrnoPathIf, + throwErrnoPathIf_, + throwErrnoPathIfNull, + throwErrnoPathIfMinus1, + throwErrnoPathIfMinus1_ ) + +import System.OsPath.Types +import System.Posix.Files hiding (getFileStatus, getSymbolicLinkStatus, createNamedPipe, createDevice, createLink, removeLink, createSymbolicLink, readSymbolicLink, rename, setOwnerAndGroup, setSymbolicLinkOwnerAndGroup, setFileTimes, setSymbolicLinkTimesHiRes, touchFile, touchSymbolicLink, setFileSize, getPathVar, setFileMode, fileAccess, fileExist, setFdTimesHiRes, setFileTimesHiRes) +import System.Posix.PosixPath.FilePath + +import Data.Time.Clock.POSIX (POSIXTime) + +-- ----------------------------------------------------------------------------- +-- chmod() + +-- | @setFileMode path mode@ changes permission of the file given by @path@ +-- to @mode@. This operation may fail with 'throwErrnoPathIfMinus1_' if @path@ +-- doesn't exist or if the effective user ID of the current process is not that +-- of the file's owner. +-- +-- Note: calls @chmod@. +setFileMode :: PosixPath -> FileMode -> IO () +setFileMode name m = + withFilePath name $ \s -> do + throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m) + + +-- ----------------------------------------------------------------------------- +-- access() + +-- | @fileAccess name read write exec@ checks if the file (or other file system +-- object) @name@ can be accessed for reading, writing and\/or executing. To +-- check a permission set the corresponding argument to 'True'. +-- +-- Note: calls @access@. +fileAccess :: PosixPath -> Bool -> Bool -> Bool -> IO Bool +fileAccess name readOK writeOK execOK = access name flags + where + flags = read_f .|. write_f .|. exec_f + read_f = if readOK then (#const R_OK) else 0 + write_f = if writeOK then (#const W_OK) else 0 + exec_f = if execOK then (#const X_OK) else 0 + +-- | Checks for the existence of the file. +-- +-- Note: calls @access@. +fileExist :: PosixPath -> IO Bool +fileExist name = + withFilePath name $ \s -> do + r <- c_access s (#const F_OK) + if (r == 0) + then return True + else do err <- getErrno + if (err == eNOENT) + then return False + else throwErrnoPath "fileExist" name + +access :: PosixPath -> CMode -> IO Bool +access name flags = + withFilePath name $ \s -> do + r <- c_access s (fromIntegral flags) + if (r == 0) + then return True + else do err <- getErrno + if (err == eACCES || err == eROFS || err == eTXTBSY || + err == ePERM) + then return False + else throwErrnoPath "fileAccess" name + + +-- | @getFileStatus path@ calls gets the @FileStatus@ information (user ID, +-- size, access times, etc.) for the file @path@. +-- +-- Note: calls @stat@. +getFileStatus :: PosixPath -> IO FileStatus +getFileStatus path = do + fp <- mallocForeignPtrBytes (#const sizeof(struct stat)) + withForeignPtr fp $ \p -> + withFilePath path $ \s -> + throwErrnoPathIfMinus1Retry_ "getFileStatus" path (c_stat s p) + return (Common.FileStatus fp) + +-- | Acts as 'getFileStatus' except when the 'PosixPath' refers to a symbolic +-- link. In that case the @FileStatus@ information of the symbolic link itself +-- is returned instead of that of the file it points to. +-- +-- Note: calls @lstat@. +getSymbolicLinkStatus :: PosixPath -> IO FileStatus +getSymbolicLinkStatus path = do + fp <- mallocForeignPtrBytes (#const sizeof(struct stat)) + withForeignPtr fp $ \p -> + withFilePath path $ \s -> + throwErrnoPathIfMinus1_ "getSymbolicLinkStatus" path (c_lstat s p) + return (Common.FileStatus fp) + +foreign import capi unsafe "HsUnix.h lstat" + c_lstat :: CString -> Ptr CStat -> IO CInt + +-- | @createNamedPipe fifo mode@ +-- creates a new named pipe, @fifo@, with permissions based on +-- @mode@. May fail with 'throwErrnoPathIfMinus1_' if a file named @name@ +-- already exists or if the effective user ID of the current process doesn't +-- have permission to create the pipe. +-- +-- Note: calls @mkfifo@. +createNamedPipe :: PosixPath -> FileMode -> IO () +createNamedPipe name mode = do + withFilePath name $ \s -> + throwErrnoPathIfMinus1_ "createNamedPipe" name (c_mkfifo s mode) + +-- | @createDevice path mode dev@ creates either a regular or a special file +-- depending on the value of @mode@ (and @dev@). @mode@ will normally be either +-- 'blockSpecialMode' or 'characterSpecialMode'. May fail with +-- 'throwErrnoPathIfMinus1_' if a file named @name@ already exists or if the +-- effective user ID of the current process doesn't have permission to create +-- the file. +-- +-- Note: calls @mknod@. +createDevice :: PosixPath -> FileMode -> DeviceID -> IO () +createDevice path mode dev = + withFilePath path $ \s -> + throwErrnoPathIfMinus1_ "createDevice" path (c_mknod s mode dev) + +foreign import capi unsafe "HsUnix.h mknod" + c_mknod :: CString -> CMode -> CDev -> IO CInt + +-- ----------------------------------------------------------------------------- +-- Hard links + +-- | @createLink old new@ creates a new path, @new@, linked to an existing file, +-- @old@. +-- +-- Note: calls @link@. +createLink :: PosixPath -> PosixPath -> IO () +createLink name1 name2 = + withFilePath name1 $ \s1 -> + withFilePath name2 $ \s2 -> + throwErrnoTwoPathsIfMinus1_ "createLink" name1 name2 (c_link s1 s2) + +-- | @removeLink path@ removes the link named @path@. +-- +-- Note: calls @unlink@. +removeLink :: PosixPath -> IO () +removeLink name = + withFilePath name $ \s -> + throwErrnoPathIfMinus1_ "removeLink" name (c_unlink s) + +-- ----------------------------------------------------------------------------- +-- Symbolic Links + +-- | @createSymbolicLink file1 file2@ creates a symbolic link named @file2@ +-- which points to the file @file1@. +-- +-- Symbolic links are interpreted at run-time as if the contents of the link +-- had been substituted into the path being followed to find a file or directory. +-- +-- Note: calls @symlink@. +createSymbolicLink :: PosixPath -> PosixPath -> IO () +createSymbolicLink name1 name2 = + withFilePath name1 $ \s1 -> + withFilePath name2 $ \s2 -> + throwErrnoTwoPathsIfMinus1_ "createSymbolicLink" name1 name2 (c_symlink s1 s2) + +foreign import ccall unsafe "symlink" + c_symlink :: CString -> CString -> IO CInt + +-- ToDo: should really use SYMLINK_MAX, but not everyone supports it yet, +-- and it seems that the intention is that SYMLINK_MAX is no larger than +-- PATH_MAX. +#if !defined(PATH_MAX) +-- PATH_MAX is not defined on systems with unlimited path length. +-- Ugly. Fix this. +#define PATH_MAX 4096 +#endif + +-- | Reads the @PosixPath@ pointed to by the symbolic link and returns it. +-- +-- Note: calls @readlink@. +readSymbolicLink :: PosixPath -> IO PosixPath +readSymbolicLink file = + allocaArray0 (#const PATH_MAX) $ \buf -> do + withFilePath file $ \s -> do + len <- throwErrnoPathIfMinus1 "readSymbolicLink" file $ + c_readlink s buf (#const PATH_MAX) + peekFilePathLen (buf,fromIntegral len) + +foreign import ccall unsafe "readlink" + c_readlink :: CString -> CString -> CSize -> IO CInt + +-- ----------------------------------------------------------------------------- +-- Renaming files + +-- | @rename old new@ renames a file or directory from @old@ to @new@. +-- +-- Note: calls @rename@. +rename :: PosixPath -> PosixPath -> IO () +rename name1 name2 = + withFilePath name1 $ \s1 -> + withFilePath name2 $ \s2 -> + throwErrnoTwoPathsIfMinus1_ "rename" name1 name2 (c_rename s1 s2) + +foreign import ccall unsafe "rename" + c_rename :: CString -> CString -> IO CInt + +-- ----------------------------------------------------------------------------- +-- chown() + +-- | @setOwnerAndGroup path uid gid@ changes the owner and group of @path@ to +-- @uid@ and @gid@, respectively. +-- +-- If @uid@ or @gid@ is specified as -1, then that ID is not changed. +-- +-- Note: calls @chown@. +setOwnerAndGroup :: PosixPath -> UserID -> GroupID -> IO () +setOwnerAndGroup name uid gid = do + withFilePath name $ \s -> + throwErrnoPathIfMinus1_ "setOwnerAndGroup" name (c_chown s uid gid) + +foreign import ccall unsafe "chown" + c_chown :: CString -> CUid -> CGid -> IO CInt + +#if HAVE_LCHOWN +-- | Acts as 'setOwnerAndGroup' but does not follow symlinks (and thus +-- changes permissions on the link itself). +-- +-- Note: calls @lchown@. +setSymbolicLinkOwnerAndGroup :: PosixPath -> UserID -> GroupID -> IO () +setSymbolicLinkOwnerAndGroup name uid gid = do + withFilePath name $ \s -> + throwErrnoPathIfMinus1_ "setSymbolicLinkOwnerAndGroup" name + (c_lchown s uid gid) + +foreign import ccall unsafe "lchown" + c_lchown :: CString -> CUid -> CGid -> IO CInt +#endif + +-- ----------------------------------------------------------------------------- +-- Setting file times + +-- | @setFileTimes path atime mtime@ sets the access and modification times +-- associated with file @path@ to @atime@ and @mtime@, respectively. +-- +-- Note: calls @utime@. +setFileTimes :: PosixPath -> EpochTime -> EpochTime -> IO () +setFileTimes name atime mtime = do + withFilePath name $ \s -> + allocaBytes (#const sizeof(struct utimbuf)) $ \p -> do + (#poke struct utimbuf, actime) p atime + (#poke struct utimbuf, modtime) p mtime + throwErrnoPathIfMinus1_ "setFileTimes" name (c_utime s p) + +-- | Like 'setFileTimes' but timestamps can have sub-second resolution. +-- +-- Note: calls @utimensat@ or @utimes@. Support for high resolution timestamps +-- is filesystem dependent with the following limitations: +-- +-- - HFS+ volumes on OS X truncate the sub-second part of the timestamp. +-- +setFileTimesHiRes :: PosixPath -> POSIXTime -> POSIXTime -> IO () +#ifdef HAVE_UTIMENSAT +setFileTimesHiRes name atime mtime = + withFilePath name $ \s -> + withArray [Common.toCTimeSpec atime, Common.toCTimeSpec mtime] $ \times -> + throwErrnoPathIfMinus1_ "setFileTimesHiRes" name $ + Common.c_utimensat (#const AT_FDCWD) s times 0 +#else +setFileTimesHiRes name atime mtime = + withFilePath name $ \s -> + withArray [Common.toCTimeVal atime, Common.toCTimeVal mtime] $ \times -> + throwErrnoPathIfMinus1_ "setFileTimesHiRes" name (Common.c_utimes s times) +#endif + +-- | Like 'setFileTimesHiRes' but does not follow symbolic links. +-- This operation is not supported on all platforms. On these platforms, +-- this function will raise an exception. +-- +-- Note: calls @utimensat@ or @lutimes@. Support for high resolution timestamps +-- is filesystem dependent with the following limitations: +-- +-- - HFS+ volumes on OS X truncate the sub-second part of the timestamp. +-- +setSymbolicLinkTimesHiRes :: PosixPath -> POSIXTime -> POSIXTime -> IO () +#if HAVE_UTIMENSAT +setSymbolicLinkTimesHiRes name atime mtime = + withFilePath name $ \s -> + withArray [Common.toCTimeSpec atime, Common.toCTimeSpec mtime] $ \times -> + throwErrnoPathIfMinus1_ "setSymbolicLinkTimesHiRes" name $ + Common.c_utimensat (#const AT_FDCWD) s times (#const AT_SYMLINK_NOFOLLOW) +#elif HAVE_LUTIMES +setSymbolicLinkTimesHiRes name atime mtime = + withFilePath name $ \s -> + withArray [Common.toCTimeVal atime, Common.toCTimeVal mtime] $ \times -> + throwErrnoPathIfMinus1_ "setSymbolicLinkTimesHiRes" name $ + Common.c_lutimes s times +#else +setSymbolicLinkTimesHiRes = + error "setSymbolicLinkTimesHiRes: not available on this platform" +#endif + +-- | @touchFile path@ sets the access and modification times associated with +-- file @path@ to the current time. +-- +-- Note: calls @utime@. +touchFile :: PosixPath -> IO () +touchFile name = do + withFilePath name $ \s -> + throwErrnoPathIfMinus1_ "touchFile" name (c_utime s nullPtr) + +-- | Like 'touchFile' but does not follow symbolic links. +-- This operation is not supported on all platforms. On these platforms, +-- this function will raise an exception. +-- +-- Note: calls @lutimes@. +touchSymbolicLink :: PosixPath -> IO () +#if HAVE_LUTIMES +touchSymbolicLink name = + withFilePath name $ \s -> + throwErrnoPathIfMinus1_ "touchSymbolicLink" name (Common.c_lutimes s nullPtr) +#else +touchSymbolicLink = + error "touchSymbolicLink: not available on this platform" +#endif + +-- ----------------------------------------------------------------------------- +-- Setting file sizes + +-- | Truncates the file down to the specified length. If the file was larger +-- than the given length before this operation was performed the extra is lost. +-- +-- Note: calls @truncate@. +setFileSize :: PosixPath -> FileOffset -> IO () +setFileSize file off = + withFilePath file $ \s -> + throwErrnoPathIfMinus1_ "setFileSize" file (c_truncate s off) + +foreign import capi unsafe "HsUnix.h truncate" + c_truncate :: CString -> COff -> IO CInt + +-- ----------------------------------------------------------------------------- +-- pathconf()/fpathconf() support + +-- | @getPathVar var path@ obtains the dynamic value of the requested +-- configurable file limit or option associated with file or directory @path@. +-- For defined file limits, @getPathVar@ returns the associated +-- value. For defined file options, the result of @getPathVar@ +-- is undefined, but not failure. +-- +-- Note: calls @pathconf@. +getPathVar :: PosixPath -> PathVar -> IO Limit +getPathVar name v = do + withFilePath name $ \ nameP -> + throwErrnoPathIfMinus1 "getPathVar" name $ + c_pathconf nameP (Common.pathVarConst v) + +foreign import ccall unsafe "pathconf" + c_pathconf :: CString -> CInt -> IO CLong diff --git a/System/Posix/IO/PosixString.hsc b/System/Posix/IO/PosixString.hsc new file mode 100644 index 00000000..d6d6b009 --- /dev/null +++ b/System/Posix/IO/PosixString.hsc @@ -0,0 +1,116 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.IO.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 IO support. These types and functions correspond to the unix +-- functions open(2), close(2), etc. For more portable functions +-- which are more like fopen(3) and friends from stdio.h, see +-- "System.IO". +-- +----------------------------------------------------------------------------- + +#include "HsUnix.h" + +module System.Posix.IO.PosixString ( + -- * Input \/ Output + + -- ** Standard file descriptors + stdInput, stdOutput, stdError, + + -- ** Opening and closing files + OpenMode(..), + OpenFileFlags(..), defaultFileFlags, + openFd, openFdAt, createFile, createFileAt, + closeFd, + + -- ** Reading\/writing data + -- |Programmers using the 'fdRead' and 'fdWrite' API should be aware that + -- EAGAIN exceptions may occur for non-blocking IO! + + fdRead, fdWrite, + fdReadBuf, fdWriteBuf, + + -- ** Seeking + fdSeek, + + -- ** File options + FdOption(..), + queryFdOption, + setFdOption, + + -- ** Locking + FileLock, + LockRequest(..), + getLock, setLock, + waitToSetLock, + + -- ** Pipes + createPipe, + + -- ** Duplicating file descriptors + dup, dupTo, + + -- ** Converting file descriptors to\/from Handles + handleToFd, + fdToHandle, + + ) where + +import System.Posix.Types +import System.Posix.IO.Common +import System.Posix.IO.ByteString ( fdRead, fdWrite ) +import System.OsPath.Types + +import System.Posix.PosixPath.FilePath + + + +-- |Open and optionally create this file. See 'System.Posix.Files' +-- for information on how to use the 'FileMode' type. +openFd :: PosixPath + -> OpenMode + -> OpenFileFlags + -> IO Fd +openFd = openFdAt Nothing + +-- | Open a file relative to an optional directory file descriptor. +-- +-- Directory file descriptors can be used to avoid some race conditions when +-- navigating changing directory trees, or to retain access to a portion of the +-- directory tree that would otherwise become inaccessible after dropping +-- privileges. +openFdAt :: Maybe Fd -- ^ Optional directory file descriptor + -> PosixPath -- ^ Pathname to open + -> OpenMode -- ^ Read-only, read-write or write-only + -> OpenFileFlags -- ^ Append, exclusive, truncate, etc. + -> IO Fd +openFdAt fdMay name how flags = + withFilePath name $ \str -> + throwErrnoPathIfMinus1Retry "openFdAt" name $ + openat_ fdMay str how flags + +-- |Create and open this file in WriteOnly mode. A special case of +-- 'openFd'. See 'System.Posix.Files' for information on how to use +-- the 'FileMode' type. +createFile :: PosixPath -> FileMode -> IO Fd +createFile = createFileAt Nothing + +-- | Create and open a file for write-only, with default flags, +-- relative an optional directory file-descriptor. +-- +-- Directory file descriptors can be used to avoid some race conditions when +-- navigating changing directory trees, or to retain access to a portion of the +-- directory tree that would otherwise become inaccessible after dropping +-- privileges. +createFileAt :: Maybe Fd -- ^ Optional directory file descriptor + -> PosixPath -- ^ Pathname to create + -> FileMode -- ^ File permission bits (before umask) + -> IO Fd +createFileAt fdMay name mode + = openFdAt fdMay name WriteOnly defaultFileFlags{ trunc=True, creat=(Just mode) } diff --git a/System/Posix/PosixPath/FilePath.hsc b/System/Posix/PosixPath/FilePath.hsc new file mode 100644 index 00000000..0ce2c7ea --- /dev/null +++ b/System/Posix/PosixPath/FilePath.hsc @@ -0,0 +1,140 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.PosixPath.FilePath +-- 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) +-- +-- Internal stuff: support for ByteString FilePaths +-- +----------------------------------------------------------------------------- + +module System.Posix.PosixPath.FilePath ( + withFilePath, peekFilePath, peekFilePathLen, + throwErrnoPathIfMinus1Retry, + throwErrnoPathIfMinus1Retry_, + throwErrnoPathIfNullRetry, + throwErrnoPathIfRetry, + throwErrnoPath, + throwErrnoPathIf, + throwErrnoPathIf_, + throwErrnoPathIfNull, + throwErrnoPathIfMinus1, + throwErrnoPathIfMinus1_, + throwErrnoTwoPathsIfMinus1_ + ) where + +import Foreign hiding ( void ) +import Foreign.C hiding ( + throwErrnoPath, + throwErrnoPathIf, + throwErrnoPathIf_, + throwErrnoPathIfNull, + throwErrnoPathIfMinus1, + throwErrnoPathIfMinus1_ ) + +import System.OsPath.Types +import Control.Monad +import GHC.IO.Encoding.UTF8 ( mkUTF8 ) +import GHC.IO.Encoding.Failure ( CodingFailureMode(..) ) +import System.OsPath.Posix +import System.OsPath.Data.ByteString.Short +import Prelude hiding (FilePath) +import System.OsString.Internal.Types (PosixString(..)) +#if !MIN_VERSION_base(4, 11, 0) +import Data.Monoid ((<>)) +#endif + + +withFilePath :: PosixPath -> (CString -> IO a) -> IO a +withFilePath = useAsCString . getPosixString + +peekFilePath :: CString -> IO PosixPath +peekFilePath = fmap PosixString . packCString + +peekFilePathLen :: CStringLen -> IO PosixPath +peekFilePathLen = fmap PosixString . packCStringLen + + +throwErrnoPathIfMinus1Retry :: (Eq a, Num a) + => String -> PosixPath -> IO a -> IO a +throwErrnoPathIfMinus1Retry loc path f = do + throwErrnoPathIfRetry (== -1) loc path f + +throwErrnoPathIfMinus1Retry_ :: (Eq a, Num a) + => String -> PosixPath -> IO a -> IO () +throwErrnoPathIfMinus1Retry_ loc path f = + void $ throwErrnoPathIfRetry (== -1) loc path f + +throwErrnoPathIfNullRetry :: String -> PosixPath -> IO (Ptr a) -> IO (Ptr a) +throwErrnoPathIfNullRetry loc path f = + throwErrnoPathIfRetry (== nullPtr) loc path f + +throwErrnoPathIfRetry :: (a -> Bool) -> String -> PosixPath -> IO a -> IO a +throwErrnoPathIfRetry pr loc rpath f = + do + res <- f + if pr res + then do + err <- getErrno + if err == eINTR + then throwErrnoPathIfRetry pr loc rpath f + else throwErrnoPath loc rpath + else return res + +-- | as 'throwErrno', but exceptions include the given path when appropriate. +-- +throwErrnoPath :: String -> PosixPath -> IO a +throwErrnoPath loc path = + do + errno <- getErrno + ioError (errnoToIOError loc errno Nothing (Just (_toStr path))) + +-- | as 'throwErrnoIf', but exceptions include the given path when +-- appropriate. +-- +throwErrnoPathIf :: (a -> Bool) -> String -> PosixPath -> IO a -> IO a +throwErrnoPathIf cond loc path f = + do + res <- f + if cond res then throwErrnoPath loc path else return res + +-- | as 'throwErrnoIf_', but exceptions include the given path when +-- appropriate. +-- +throwErrnoPathIf_ :: (a -> Bool) -> String -> PosixPath -> IO a -> IO () +throwErrnoPathIf_ cond loc path f = void $ throwErrnoPathIf cond loc path f + +-- | as 'throwErrnoIfNull', but exceptions include the given path when +-- appropriate. +-- +throwErrnoPathIfNull :: String -> PosixPath -> IO (Ptr a) -> IO (Ptr a) +throwErrnoPathIfNull = throwErrnoPathIf (== nullPtr) + +-- | as 'throwErrnoIfMinus1', but exceptions include the given path when +-- appropriate. +-- +throwErrnoPathIfMinus1 :: (Eq a, Num a) => String -> PosixPath -> IO a -> IO a +throwErrnoPathIfMinus1 = throwErrnoPathIf (== -1) + +-- | as 'throwErrnoIfMinus1_', but exceptions include the given path when +-- appropriate. +-- +throwErrnoPathIfMinus1_ :: (Eq a, Num a) => String -> PosixPath -> IO a -> IO () +throwErrnoPathIfMinus1_ = throwErrnoPathIf_ (== -1) + +-- | as 'throwErrnoTwoPathsIfMinus1_', but exceptions include two paths when appropriate. +-- +throwErrnoTwoPathsIfMinus1_ :: (Eq a, Num a) => String -> PosixPath -> PosixPath -> IO a -> IO () +throwErrnoTwoPathsIfMinus1_ loc path1 path2 = + throwErrnoIfMinus1_ (loc <> " '" <> _toStr path1 <> "' to '" <> _toStr path2 <> "'") + + +_toStr :: PosixPath -> String +_toStr fp = either (error . show) id $ decodeWith (mkUTF8 TransliterateCodingFailure) fp + diff --git a/System/Posix/PosixString.hs b/System/Posix/PosixString.hs new file mode 100644 index 00000000..c558ac2a --- /dev/null +++ b/System/Posix/PosixString.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.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) +-- +-- +-- support with 'ByteString' file paths and environment strings. +-- +-- This module exports exactly the same API as "System.Posix", except +-- that all file paths and environment strings are represented by +-- 'ByteString' instead of 'String'. The "System.Posix" API +-- implicitly translates all file paths and environment strings using +-- the locale encoding, whereas this version of the API does no +-- encoding or decoding and works directly in terms of raw bytes. +-- +-- Note that if you do need to interpret file paths or environment +-- strings as text, then some Unicode encoding or decoding should be +-- applied first. +-- +----------------------------------------------------------------------------- + +module System.Posix.PosixString ( + System.OsString.Posix.PosixString, + System.OsPath.Posix.PosixPath, + module System.Posix.Types, + module System.Posix.Signals, + module System.Posix.Directory.PosixPath, + module System.Posix.Files.PosixString, + module System.Posix.Unistd, + module System.Posix.IO.PosixString, + module System.Posix.Env.PosixString, + module System.Posix.Process.PosixString, + module System.Posix.Temp.PosixString, + -- module System.Posix.Terminal.ByteString, + module System.Posix.Time, + module System.Posix.User, + module System.Posix.Resource, + module System.Posix.Semaphore, + module System.Posix.SharedMem, +-- module System.Posix.DynamicLinker.ByteString, +-- XXX 'Module' type clashes with GHC +-- module System.Posix.DynamicLinker.Module.ByteString + ) where + +import System.OsPath.Posix +import System.OsString.Posix +import System.Posix.Types +import System.Posix.Signals +import System.Posix.Directory.PosixPath +import System.Posix.Files.PosixString +import System.Posix.Unistd +import System.Posix.Process.PosixString +import System.Posix.IO.PosixString +import System.Posix.Env.PosixString +import System.Posix.Temp.PosixString +-- import System.Posix.Terminal.ByteString +import System.Posix.Time +import System.Posix.User +import System.Posix.Resource +import System.Posix.Semaphore +import System.Posix.SharedMem +-- XXX: bad planning, we have two constructors called "Default" +-- import System.Posix.DynamicLinker.ByteString hiding (Default) +--import System.Posix.DynamicLinker.Module.ByteString diff --git a/System/Posix/Process/Common.hsc b/System/Posix/Process/Common.hsc index 9b787d97..1a502eb8 100644 --- a/System/Posix/Process/Common.hsc +++ b/System/Posix/Process/Common.hsc @@ -82,9 +82,10 @@ import Control.Monad import Control.Exception.Base ( bracket, getMaskingState, MaskingState(..) ) -- used by forkProcess import GHC.TopHandler ( runIO ) -import GHC.IO ( unsafeUnmask, uninterruptibleMask_, unsafePerformIO ) -#if !defined(HAVE_GETPID) +#if defined(HAVE_GETPID) +import GHC.IO ( unsafeUnmask, uninterruptibleMask_ ) +#else import System.IO.Error ( ioeSetLocation ) import GHC.IO.Exception ( unsupportedOperation ) #endif diff --git a/System/Posix/Process/PosixString.hsc b/System/Posix/Process/PosixString.hsc new file mode 100644 index 00000000..7994bff0 --- /dev/null +++ b/System/Posix/Process/PosixString.hsc @@ -0,0 +1,134 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Process.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 process support. See also the System.Cmd and System.Process +-- modules in the process package. +-- +----------------------------------------------------------------------------- + +module System.Posix.Process.PosixString ( + -- * Processes + + -- ** Forking and executing + forkProcess, + forkProcessWithUnmask, + executeFile, + + -- ** Exiting + exitImmediately, + + -- ** Process environment + getProcessID, + getParentProcessID, + + -- ** Process groups + getProcessGroupID, + getProcessGroupIDOf, + createProcessGroupFor, + joinProcessGroup, + setProcessGroupIDOf, + + -- ** Sessions + createSession, + + -- ** Process times + ProcessTimes(..), + getProcessTimes, + + -- ** Scheduling priority + nice, + getProcessPriority, + getProcessGroupPriority, + getUserPriority, + setProcessPriority, + setProcessGroupPriority, + setUserPriority, + + -- ** Process status + ProcessStatus(..), + getProcessStatus, + getAnyProcessStatus, + getGroupProcessStatus, + + -- ** Deprecated + createProcessGroup, + setProcessGroupID, + + ) where + +#include "HsUnix.h" + +import Foreign +import System.Posix.Process.Internals +import System.Posix.Process (ProcessTimes(..), setProcessGroupID, createProcessGroup, getGroupProcessStatus, getAnyProcessStatus, getProcessStatus, setUserPriority, setProcessGroupPriority, setProcessPriority, getUserPriority, getProcessGroupPriority, getProcessPriority, nice, getProcessTimes, createSession, setProcessGroupIDOf, joinProcessGroup, createProcessGroupFor, getProcessGroupIDOf, getProcessGroupID, getParentProcessID, getProcessID, exitImmediately, forkProcessWithUnmask, forkProcess) + +import Foreign.C hiding ( + throwErrnoPath, + throwErrnoPathIf, + throwErrnoPathIf_, + throwErrnoPathIfNull, + throwErrnoPathIfMinus1, + throwErrnoPathIfMinus1_ ) + +import System.OsPath.Types +import System.OsString.Internal.Types (PosixString(..)) +import qualified System.OsPath.Data.ByteString.Short as BC + +import System.Posix.PosixPath.FilePath + +-- | @'executeFile' cmd args env@ calls one of the +-- @execv*@ family, depending on whether or not the current +-- PATH is to be searched for the command, and whether or not an +-- environment is provided to supersede the process's current +-- environment. The basename (leading directory names suppressed) of +-- the command is passed to @execv*@ as @arg[0]@; +-- the argument list passed to 'executeFile' therefore +-- begins with @arg[1]@. +executeFile :: PosixPath -- ^ Command + -> Bool -- ^ Search PATH? + -> [PosixString] -- ^ Arguments + -> Maybe [(PosixString, PosixString)] -- ^ Environment + -> IO a +executeFile path search args Nothing = do + withFilePath path $ \s -> + withMany withFilePath (path:args) $ \cstrs -> + withArray0 nullPtr cstrs $ \arr -> do + pPrPr_disableITimers + if search + then throwErrnoPathIfMinus1_ "executeFile" path (c_execvp s arr) + else throwErrnoPathIfMinus1_ "executeFile" path (c_execv s arr) + return undefined -- never reached + +executeFile path search args (Just env) = do + withFilePath path $ \s -> + withMany withFilePath (path:args) $ \cstrs -> + withArray0 nullPtr cstrs $ \arg_arr -> + let env' = map (\ (PosixString name, PosixString val) -> PosixString $ name `BC.append` (_equal `BC.cons` val)) env in + withMany withFilePath env' $ \cenv -> + withArray0 nullPtr cenv $ \env_arr -> do + pPrPr_disableITimers + if search + then throwErrnoPathIfMinus1_ "executeFile" path + (c_execvpe s arg_arr env_arr) + else throwErrnoPathIfMinus1_ "executeFile" path + (c_execve s arg_arr env_arr) + return undefined -- never reached + +foreign import ccall unsafe "execvp" + c_execvp :: CString -> Ptr CString -> IO CInt + +foreign import ccall unsafe "execv" + c_execv :: CString -> Ptr CString -> IO CInt + +foreign import ccall unsafe "execve" + c_execve :: CString -> Ptr CString -> Ptr CString -> IO CInt + +_equal :: Word8 +_equal = 0x3d diff --git a/System/Posix/Signals.hsc b/System/Posix/Signals.hsc index 4a31ccd9..b068d41b 100644 --- a/System/Posix/Signals.hsc +++ b/System/Posix/Signals.hsc @@ -101,6 +101,10 @@ import Foreign.ForeignPtr import Foreign.Marshal import Foreign.Ptr import Foreign.Storable +#if !defined(HAVE_SIGNAL_H) +import System.IO.Error ( ioeSetLocation ) +import GHC.IO.Exception ( unsupportedOperation ) +#endif import System.IO.Unsafe (unsafePerformIO) import System.Posix.Types import System.Posix.Internals @@ -114,8 +118,6 @@ import GHC.Conc hiding (Signal) #if !defined(HAVE_SIGNAL_H) import Control.Exception ( throw ) -import System.IO.Error ( ioeSetLocation ) -import GHC.IO.Exception ( unsupportedOperation ) #endif -- ----------------------------------------------------------------------------- diff --git a/System/Posix/Temp/PosixString.hsc b/System/Posix/Temp/PosixString.hsc new file mode 100644 index 00000000..bdab8d0c --- /dev/null +++ b/System/Posix/Temp/PosixString.hsc @@ -0,0 +1,123 @@ +{-# LANGUAGE CApiFFI #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Temp.PosixString +-- Copyright : (c) Volker Stolz +-- Deian Stefan +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org, vs@foldr.org, deian@cs.stanford.edu +-- Stability : provisional +-- Portability : non-portable (requires POSIX) +-- +-- POSIX temporary file and directory creation functions. +-- +----------------------------------------------------------------------------- + +module System.Posix.Temp.PosixString ( + mkstemp, mkstemps, mkdtemp + ) where + +#include "HsUnix.h" + +import qualified System.OsPath.Data.ByteString.Short as BC +import Data.Word + +import Foreign.C + +import System.OsPath.Types +import System.IO +import System.Posix.PosixPath.FilePath +import System.OsString.Internal.Types (PosixString(..)) +#if !HAVE_MKDTEMP +import System.Posix.Directory.PosixPath (createDirectory) +#endif +import System.Posix.IO.PosixString +import System.Posix.Types + +foreign import capi unsafe "HsUnix.h mkstemp" + c_mkstemp :: CString -> IO CInt + +-- | Make a unique filename and open it for reading\/writing. The returned +-- 'PosixPath' is the (possibly relative) path of the created file, which is +-- padded with 6 random characters. The argument is the desired prefix of the +-- filepath of the temporary file to be created. +-- +-- If you aren't using GHC or Hugs then this function simply wraps mktemp and +-- so shouldn't be considered safe. +mkstemp :: PosixString -> IO (PosixPath, Handle) +mkstemp (PosixString template') = do + let template = PosixString $ template' `BC.append` (BC.pack [_X,_X,_X,_X,_X,_X]) + withFilePath template $ \ ptr -> do + fd <- throwErrnoIfMinus1 "mkstemp" (c_mkstemp ptr) + name <- peekFilePath ptr + h <- fdToHandle (Fd fd) + return (name, h) + +#if HAVE_MKSTEMPS +foreign import capi unsafe "HsUnix.h mkstemps" + c_mkstemps :: CString -> CInt -> IO CInt +#endif + +-- |'mkstemps' - make a unique filename with a given prefix and suffix +-- and open it for reading\/writing (only safe on GHC & Hugs). +-- The returned 'PosixPath' is the (possibly relative) path of +-- the created file, which contains 6 random characters in between +-- the prefix and suffix. +mkstemps :: PosixString -> PosixString -> IO (PosixPath, Handle) +#if HAVE_MKSTEMPS +mkstemps (PosixString prefix) (PosixString suffix) = do + let template = PosixString $ prefix `BC.append` (BC.pack [_X,_X,_X,_X,_X,_X]) `BC.append` suffix + lenOfsuf = (fromIntegral $ BC.length suffix) :: CInt + withFilePath template $ \ ptr -> do + fd <- throwErrnoIfMinus1 "mkstemps" (c_mkstemps ptr lenOfsuf) + name <- peekFilePath ptr + h <- fdToHandle (Fd fd) + return (name, h) +#else +mkstemps = error "System.Posix.Temp.mkstemps: not available on this platform" +#endif + +#if HAVE_MKDTEMP +foreign import capi unsafe "HsUnix.h mkdtemp" + c_mkdtemp :: CString -> IO CString +#endif + +-- | Make a unique directory. The returned 'PosixPath' is the path of the +-- created directory, which is padded with 6 random characters. The argument is +-- the desired prefix of the filepath of the temporary directory to be created. +-- +-- If you aren't using GHC or Hugs then this function simply wraps mktemp and +-- so shouldn't be considered safe. +mkdtemp :: PosixString -> IO PosixPath +mkdtemp (PosixString template') = do + let template = PosixString $ template' `BC.append` (BC.pack [_X,_X,_X,_X,_X,_X]) +#if HAVE_MKDTEMP + withFilePath template $ \ ptr -> do + _ <- throwErrnoIfNull "mkdtemp" (c_mkdtemp ptr) + name <- peekFilePath ptr + return name +#else + name <- mktemp template + h <- createDirectory name (toEnum 0o700) + return name +#endif + +#if !HAVE_MKDTEMP + +foreign import ccall unsafe "mktemp" + c_mktemp :: CString -> IO CString + +-- | Make a unique file name It is required that the template have six trailing +-- \'X\'s. This function should be considered deprecated. +{-# WARNING mktemp "This function is unsafe; use mkstemp instead" #-} +mktemp :: PosixString -> IO PosixPath +mktemp template = do + withFilePath template $ \ ptr -> do + ptr <- throwErrnoIfNull "mktemp" (c_mktemp ptr) + peekFilePath ptr +#endif + +_X :: Word8 +_X = 0x58 + diff --git a/System/Posix/Terminal/PosixString.hsc b/System/Posix/Terminal/PosixString.hsc new file mode 100644 index 00000000..a62f2bb6 --- /dev/null +++ b/System/Posix/Terminal/PosixString.hsc @@ -0,0 +1,211 @@ +{-# LANGUAGE CApiFFI #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Terminal.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 Terminal support +-- +----------------------------------------------------------------------------- + +module System.Posix.Terminal.PosixString ( + -- * Terminal support + + -- ** Terminal attributes + TerminalAttributes, + getTerminalAttributes, + TerminalState(..), + setTerminalAttributes, + + TerminalMode(..), + withoutMode, + withMode, + terminalMode, + bitsPerByte, + withBits, + + ControlCharacter(..), + controlChar, + withCC, + withoutCC, + + inputTime, + withTime, + minInput, + withMinInput, + + BaudRate(..), + inputSpeed, + withInputSpeed, + outputSpeed, + withOutputSpeed, + + -- ** Terminal operations + sendBreak, + drainOutput, + QueueSelector(..), + discardData, + FlowAction(..), + controlFlow, + + -- ** Process groups + getTerminalProcessGroupID, + setTerminalProcessGroupID, + + -- ** Testing a file descriptor + queryTerminal, + getTerminalName, + getControllingTerminalName, + + -- ** Pseudoterminal operations + openPseudoTerminal, + getSlaveTerminalName + ) where + +#include "HsUnix.h" + +import Foreign +import System.Posix.Types +import System.Posix.Terminal.Common +#ifndef HAVE_OPENPTY +import qualified System.OsPath.Data.ByteString.Short as SBS +import System.Posix.IO.ByteString (defaultFileFlags, openFd, noctty, OpenMode(ReadWrite)) +import Data.ByteString.Char8 as B ( pack, ) +import qualified System.OsPath.Data.ByteString.Short as BC +import System.OsString.Internal.Types (PosixString(..)) +#endif + +import Foreign.C hiding ( + throwErrnoPath, + throwErrnoPathIf, + throwErrnoPathIf_, + throwErrnoPathIfNull, + throwErrnoPathIfMinus1, + throwErrnoPathIfMinus1_ ) + +import System.OsPath.Types +import System.Posix.PosixPath.FilePath + +#if !(HAVE_CTERMID && defined(HAVE_TERMIOS_H)) +import System.IO.Error ( ioeSetLocation ) +import GHC.IO.Exception ( unsupportedOperation ) +#endif + +-- | @getTerminalName fd@ calls @ttyname@ to obtain a name associated +-- with the terminal for @Fd@ @fd@. If @fd@ is associated +-- with a terminal, @getTerminalName@ returns the name of the +-- terminal. +getTerminalName :: Fd -> IO PosixPath +getTerminalName (Fd fd) = do + s <- throwErrnoIfNull "getTerminalName" (c_ttyname fd) + peekFilePath s + +foreign import ccall unsafe "ttyname" + c_ttyname :: CInt -> IO CString + +-- | @getControllingTerminalName@ calls @ctermid@ to obtain +-- a name associated with the controlling terminal for the process. If a +-- controlling terminal exists, +-- @getControllingTerminalName@ returns the name of the +-- controlling terminal. +-- +-- Throws 'IOError' (\"unsupported operation\") if platform does not +-- provide @ctermid(3)@ (use @#if HAVE_CTERMID@ CPP guard to +-- detect availability). +getControllingTerminalName :: IO PosixPath +#if HAVE_CTERMID && defined(HAVE_TERMIOS_H) +getControllingTerminalName = do + s <- throwErrnoIfNull "getControllingTerminalName" (c_ctermid nullPtr) + peekFilePath s + +foreign import capi unsafe "termios.h ctermid" + c_ctermid :: CString -> IO CString +#else +{-# WARNING getControllingTerminalName + "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_CTERMID@)" #-} +getControllingTerminalName = ioError (ioeSetLocation unsupportedOperation "getControllingTerminalName") +#endif + +-- | @getSlaveTerminalName@ calls @ptsname@ to obtain the name of the +-- slave terminal associated with a pseudoterminal pair. The file +-- descriptor to pass in must be that of the master. +getSlaveTerminalName :: Fd -> IO PosixPath + +#ifdef HAVE_PTSNAME +getSlaveTerminalName (Fd fd) = do + s <- throwErrnoIfNull "getSlaveTerminalName" (c_ptsname fd) + peekFilePath s + +foreign import capi unsafe "HsUnix.h ptsname" + c_ptsname :: CInt -> IO CString +#else +{-# WARNING getSlaveTerminalName "getSlaveTerminalName: not available on this platform" #-} +getSlaveTerminalName _ = + ioError (errnoToIOError "getSlaveTerminalName" eNOSYS Nothing Nothing) +#endif + +-- ----------------------------------------------------------------------------- +-- openPseudoTerminal needs to be here because it depends on +-- getSlaveTerminalName. + +-- | @openPseudoTerminal@ creates a pseudoterminal (pty) pair, and +-- returns the newly created pair as a (@master@, @slave@) tuple. +openPseudoTerminal :: IO (Fd, Fd) + +#ifdef HAVE_OPENPTY +openPseudoTerminal = + alloca $ \p_master -> + alloca $ \p_slave -> do + throwErrnoIfMinus1_ "openPty" + (c_openpty p_master p_slave nullPtr nullPtr nullPtr) + master <- peek p_master + slave <- peek p_slave + return (Fd master, Fd slave) + +foreign import ccall unsafe "openpty" + c_openpty :: Ptr CInt -> Ptr CInt -> CString -> Ptr CTermios -> Ptr a + -> IO CInt +#else +openPseudoTerminal = do + (Fd master) <- openFd (B.pack "/dev/ptmx") ReadWrite + defaultFileFlags{noctty=True} + throwErrnoIfMinus1_ "openPseudoTerminal" (c_grantpt master) + throwErrnoIfMinus1_ "openPseudoTerminal" (c_unlockpt master) + slaveName <- getSlaveTerminalName (Fd master) + slave <- openFd (SBS.fromShort . getPosixString $ slaveName) ReadWrite defaultFileFlags{noctty=True} + pushModule slave "ptem" + pushModule slave "ldterm" +# ifndef __hpux + pushModule slave "ttcompat" +# endif /* __hpux */ + return (Fd master, slave) + +-- Push a STREAMS module, for System V systems. +pushModule :: Fd -> String -> IO () +pushModule (Fd fd) name = + withCString name $ \p_name -> + throwErrnoIfMinus1_ "openPseudoTerminal" + (c_push_module fd p_name) + +foreign import ccall unsafe "__hsunix_push_module" + c_push_module :: CInt -> CString -> IO CInt + +#if HAVE_PTSNAME +foreign import capi unsafe "HsUnix.h grantpt" + c_grantpt :: CInt -> IO CInt + +foreign import capi unsafe "HsUnix.h unlockpt" + c_unlockpt :: CInt -> IO CInt +#else +c_grantpt :: CInt -> IO CInt +c_grantpt _ = return (fromIntegral (0::Int)) + +c_unlockpt :: CInt -> IO CInt +c_unlockpt _ = return (fromIntegral (0::Int)) +#endif /* HAVE_PTSNAME */ +#endif /* !HAVE_OPENPTY */ diff --git a/cabal.project b/cabal.project index 586737c7..50c6c320 100644 --- a/cabal.project +++ b/cabal.project @@ -1,4 +1,5 @@ packages: . + tests: True constraints: diff --git a/cabal.project.wasm32-wasi b/cabal.project.wasm32-wasi index f6e34e22..87a3e351 100644 --- a/cabal.project.wasm32-wasi +++ b/cabal.project.wasm32-wasi @@ -5,4 +5,4 @@ package unix write-ghc-environment-files: always -allow-newer: all:base +allow-newer: all:base, all:filepath diff --git a/unix.cabal b/unix.cabal index 081e49f5..a297c5d5 100644 --- a/unix.cabal +++ b/unix.cabal @@ -70,11 +70,13 @@ library build-depends: base >= 4.10 && < 4.17, bytestring >= 0.9.2 && < 0.12, + filepath >= 1.4.100.0, time >= 1.2 && < 1.13 exposed-modules: System.Posix System.Posix.ByteString + System.Posix.PosixString System.Posix.Error System.Posix.Resource @@ -87,11 +89,13 @@ library System.Posix.SharedMem System.Posix.ByteString.FilePath + System.Posix.PosixPath.FilePath System.Posix.Directory System.Posix.Directory.Internals System.Posix.Directory.Fd System.Posix.Directory.ByteString + System.Posix.Directory.PosixPath System.Posix.DynamicLinker.Module System.Posix.DynamicLinker.Module.ByteString @@ -101,24 +105,30 @@ library System.Posix.Files System.Posix.Files.ByteString + System.Posix.Files.PosixString System.Posix.IO System.Posix.IO.ByteString + System.Posix.IO.PosixString System.Posix.Env System.Posix.Env.ByteString + System.Posix.Env.PosixString System.Posix.Fcntl System.Posix.Process System.Posix.Process.Internals System.Posix.Process.ByteString + System.Posix.Process.PosixString System.Posix.Temp System.Posix.Temp.ByteString + System.Posix.Temp.PosixString System.Posix.Terminal System.Posix.Terminal.ByteString + System.Posix.Terminal.PosixString other-modules: System.Posix.Directory.Common From 6037a3766860bba8d42eaf53a19ae862d3b7b46f Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sun, 17 Jul 2022 02:22:02 +0200 Subject: [PATCH 2/2] Raise timeout --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 5e176cc8..d166a227 100644 --- a/.github/workflows/ci.yml +++ b/.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