module System.Posix.Pty (
spawnWithPty
, Pty
, PtyControlCode (..)
, createPty
, tryReadPty
, readPty
, writePty
, resizePty
, ptyDimensions
, getTerminalAttributes
, setTerminalAttributes
, sendBreak
, drainOutput
, discardData
, controlFlow
, getTerminalProcessGroupID
, getTerminalName
, getSlaveTerminalName
, module System.Posix.Terminal
) where
import Control.Applicative
import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Foreign
import Foreign.C.String (CString, newCString, peekCString)
import Foreign.C.Types
import System.IO (Handle)
import System.IO.Error (mkIOError, eofErrorType)
import System.Posix.IO.ByteString (fdToHandle)
import System.Posix.Types
import qualified System.Posix.Terminal as T
import System.Posix.Terminal hiding
( getTerminalAttributes
, setTerminalAttributes
, sendBreak
, drainOutput
, discardData
, controlFlow
, getTerminalProcessGroupID
, setTerminalProcessGroupID
, queryTerminal
, getTerminalName
, openPseudoTerminal
, getSlaveTerminalName)
data Pty = Pty !Fd !Handle
data PtyControlCode = FlushRead
| FlushWrite
| OutputStopped
| OutputStarted
| DoStop
| NoStop
deriving (Eq, Read, Show)
createPty :: Fd -> IO (Maybe Pty)
createPty fd = do
isTerm <- T.queryTerminal fd
if isTerm
then Just . Pty fd <$> fdToHandle fd
else return Nothing
tryReadPty :: Pty -> IO (Either [PtyControlCode] ByteString)
tryReadPty (Pty _ hnd) = do
result <- BS.hGetSome hnd 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 = mkIOError eofErrorType "pty terminated" Nothing Nothing
can'tHappen = userError "Uh-oh! Something different went horribly wrong!"
readPty :: Pty -> IO ByteString
readPty pty = tryReadPty pty >>= \case
Left _ -> readPty pty
Right bs -> return bs
writePty :: Pty -> ByteString -> IO ()
writePty (Pty _ hnd) = BS.hPut hnd
resizePty :: Pty -> (Int, Int) -> IO ()
resizePty (Pty fd _) (x, y) =
set_pty_size fd x y >>= throwCErrorOnMinus1 "unable to set pty dimensions"
ptyDimensions :: Pty -> IO (Int, Int)
ptyDimensions (Pty fd _) = alloca $ \x -> alloca $ \y -> do
get_pty_size fd x y >>= throwCErrorOnMinus1 "unable to get pty size"
(,) <$> peek x <*> peek y
spawnWithPty :: Maybe [(String, String)]
-> Bool
-> FilePath
-> [String]
-> (Int, Int)
-> IO Pty
spawnWithPty env' search path' argv' (x, y) = do
path <- newCString path'
argv <- mapM newCString argv'
env <- maybe (return []) (mapM fuse) env'
result <- forkExecWithPty x y path (fromBool search) argv env
mapM_ free (env ++ argv)
free path
throwCErrorOnMinus1 "unable to fork or open new pty" result
hnd <- fdToHandle result
return (Pty result hnd)
where
fuse (key, val) = newCString (key ++ "=" ++ val)
getFd :: Pty -> Fd
getFd (Pty fd _) = fd
throwCErrorOnMinus1 :: (Eq a, Num a) => String -> a -> IO ()
throwCErrorOnMinus1 s i = when (i == 1) $ do
errnoMsg <- errno >>= peekCString . strerror
ioError . userError $ s ++ ": " ++ errnoMsg
forkExecWithPty :: Int
-> Int
-> CString
-> CInt
-> [CString]
-> [CString]
-> IO Fd
forkExecWithPty x y path search argv' env' = do
argv <- newArray0 nullPtr (path:argv')
env <- case env' of
[] -> return nullPtr
_ -> newArray0 nullPtr env'
result <- fork_exec_with_pty x y search path argv env
free argv >> free env
return result
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/termios.h value TIOCPKT_FLUSHREAD"
tiocPktFlushRead :: Word8
foreign import capi unsafe "sys/termios.h value TIOCPKT_FLUSHWRITE"
tiocPktFlushWrite :: Word8
foreign import capi unsafe "sys/termios.h value TIOCPKT_STOP"
tiocPktStop :: Word8
foreign import capi unsafe "sys/termios.h value TIOCPKT_START"
tiocPktStart :: Word8
foreign import capi unsafe "sys/termios.h value TIOCPKT_DOSTOP"
tiocPktDoStop :: Word8
foreign import capi unsafe "sys/termios.h value TIOCPKT_NOSTOP"
tiocPktNoStop :: Word8
foreign import ccall unsafe "errno.h"
errno :: IO CInt
foreign import ccall unsafe "string.h"
strerror :: CInt -> CString
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
-> IO Fd
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