{-
Modified by Michael Sloan, FP Complete, in 2015
Copyright 2012-2013 Google Inc. All Rights Reserved.
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
-- | Modified by Michael Sloan, FP Complete, in 2015
--
-- Based on https://github.com/mzero/plush/blob/ffa6c84f7bcb7bd57079e9a519e2bdc1ae07b4be/src/System/Posix/Missing.hsc
module Posix (
dupFd, dupFdCloseOnExec,
loginTerminal,
setControllingTerminal,
getArg0,
executeFile0,
-- * From Plush.Run.Posix.IO
write,
readChunk
) where
import Control.Applicative ((<$>))
import Control.Arrow (second)
import Control.Exception (throwIO)
import Control.Monad (when, void)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Internal as BS (createAndTrim)
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import Foreign (withArray0, withMany)
import Foreign.C (CInt(..), CString, CULong(..),
throwErrnoIfMinus1, throwErrnoIfMinus1_, throwErrnoPathIfMinus1_)
import Foreign.Ptr (Ptr, nullPtr, castPtr, plusPtr)
import Foreign.Ptr (nullPtr, Ptr)
import Foreign.Safe (alloca, peek, peekElemOff)
import GHC.Foreign (peekCString)
import GHC.IO.Device (SeekMode(SeekFromEnd, AbsoluteSeek))
import GHC.IO.Encoding (getFileSystemEncoding)
import GHC.IO.Exception (IOErrorType(UnsupportedOperation))
import System.IO.Error (ioeGetErrorType, catchIOError)
import System.Posix.IO (fdReadBuf, fdSeek, fdWriteBuf, setFdOption, FdOption(CloseOnExec))
import System.Posix.Internals (c_fcntl_write, FD, withFilePath)
import System.Posix.Process.Internals (pPrPr_disableITimers)
import System.Posix.Types (Fd(Fd))
#include "HsUnix.h"
-- | This is like 'dup', but takes an extra argument. The new file descriptor
-- will be the lowest free file descriptor not less than the second argument.
-- The 'CloseOnExec' flag (FD_CLOEXEC) will be cleared on the new descriptor.
dupFd :: Fd -> Fd -> IO Fd
dupFd = dupFdViaFcntl (#const F_DUPFD)
-- | Same as 'dupFd', but the 'CloseOnExec' flag (FD_CLOEXEC) will be set.
dupFdCloseOnExec :: Fd -> Fd -> IO Fd
-- dupFdCloseOnExec = dupFdViaFcntl (#const F_DUPFD_CLOEXEC)
-- While this is POSIX, is is relatively new, and many systems do not
-- support this operation. The following code simulates it.
dupFdCloseOnExec src base = do
dest <- dupFd src base
setFdOption dest CloseOnExec True
return dest
dupFdViaFcntl :: CInt -> Fd -> Fd -> IO Fd
dupFdViaFcntl op (Fd srcFd) (Fd minFd) = Fd `fmap`
throwErrnoIfMinus1 "dupFdViaFcntl"
(c_fcntl_write srcFd op (fromIntegral minFd))
-- | Prepares for login on the tty, which should be a real tty or the slave
-- from a call to `openPseudoTerminal`. A new session will be started, the tty
-- will become the controlling terminal, and the tty is dup'd down to become
-- the standard in, out and err FDs.
loginTerminal :: Fd -> IO ()
#ifdef HAVE_OPENPTY
-- In theory this should be testing HAVE_LOGIN_TTY, but that doesn't exist.
-- The calls login_tty, openpty, and forkpty are part of the same BSD module
-- and so are all generally present together or not.
loginTerminal (Fd ttyFd) =
throwErrnoIfMinus1_ "loginTerminal" (c_login_tty ttyFd)
foreign import ccall unsafe "login_tty"
c_login_tty :: CInt -> IO CInt
#else
loginTerminal tty = do
_ <- createSession
setControllingTerminal tty
_ <- dupTo tty stdInput
_ <- dupTo tty stdOutput
_ <- dupTo tty stdError
when (tty > stdError) $ closeFd tty
#endif
-- | Set the controlling terminal of the process. The tty should be a real tty
-- or the slave from a call to 'openPseudoTerminal'.
setControllingTerminal :: Fd -> IO ()
#ifdef TIOCSCTTY
setControllingTerminal (Fd ttyfd) =
throwErrnoIfMinus1_ "setControllingTerminal"
(ioctl ttyfd (#const TIOCSCTTY) nullPtr)
foreign import ccall ioctl :: FD -> CULong -> Ptr a -> IO CInt
#else
-- POSIX doesn't spec how to set the controlling terminal! The ioctl TIOSCTTY
-- method above is generally available, but some systems don't have it. The
-- second most common way to set the controlling terminal is to open it when no
-- other terminal is opened in the process. That is what this alternative
-- implementation does. Be forewarned that they may be systems that use yet some
-- third unknown method.
setControllingTerminal tty = do
ttyName <- getTerminalName tty
when (tty /= stdInput) $ closeFd stdInput
when (tty /= stdOutput) $ closeFd stdOutput
when (tty /= stdError) $ closeFd stdError
openFd ttyName ReadWrite Nothing defaultFileFlags >>= closeFd
#endif
-- | Return @argv[0]@ as passed to the program on invocation. Unlike
-- 'getProgName', this is the raw value passed to the process. It may, or may
-- not, have anything to do with the name of the running executable!
getArg0 :: IO String
getArg0 =
alloca $ \ p_argc ->
alloca $ \ p_argv -> do
getProgArgv p_argc p_argv
argv <- peek p_argv
enc <- getFileSystemEncoding
peekElemOff argv 0 >>= peekCString enc
foreign import ccall unsafe "getProgArgv"
getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()
-- | Like 'executeFile', but allow for expressly setting @argv[0]@
-- For simplicity, this version has no path search option, and always takes an
-- environment. If incorporating into System.Posix.Process, the signature
-- should better match 'executeFile'.
executeFile0 :: FilePath -> String -> [String] -> [(String, String)] -> IO a
executeFile0 path cmd args env = do
withFilePath path $ \s ->
withMany withFilePath (cmd:args) $ \cstrs ->
withArray0 nullPtr cstrs $ \arg_arr ->
let env' = map (\ (name, val) -> name ++ ('=' : val)) env in
withMany withFilePath env' $ \cenv ->
withArray0 nullPtr cenv $ \env_arr -> do
pPrPr_disableITimers
throwErrnoPathIfMinus1_ "executeFile" path
(c_execve s arg_arr env_arr)
return undefined -- never reached
foreign import ccall unsafe "execve"
c_execve :: CString -> Ptr CString -> Ptr CString -> IO CInt
-- Copied from Plush.Run.Posix
-- https://github.com/mzero/plush/blob/ffa6c84f7bcb7bd57079e9a519e2bdc1ae07b4be/src/Plush/Run/Posix.hs
-- | Based on code for readLoop, but instead expects a blocking Fd.
readChunk :: Fd -> IO BS.ByteString
readChunk fd =
BS.createAndTrim bufSize $ \buf ->
fmap fromIntegral (fdReadBuf fd buf (fromIntegral bufSize))
where
bufSize = 4096
-- | 'write' for 'IO': Seek to the end, and write.
--
-- Modified to take a strict bytestring
write :: Fd -> BS.ByteString -> IO ()
write fd bs = unsafeUseAsCStringLen bs writeBuf
where
writeBuf (p, n) | n > 0 = do
ignoreUnsupportedOperation $ fdSeek fd SeekFromEnd 0
m <- fromIntegral `fmap` fdWriteBuf fd (castPtr p) (fromIntegral n)
when (0 <= m && m <= n) $ writeBuf (p `plusPtr` m, n - m)
writeBuf _ = return ()
ignoreUnsupportedOperation :: IO a -> IO ()
ignoreUnsupportedOperation act = void act `catchIOError` \ex ->
if ioeGetErrorType ex == UnsupportedOperation
then return ()
else throwIO ex