{-# LANGUAGE CApiFFI #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE ViewPatterns #-}
-------------------------------------------------------------------------------
-- |
-- Module      :  System.Posix.Pty
-- Copyright   :  (C) 2013 Merijn Verstraaten
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Merijn Verstraaten <merijn@inconsistent.nl>
-- Stability   :  experimental
-- Portability :  haha
--
-- A module for interacting with subprocesses through a pseudo terminal (pty).
-- Provides functions for reading from, writing to and resizing pseudo
-- terminals. Re-exports most of "System.Posix.Terminal", providing wrappers
-- that work with the 'Pty' type where necessary.
-------------------------------------------------------------------------------
module System.Posix.Pty (
    -- * Subprocess Creation
      spawnWithPty
    -- * Data Structures
    , Pty
    , PtyControlCode (..)
    -- * Pty Interaction Functions
    , createPty
    , closePty
    , tryReadPty
    , readPty
    , writePty
    , resizePty
    , ptyDimensions
    -- * Blocking on 'Pty's
    , threadWaitReadPty
    , threadWaitWritePty
    , threadWaitReadPtySTM
    , threadWaitWritePtySTM
    -- * Re-exports of "System.Posix.Terminal"
    -- $posix-reexport
    , getTerminalAttributes
    , setTerminalAttributes
    , sendBreak
    , drainOutput
    , discardData
    , controlFlow
    , getTerminalProcessGroupID
    , getTerminalName
    , getSlaveTerminalName
    , module System.Posix.Terminal
    ) where

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif

import Control.Concurrent (withMVar)
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, runInteractiveProcess_lock, 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)

-- | Abstract pseudo terminal type.
newtype Pty = Pty Fd

-- | Pseudo terminal control information.
--
-- [Terminal read queue] The terminal read queue contains the data that was
-- written from the master terminal to the slave terminal, which was not read
-- from the slave yet.
--
-- [Terminal write queue] The terminal write queue contains the data that was
-- written from the slave terminal, which was not sent to the master yet.
data PtyControlCode = FlushRead     -- ^ Terminal read queue was flushed.
                    | FlushWrite    -- ^ Terminal write queue was flushed.
                    | OutputStopped -- ^ Terminal output was stopped.
                    | OutputStarted -- ^ Terminal output was restarted.
                    | DoStop        -- ^ Terminal stop and start characters are
                                    --   @^S@ and @^Q@ respectively.
                    | NoStop        -- ^ Terminal stop and start characters are
                                    --   NOT @^S@ and @^Q@.
                    deriving (PtyControlCode -> PtyControlCode -> Bool
(PtyControlCode -> PtyControlCode -> Bool)
-> (PtyControlCode -> PtyControlCode -> Bool) -> Eq PtyControlCode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PtyControlCode -> PtyControlCode -> Bool
$c/= :: PtyControlCode -> PtyControlCode -> Bool
== :: PtyControlCode -> PtyControlCode -> Bool
$c== :: PtyControlCode -> PtyControlCode -> Bool
Eq, ReadPrec [PtyControlCode]
ReadPrec PtyControlCode
Int -> ReadS PtyControlCode
ReadS [PtyControlCode]
(Int -> ReadS PtyControlCode)
-> ReadS [PtyControlCode]
-> ReadPrec PtyControlCode
-> ReadPrec [PtyControlCode]
-> Read PtyControlCode
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PtyControlCode]
$creadListPrec :: ReadPrec [PtyControlCode]
readPrec :: ReadPrec PtyControlCode
$creadPrec :: ReadPrec PtyControlCode
readList :: ReadS [PtyControlCode]
$creadList :: ReadS [PtyControlCode]
readsPrec :: Int -> ReadS PtyControlCode
$creadsPrec :: Int -> ReadS PtyControlCode
Read, Int -> PtyControlCode -> ShowS
[PtyControlCode] -> ShowS
PtyControlCode -> String
(Int -> PtyControlCode -> ShowS)
-> (PtyControlCode -> String)
-> ([PtyControlCode] -> ShowS)
-> Show PtyControlCode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PtyControlCode] -> ShowS
$cshowList :: [PtyControlCode] -> ShowS
show :: PtyControlCode -> String
$cshow :: PtyControlCode -> String
showsPrec :: Int -> PtyControlCode -> ShowS
$cshowsPrec :: Int -> PtyControlCode -> ShowS
Show)

-- | Produces a 'Pty' if the file descriptor is associated with a terminal and
-- Nothing if not.
createPty :: Fd -> IO (Maybe Pty)
createPty :: Fd -> IO (Maybe Pty)
createPty Fd
fd = do
    Bool
isTerminal <- Fd -> IO Bool
T.queryTerminal Fd
fd
    let result :: Maybe Pty
result | Bool
isTerminal = Pty -> Maybe Pty
forall a. a -> Maybe a
Just (Fd -> Pty
Pty Fd
fd)
               | Bool
otherwise  = Maybe Pty
forall a. Maybe a
Nothing
    Maybe Pty -> IO (Maybe Pty)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Pty
result

-- | Close this pseudo terminal.
closePty :: Pty -> IO ()
closePty :: Pty -> IO ()
closePty (Pty Fd
fd) = Fd -> IO ()
closeFd Fd
fd

-- | Attempt to read data from a pseudo terminal. Produces either the data read
-- or a list of 'PtyControlCode'@s@ indicating which control status events that
-- have happened on the slave terminal.
--
-- Throws an 'IOError' of type 'eofErrorType' when the terminal has been
-- closed, for example when the subprocess has terminated.
tryReadPty :: Pty -> IO (Either [PtyControlCode] ByteString)
tryReadPty :: Pty -> IO (Either [PtyControlCode] ByteString)
tryReadPty (Pty Fd
fd) = do
    ByteString
result <- ByteCount -> IO ByteString
readBS ByteCount
1024
    case ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
result of
         Maybe (Word8, ByteString)
Nothing -> IOError -> IO (Either [PtyControlCode] ByteString)
forall a. IOError -> IO a
ioError IOError
ptyClosed
         Just (Word8
byte, ByteString
rest)
            | Word8
byte Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0    -> Either [PtyControlCode] ByteString
-> IO (Either [PtyControlCode] ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Either [PtyControlCode] ByteString
forall a b. b -> Either a b
Right ByteString
rest)
            | ByteString -> Bool
BS.null ByteString
rest -> Either [PtyControlCode] ByteString
-> IO (Either [PtyControlCode] ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [PtyControlCode] ByteString
 -> IO (Either [PtyControlCode] ByteString))
-> Either [PtyControlCode] ByteString
-> IO (Either [PtyControlCode] ByteString)
forall a b. (a -> b) -> a -> b
$ [PtyControlCode] -> Either [PtyControlCode] ByteString
forall a b. a -> Either a b
Left (Word8 -> [PtyControlCode]
byteToControlCode Word8
byte)
            | Bool
otherwise    -> IOError -> IO (Either [PtyControlCode] ByteString)
forall a. IOError -> IO a
ioError IOError
can'tHappen
  where
    ptyClosed :: IOError
    ptyClosed :: IOError
ptyClosed = IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
eofErrorType String
"pty terminated" Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing

    can'tHappen :: IOError
    can'tHappen :: IOError
can'tHappen = String -> IOError
userError String
"Uh-oh! Something different went horribly wrong!"

    readBS :: ByteCount -> IO ByteString
    readBS :: ByteCount -> IO ByteString
readBS ByteCount
n
      | ByteCount
n ByteCount -> ByteCount -> Bool
forall a. Ord a => a -> a -> Bool
<= ByteCount
0    = ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
BS.empty
      | Bool
overflow  = ErrorCall -> IO ByteString
forall e a. Exception e => e -> IO a
throwIO (String -> ErrorCall
ErrorCall String
"invalid size for read")
      | Bool
otherwise = Int -> (Ptr Word8 -> IO Int) -> IO ByteString
BS.createAndTrim (ByteCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteCount
n) ((Ptr Word8 -> IO Int) -> IO ByteString)
-> (Ptr Word8 -> IO Int) -> IO ByteString
forall a b. (a -> b) -> a -> b
$
                        (ByteCount -> Int) -> IO ByteCount -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IO ByteCount -> IO Int)
-> (Ptr Word8 -> IO ByteCount) -> Ptr Word8 -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Word8 -> IO ByteCount
fillBuf
      where
        overflow :: Bool
        overflow :: Bool
overflow = ByteCount
n ByteCount -> ByteCount -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> ByteCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
forall a. Bounded a => a
maxBound :: Int)

        fillBuf :: Ptr Word8 -> IO ByteCount
        fillBuf :: Ptr Word8 -> IO ByteCount
fillBuf Ptr Word8
buf = String -> IO ByteCount -> IO ByteCount
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1Retry String
"read failed" (IO ByteCount -> IO ByteCount) -> IO ByteCount -> IO ByteCount
forall a b. (a -> b) -> a -> b
$
                            Fd -> Ptr Word8 -> ByteCount -> IO ByteCount
fdReadBuf Fd
fd Ptr Word8
buf ByteCount
n

-- | The same as 'tryReadPty', but discards any control status events.
readPty :: Pty -> IO ByteString
readPty :: Pty -> IO ByteString
readPty Pty
pty = Pty -> IO (Either [PtyControlCode] ByteString)
tryReadPty Pty
pty IO (Either [PtyControlCode] ByteString)
-> (Either [PtyControlCode] ByteString -> IO ByteString)
-> IO ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                   Left [PtyControlCode]
_ -> Pty -> IO ByteString
readPty Pty
pty
                   Right ByteString
bs -> ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs

-- | Write a 'ByteString' to the pseudo terminal, throws an 'IOError' when the
-- terminal has been closed, for example when the subprocess has terminated.
writePty :: Pty -> ByteString -> IO ()
writePty :: Pty -> ByteString -> IO ()
writePty (Pty Fd
fd) ByteString
bs =
    ByteString -> (CString -> IO ()) -> IO ()
forall a. ByteString -> (CString -> IO a) -> IO a
BS.unsafeUseAsCString ByteString
bs ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteCount -> Ptr Word8 -> IO ()
write (Int -> ByteCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
bs)) (Ptr Word8 -> IO ()) -> (CString -> Ptr Word8) -> CString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr
  where
    write :: ByteCount -> Ptr Word8 -> IO ()
    write :: ByteCount -> Ptr Word8 -> IO ()
write ByteCount
len Ptr Word8
buf = do
        ByteCount
res <- String -> IO ByteCount -> IO ByteCount
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1Retry String
"write failed" (IO ByteCount -> IO ByteCount) -> IO ByteCount -> IO ByteCount
forall a b. (a -> b) -> a -> b
$ Fd -> Ptr Word8 -> ByteCount -> IO ByteCount
fdWriteBuf Fd
fd Ptr Word8
buf ByteCount
len
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteCount
res ByteCount -> ByteCount -> Bool
forall a. Ord a => a -> a -> Bool
< ByteCount
len) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteCount -> Ptr Word8 -> IO ()
write (ByteCount
len ByteCount -> ByteCount -> ByteCount
forall a. Num a => a -> a -> a
- ByteCount
res) (Ptr Word8 -> IO ()) -> Ptr Word8 -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
buf (ByteCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteCount
res)

-- | Set the pseudo terminal's dimensions to the specified width and height.
resizePty :: Pty -> (Int, Int) -> IO ()
resizePty :: Pty -> (Int, Int) -> IO ()
resizePty (Pty Fd
fd) (Int
x, Int
y) =
  String -> IO CInt -> IO ()
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1Retry_ String
"unable to set pty dimensions" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Fd -> Int -> Int -> IO CInt
set_pty_size Fd
fd Int
x Int
y

-- | Produces the pseudo terminal's current dimensions.
ptyDimensions :: Pty -> IO (Int, Int)
ptyDimensions :: Pty -> IO (Int, Int)
ptyDimensions (Pty Fd
fd) = (Ptr Int -> IO (Int, Int)) -> IO (Int, Int)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Int -> IO (Int, Int)) -> IO (Int, Int))
-> (Ptr Int -> IO (Int, Int)) -> IO (Int, Int)
forall a b. (a -> b) -> a -> b
$ \Ptr Int
x -> (Ptr Int -> IO (Int, Int)) -> IO (Int, Int)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Int -> IO (Int, Int)) -> IO (Int, Int))
-> (Ptr Int -> IO (Int, Int)) -> IO (Int, Int)
forall a b. (a -> b) -> a -> b
$ \Ptr Int
y -> do
    String -> IO CInt -> IO ()
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1Retry_ String
"unable to get pty size" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Fd -> Ptr Int -> Ptr Int -> IO CInt
get_pty_size Fd
fd Ptr Int
x Ptr Int
y
    (,) (Int -> Int -> (Int, Int)) -> IO Int -> IO (Int -> (Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Int -> IO Int
forall a. Storable a => Ptr a -> IO a
peek Ptr Int
x IO (Int -> (Int, Int)) -> IO Int -> IO (Int, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr Int -> IO Int
forall a. Storable a => Ptr a -> IO a
peek Ptr Int
y

-- | Create a new process that is connected to the current process through a
-- pseudo terminal. If an environment is specified, then only the specified
-- environment variables will be set. If no environment is specified the
-- process will inherit its environment from the current process. Example:
--
-- > pty <- spawnWithPty (Just [("SHELL", "tcsh")]) True "ls" ["-l"] (20, 10)
--
-- This searches the user's PATH for a binary called @ls@, then runs this
-- binary with the commandline argument @-l@ in a terminal that is 20
-- characters wide and 10 characters high. The environment of @ls@ will
-- contains one variable, SHELL, which will be set to the value \"tcsh\".
spawnWithPty :: Maybe [(String, String)]    -- ^ Optional environment for the
                                            --   new process.
             -> Bool                        -- ^ Search for the executable in
                                            --   PATH?
             -> FilePath                    -- ^ Program's name.
             -> [String]                    -- ^ Command line arguments for the
                                            --   program.
             -> (Int, Int)                  -- ^ Initial dimensions for the
                                            --   pseudo terminal.
             -> IO (Pty, ProcessHandle)
spawnWithPty :: Maybe [(String, String)]
-> Bool
-> String
-> [String]
-> (Int, Int)
-> IO (Pty, ProcessHandle)
spawnWithPty Maybe [(String, String)]
env' (Bool -> CInt
forall a. Num a => Bool -> a
fromBool -> CInt
search) String
path' [String]
argv' (Int
x, Int
y) = do
    IO (CString, [CString], [CString])
-> ((CString, [CString], [CString]) -> IO ())
-> ((CString, [CString], [CString]) -> IO (Pty, ProcessHandle))
-> IO (Pty, ProcessHandle)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (CString, [CString], [CString])
allocStrings (CString, [CString], [CString]) -> IO ()
cleanupStrings (((CString, [CString], [CString]) -> IO (Pty, ProcessHandle))
 -> IO (Pty, ProcessHandle))
-> ((CString, [CString], [CString]) -> IO (Pty, ProcessHandle))
-> IO (Pty, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ \(CString
path, [CString]
argvList, [CString]
envList) -> do
        let allocLists :: IO (Ptr CString, Ptr CString)
allocLists = do
                Ptr CString
argv <- CString -> [CString] -> IO (Ptr CString)
forall a. Storable a => a -> [a] -> IO (Ptr a)
newArray0 CString
forall a. Ptr a
nullPtr (CString
path CString -> [CString] -> [CString]
forall a. a -> [a] -> [a]
: [CString]
argvList)
                Ptr CString
env <- case [CString]
envList of
                        [] -> Ptr CString -> IO (Ptr CString)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr CString
forall a. Ptr a
nullPtr
                        [CString]
_ -> CString -> [CString] -> IO (Ptr CString)
forall a. Storable a => a -> [a] -> IO (Ptr a)
newArray0 CString
forall a. Ptr a
nullPtr [CString]
envList
                (Ptr CString, Ptr CString) -> IO (Ptr CString, Ptr CString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr CString
argv, Ptr CString
env)

            cleanupLists :: (Ptr a, Ptr a) -> IO ()
cleanupLists (Ptr a
argv, Ptr a
env) = Ptr a -> IO ()
forall a. Ptr a -> IO ()
free Ptr a
argv IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr a -> IO ()
forall a. Ptr a -> IO ()
free Ptr a
env

        IO (Ptr CString, Ptr CString)
-> ((Ptr CString, Ptr CString) -> IO ())
-> ((Ptr CString, Ptr CString) -> IO (Pty, ProcessHandle))
-> IO (Pty, ProcessHandle)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Ptr CString, Ptr CString)
allocLists (Ptr CString, Ptr CString) -> IO ()
forall a a. (Ptr a, Ptr a) -> IO ()
cleanupLists (((Ptr CString, Ptr CString) -> IO (Pty, ProcessHandle))
 -> IO (Pty, ProcessHandle))
-> ((Ptr CString, Ptr CString) -> IO (Pty, ProcessHandle))
-> IO (Pty, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ \(Ptr CString
argv, Ptr CString
env) -> do
            (Ptr Int -> IO (Pty, ProcessHandle)) -> IO (Pty, ProcessHandle)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Int -> IO (Pty, ProcessHandle)) -> IO (Pty, ProcessHandle))
-> (Ptr Int -> IO (Pty, ProcessHandle)) -> IO (Pty, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ \Ptr Int
pidPtr -> do
                Fd
fd <- String -> IO Fd -> IO Fd
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1Retry String
"failed to fork or open pty" (IO Fd -> IO Fd) -> IO Fd -> IO Fd
forall a b. (a -> b) -> a -> b
$
                        MVar () -> (() -> IO Fd) -> IO Fd
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
runInteractiveProcess_lock ((() -> IO Fd) -> IO Fd) -> (() -> IO Fd) -> IO Fd
forall a b. (a -> b) -> a -> b
$ \()
_ ->
                          Int
-> Int
-> CInt
-> CString
-> Ptr CString
-> Ptr CString
-> Ptr Int
-> IO Fd
fork_exec_with_pty Int
x Int
y CInt
search CString
path Ptr CString
argv Ptr CString
env Ptr Int
pidPtr

                Int
pid <- Ptr Int -> IO Int
forall a. Storable a => Ptr a -> IO a
peek Ptr Int
pidPtr
                ProcessHandle
handle <- PHANDLE -> Bool -> IO ProcessHandle
mkProcessHandle (Int -> PHANDLE
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
pid) Bool
True

                (Pty, ProcessHandle) -> IO (Pty, ProcessHandle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Fd -> Pty
Pty Fd
fd, ProcessHandle
handle)
  where
    fuse :: (String, String) -> IO CString
    fuse :: (String, String) -> IO CString
fuse (String
key, String
val) = String -> IO CString
newCString (String
key String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
val)

    allocStrings :: IO (CString, [CString], [CString])
    allocStrings :: IO (CString, [CString], [CString])
allocStrings = do
        CString
path <- String -> IO CString
newCString String
path'
        [CString]
argv <- (String -> IO CString) -> [String] -> IO [CString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO CString
newCString [String]
argv'
        [CString]
env <- IO [CString]
-> ([(String, String)] -> IO [CString])
-> Maybe [(String, String)]
-> IO [CString]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([CString] -> IO [CString]
forall (m :: * -> *) a. Monad m => a -> m a
return []) (((String, String) -> IO CString)
-> [(String, String)] -> IO [CString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String, String) -> IO CString
fuse) Maybe [(String, String)]
env'
        (CString, [CString], [CString])
-> IO (CString, [CString], [CString])
forall (m :: * -> *) a. Monad m => a -> m a
return (CString
path, [CString]
argv, [CString]
env)

    cleanupStrings :: (CString, [CString], [CString]) -> IO ()
    cleanupStrings :: (CString, [CString], [CString]) -> IO ()
cleanupStrings (CString
path, [CString]
argv, [CString]
env) = do
        CString -> IO ()
forall a. Ptr a -> IO ()
free CString
path
        (CString -> IO ()) -> [CString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CString -> IO ()
forall a. Ptr a -> IO ()
free [CString]
argv
        (CString -> IO ()) -> [CString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CString -> IO ()
forall a. Ptr a -> IO ()
free [CString]
env

-- Module internal functions

getFd :: Pty -> Fd
getFd :: Pty -> Fd
getFd (Pty Fd
fd) = Fd
fd

byteToControlCode :: Word8 -> [PtyControlCode]
byteToControlCode :: Word8 -> [PtyControlCode]
byteToControlCode Word8
i = ((Word8, PtyControlCode) -> PtyControlCode)
-> [(Word8, PtyControlCode)] -> [PtyControlCode]
forall a b. (a -> b) -> [a] -> [b]
map (Word8, PtyControlCode) -> PtyControlCode
forall a b. (a, b) -> b
snd ([(Word8, PtyControlCode)] -> [PtyControlCode])
-> [(Word8, PtyControlCode)] -> [PtyControlCode]
forall a b. (a -> b) -> a -> b
$ ((Word8, PtyControlCode) -> Bool)
-> [(Word8, PtyControlCode)] -> [(Word8, PtyControlCode)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/=Word8
0) (Word8 -> Bool)
-> ((Word8, PtyControlCode) -> Word8)
-> (Word8, PtyControlCode)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&.Word8
i) (Word8 -> Word8)
-> ((Word8, PtyControlCode) -> Word8)
-> (Word8, PtyControlCode)
-> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8, PtyControlCode) -> Word8
forall a b. (a, b) -> a
fst) [(Word8, PtyControlCode)]
codeMapping
    where codeMapping :: [(Word8, PtyControlCode)]
          codeMapping :: [(Word8, PtyControlCode)]
codeMapping =
            [ (Word8
tiocPktFlushRead,  PtyControlCode
FlushRead)
            , (Word8
tiocPktFlushWrite, PtyControlCode
FlushWrite)
            , (Word8
tiocPktStop,       PtyControlCode
OutputStopped)
            , (Word8
tiocPktStart,      PtyControlCode
OutputStarted)
            , (Word8
tiocPktDoStop,     PtyControlCode
DoStop)
            , (Word8
tiocPktNoStop,     PtyControlCode
NoStop)
            ]

-- Foreign imports

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

-- Pty specialised versions of GHC.Conc.IO
-- | Equivalent to 'threadWaitRead'.
threadWaitReadPty :: Pty -> IO ()
threadWaitReadPty :: Pty -> IO ()
threadWaitReadPty = Fd -> IO ()
threadWaitRead (Fd -> IO ()) -> (Pty -> Fd) -> Pty -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pty -> Fd
getFd

-- | Equivalent to 'threadWaitWrite'.
threadWaitWritePty :: Pty -> IO ()
threadWaitWritePty :: Pty -> IO ()
threadWaitWritePty = Fd -> IO ()
threadWaitWrite (Fd -> IO ()) -> (Pty -> Fd) -> Pty -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pty -> Fd
getFd

-- | Equivalent to 'threadWaitReadSTM'.
threadWaitReadPtySTM :: Pty -> IO (STM (), IO ())
threadWaitReadPtySTM :: Pty -> IO (STM (), IO ())
threadWaitReadPtySTM = Fd -> IO (STM (), IO ())
threadWaitReadSTM (Fd -> IO (STM (), IO ()))
-> (Pty -> Fd) -> Pty -> IO (STM (), IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pty -> Fd
getFd

-- | Equivalent to 'threadWaitWriteSTM'.
threadWaitWritePtySTM :: Pty -> IO (STM (), IO ())
threadWaitWritePtySTM :: Pty -> IO (STM (), IO ())
threadWaitWritePtySTM = Fd -> IO (STM (), IO ())
threadWaitWriteSTM (Fd -> IO (STM (), IO ()))
-> (Pty -> Fd) -> Pty -> IO (STM (), IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pty -> Fd
getFd

-- Pty specialised re-exports of System.Posix.Terminal

{- $posix-reexport
This module re-exports the entirety of "System.Posix.Terminal", with the
exception of the following functions:

[setTerminalProcessGroupID] This function can't be used after a process using
the slave terminal has been created, rendering it mostly useless for working
with 'Pty'@s@ created by this module.

[queryTerminal] Useless, 'Pty' is always a terminal.

[openPseudoTerminal] Only useful for the kind of tasks this module is supposed
abstract away.

In addition, some functions from "System.Posix.Terminal" work directly with
'Fd'@s@, these have been hidden and instead the following replacements working
on 'Pty'@s@ are exported.
-}

-- | See 'System.Posix.Terminal.getTerminalAttributes'.
getTerminalAttributes :: Pty -> IO TerminalAttributes
getTerminalAttributes :: Pty -> IO TerminalAttributes
getTerminalAttributes = Fd -> IO TerminalAttributes
T.getTerminalAttributes (Fd -> IO TerminalAttributes)
-> (Pty -> Fd) -> Pty -> IO TerminalAttributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pty -> Fd
getFd

-- | See 'System.Posix.Terminal.setTerminalAttributes'.
setTerminalAttributes :: Pty -> TerminalAttributes -> TerminalState -> IO ()
setTerminalAttributes :: Pty -> TerminalAttributes -> TerminalState -> IO ()
setTerminalAttributes = Fd -> TerminalAttributes -> TerminalState -> IO ()
T.setTerminalAttributes (Fd -> TerminalAttributes -> TerminalState -> IO ())
-> (Pty -> Fd)
-> Pty
-> TerminalAttributes
-> TerminalState
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pty -> Fd
getFd

-- | See 'System.Posix.Terminal.sendBreak'.
sendBreak :: Pty -> Int -> IO ()
sendBreak :: Pty -> Int -> IO ()
sendBreak = Fd -> Int -> IO ()
T.sendBreak (Fd -> Int -> IO ()) -> (Pty -> Fd) -> Pty -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pty -> Fd
getFd

-- | See 'System.Posix.Terminal.drainOutput'.
drainOutput :: Pty -> IO ()
drainOutput :: Pty -> IO ()
drainOutput = Fd -> IO ()
T.drainOutput (Fd -> IO ()) -> (Pty -> Fd) -> Pty -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pty -> Fd
getFd

-- | See 'System.Posix.Terminal.discardData'.
discardData :: Pty -> QueueSelector -> IO ()
discardData :: Pty -> QueueSelector -> IO ()
discardData = Fd -> QueueSelector -> IO ()
T.discardData (Fd -> QueueSelector -> IO ())
-> (Pty -> Fd) -> Pty -> QueueSelector -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pty -> Fd
getFd

-- | See 'System.Posix.Terminal.controlFlow'.
controlFlow :: Pty -> FlowAction -> IO ()
controlFlow :: Pty -> FlowAction -> IO ()
controlFlow = Fd -> FlowAction -> IO ()
T.controlFlow (Fd -> FlowAction -> IO ())
-> (Pty -> Fd) -> Pty -> FlowAction -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pty -> Fd
getFd

-- | See 'System.Posix.Terminal.getTerminalProcessGroupID'.
getTerminalProcessGroupID :: Pty -> IO ProcessGroupID
getTerminalProcessGroupID :: Pty -> IO PHANDLE
getTerminalProcessGroupID = Fd -> IO PHANDLE
T.getTerminalProcessGroupID (Fd -> IO PHANDLE) -> (Pty -> Fd) -> Pty -> IO PHANDLE
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pty -> Fd
getFd

-- | See 'System.Posix.Terminal.getTerminalName'.
getTerminalName :: Pty -> IO FilePath
getTerminalName :: Pty -> IO String
getTerminalName = Fd -> IO String
T.getTerminalName (Fd -> IO String) -> (Pty -> Fd) -> Pty -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pty -> Fd
getFd

-- | See 'System.Posix.Terminal.getSlaveTerminalName'.
getSlaveTerminalName :: Pty -> IO FilePath
getSlaveTerminalName :: Pty -> IO String
getSlaveTerminalName = Fd -> IO String
T.getSlaveTerminalName (Fd -> IO String) -> (Pty -> Fd) -> Pty -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pty -> Fd
getFd