{-# LANGUAGE CApiFFI #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE ViewPatterns #-}
module System.Posix.Pty (
spawnWithPty
, Pty
, PtyControlCode (..)
, createPty
, closePty
, tryReadPty
, readPty
, writePty
, resizePty
, ptyDimensions
, threadWaitReadPty
, threadWaitWritePty
, threadWaitReadPtySTM
, threadWaitWritePtySTM
, getTerminalAttributes
, setTerminalAttributes
, sendBreak
, drainOutput
, discardData
, controlFlow
, getTerminalProcessGroupID
, getTerminalName
, getSlaveTerminalName
, module System.Posix.Terminal
) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Exception (bracket, throwIO, ErrorCall(..))
import Control.Monad (when)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS (createAndTrim)
import qualified Data.ByteString.Unsafe as BS (unsafeUseAsCString)
import GHC.Conc (STM)
import GHC.Conc.IO (threadWaitRead, threadWaitWrite,
threadWaitReadSTM, threadWaitWriteSTM)
import Foreign
import Foreign.C.Error (throwErrnoIfMinus1Retry, throwErrnoIfMinus1Retry_)
import Foreign.C.String (CString, newCString)
import Foreign.C.Types
import System.IO.Error (mkIOError, eofErrorType)
import System.Posix.IO (fdReadBuf, fdWriteBuf,closeFd)
import System.Posix.Types
import System.Process.Internals (mkProcessHandle, ProcessHandle)
import qualified System.Posix.Terminal as T
import System.Posix.Terminal hiding
( getTerminalAttributes
, setTerminalAttributes
, sendBreak
, drainOutput
, discardData
, controlFlow
, getTerminalProcessGroupID
, setTerminalProcessGroupID
, queryTerminal
, getTerminalName
, openPseudoTerminal
, getSlaveTerminalName)
newtype Pty = Pty Fd
data PtyControlCode = FlushRead
| FlushWrite
| OutputStopped
| OutputStarted
| DoStop
| NoStop
deriving (Eq, Read, Show)
createPty :: Fd -> IO (Maybe Pty)
createPty fd = do
isTerminal <- T.queryTerminal fd
let result | isTerminal = Just (Pty fd)
| otherwise = Nothing
return result
closePty :: Pty -> IO ()
closePty (Pty fd) = closeFd fd
tryReadPty :: Pty -> IO (Either [PtyControlCode] ByteString)
tryReadPty (Pty fd) = do
result <- readBS 1024
case BS.uncons result of
Nothing -> ioError ptyClosed
Just (byte, rest)
| byte == 0 -> return (Right rest)
| BS.null rest -> return $ Left (byteToControlCode byte)
| otherwise -> ioError can'tHappen
where
ptyClosed :: IOError
ptyClosed = mkIOError eofErrorType "pty terminated" Nothing Nothing
can'tHappen :: IOError
can'tHappen = userError "Uh-oh! Something different went horribly wrong!"
readBS :: ByteCount -> IO ByteString
readBS n
| n <= 0 = return BS.empty
| overflow = throwIO (ErrorCall "invalid size for read")
| otherwise = BS.createAndTrim (fromIntegral n) $
fmap fromIntegral . fillBuf
where
overflow :: Bool
overflow = n >= fromIntegral (maxBound :: Int)
fillBuf :: Ptr Word8 -> IO ByteCount
fillBuf buf = throwErrnoIfMinus1Retry "read failed" $
fdReadBuf fd buf n
readPty :: Pty -> IO ByteString
readPty pty = tryReadPty pty >>= \case
Left _ -> readPty pty
Right bs -> return bs
writePty :: Pty -> ByteString -> IO ()
writePty (Pty fd) bs =
BS.unsafeUseAsCString bs $ write (fromIntegral (BS.length bs)) . castPtr
where
write :: ByteCount -> Ptr Word8 -> IO ()
write len buf = do
res <- throwErrnoIfMinus1Retry "write failed" $ fdWriteBuf fd buf len
when (res < len) $ do
write (len - res) $ plusPtr buf (fromIntegral res)
resizePty :: Pty -> (Int, Int) -> IO ()
resizePty (Pty fd) (x, y) =
throwErrnoIfMinus1Retry_ "unable to set pty dimensions" $ set_pty_size fd x y
ptyDimensions :: Pty -> IO (Int, Int)
ptyDimensions (Pty fd) = alloca $ \x -> alloca $ \y -> do
throwErrnoIfMinus1Retry_ "unable to get pty size" $ get_pty_size fd x y
(,) <$> peek x <*> peek y
spawnWithPty :: Maybe [(String, String)]
-> Bool
-> FilePath
-> [String]
-> (Int, Int)
-> IO (Pty, ProcessHandle)
spawnWithPty env' (fromBool -> search) path' argv' (x, y) = do
bracket allocStrings cleanupStrings $ \(path, argvList, envList) -> do
let allocLists = do
argv <- newArray0 nullPtr (path : argvList)
env <- case envList of
[] -> return nullPtr
_ -> newArray0 nullPtr envList
return (argv, env)
cleanupLists (argv, env) = free argv >> free env
bracket allocLists cleanupLists $ \(argv, env) -> do
alloca $ \pidPtr -> do
fd <- throwErrnoIfMinus1Retry "failed to fork or open pty" $
fork_exec_with_pty x y search path argv env pidPtr
pid <- peek pidPtr
handle <- mkProcessHandle (fromIntegral pid) True
return (Pty fd, handle)
where
fuse :: (String, String) -> IO CString
fuse (key, val) = newCString (key ++ "=" ++ val)
allocStrings :: IO (CString, [CString], [CString])
allocStrings = do
path <- newCString path'
argv <- mapM newCString argv'
env <- maybe (return []) (mapM fuse) env'
return (path, argv, env)
cleanupStrings :: (CString, [CString], [CString]) -> IO ()
cleanupStrings (path, argv, env) = do
free path
mapM_ free argv
mapM_ free env
getFd :: Pty -> Fd
getFd (Pty fd) = fd
byteToControlCode :: Word8 -> [PtyControlCode]
byteToControlCode i = map snd $ filter ((/=0) . (.&.i) . fst) codeMapping
where codeMapping :: [(Word8, PtyControlCode)]
codeMapping =
[ (tiocPktFlushRead, FlushRead)
, (tiocPktFlushWrite, FlushWrite)
, (tiocPktStop, OutputStopped)
, (tiocPktStart, OutputStarted)
, (tiocPktDoStop, DoStop)
, (tiocPktNoStop, NoStop)
]
foreign import capi unsafe "sys/ioctl.h value TIOCPKT_FLUSHREAD"
tiocPktFlushRead :: Word8
foreign import capi unsafe "sys/ioctl.h value TIOCPKT_FLUSHWRITE"
tiocPktFlushWrite :: Word8
foreign import capi unsafe "sys/ioctl.h value TIOCPKT_STOP"
tiocPktStop :: Word8
foreign import capi unsafe "sys/ioctl.h value TIOCPKT_START"
tiocPktStart :: Word8
foreign import capi unsafe "sys/ioctl.h value TIOCPKT_DOSTOP"
tiocPktDoStop :: Word8
foreign import capi unsafe "sys/ioctl.h value TIOCPKT_NOSTOP"
tiocPktNoStop :: Word8
foreign import ccall "pty_size.h"
set_pty_size :: Fd -> Int -> Int -> IO CInt
foreign import ccall "pty_size.h"
get_pty_size :: Fd -> Ptr Int -> Ptr Int -> IO CInt
foreign import ccall "fork_exec_with_pty.h"
fork_exec_with_pty :: Int
-> Int
-> CInt
-> CString
-> Ptr CString
-> Ptr CString
-> Ptr Int
-> IO Fd
threadWaitReadPty :: Pty -> IO ()
threadWaitReadPty = threadWaitRead . getFd
threadWaitWritePty :: Pty -> IO ()
threadWaitWritePty = threadWaitWrite . getFd
threadWaitReadPtySTM :: Pty -> IO (STM (), IO ())
threadWaitReadPtySTM = threadWaitReadSTM . getFd
threadWaitWritePtySTM :: Pty -> IO (STM (), IO ())
threadWaitWritePtySTM = threadWaitWriteSTM . getFd
getTerminalAttributes :: Pty -> IO TerminalAttributes
getTerminalAttributes = T.getTerminalAttributes . getFd
setTerminalAttributes :: Pty -> TerminalAttributes -> TerminalState -> IO ()
setTerminalAttributes = T.setTerminalAttributes . getFd
sendBreak :: Pty -> Int -> IO ()
sendBreak = T.sendBreak . getFd
drainOutput :: Pty -> IO ()
drainOutput = T.drainOutput . getFd
discardData :: Pty -> QueueSelector -> IO ()
discardData = T.discardData . getFd
controlFlow :: Pty -> FlowAction -> IO ()
controlFlow = T.controlFlow . getFd
getTerminalProcessGroupID :: Pty -> IO ProcessGroupID
getTerminalProcessGroupID = T.getTerminalProcessGroupID . getFd
getTerminalName :: Pty -> IO FilePath
getTerminalName = T.getTerminalName . getFd
getSlaveTerminalName :: Pty -> IO FilePath
getSlaveTerminalName = T.getSlaveTerminalName . getFd