support non-controlling terminals (#156)

* Add `useTermHandles` and `useTermHandlesWith` behaviors for explicitly providing term handles and term type

* add testing for useTermHandles[With]

* update changelog with useTermHandles

* change serial example to websocket/pty

Author: goertzenator

Changelog

@@ -3,6 +3,10 @@ Changed in unreleased:
    * System.Console.Haskeline.Internal now exposes far more internals of
      Haskeline.
 
+   * Added `useTermHandles` and `useTermHandlesWith` Behaviors for driving
+     Haskeline against caller-supplied input/output handles (e.g. a serial
+     console or a PTY pair other than the controlling terminal).  POSIX only.
+
 Changed in version 0.8.4.1:
 
    * Implemented ; and , movements and enabled them for d, c, and y actions.

System/Console/Haskeline.hs

@@ -39,6 +39,10 @@ module System.Console.Haskeline(
                     defaultBehavior,
                     useFileHandle,
                     useFile,
+#ifndef MINGW
+                    useTermHandles,
+                    useTermHandlesWith,
+#endif
                     preferTerm,
                     -- * User interaction functions
                     -- ** Reading user input

System/Console/Haskeline/Backend.hs

@@ -23,27 +23,39 @@ defaultRunTerm = (liftIO (hGetEcho stdin) >>= guard >> stdinTTY)
 terminalRunTerm :: IO RunTerm
 terminalRunTerm = directTTY `orElse` fileHandleRunTerm stdin
 
+#ifndef MINGW
+useTermHandlesRunTerm :: Maybe String -> Handle -> Handle -> IO RunTerm
+useTermHandlesRunTerm termtype input output =
+    explicitTTY termtype input output `orElse` fileHandleRunTerm input
+#endif
+
 stdinTTY :: MaybeT IO RunTerm
 #ifdef MINGW
 stdinTTY = win32TermStdin
 #else
-stdinTTY = stdinTTYHandles >>= runDraw
+stdinTTY = stdinTTYHandles >>= runDraw Nothing
 #endif
 
 directTTY :: MaybeT IO RunTerm
 #ifdef MINGW
 directTTY = win32Term
 #else
-directTTY = ttyHandles >>= runDraw
+directTTY = ttyHandles >>= runDraw Nothing
+#endif
+
+#ifndef MINGW
+explicitTTY :: Maybe String -> Handle -> Handle -> MaybeT IO RunTerm
+explicitTTY termtype input output =
+    explicitTTYHandles input output >>= runDraw termtype
 #endif
 
 
 #ifndef MINGW
-runDraw :: Handles -> MaybeT IO RunTerm
+runDraw :: Maybe String -> Handles -> MaybeT IO RunTerm
 #ifndef TERMINFO
-runDraw = runDumbTerm
+runDraw _termtype = runDumbTerm
 #else
-runDraw h = runTerminfoDraw h `mplus` runDumbTerm h
+runDraw termtype h = runTerminfoDraw termtype h `mplus` runDumbTerm h
 #endif
 #endif
 

System/Console/Haskeline/Backend/Posix.hsc

@@ -11,6 +11,7 @@ module System.Console.Haskeline.Backend.Posix (
                         mapLines,
                         stdinTTYHandles,
                         ttyHandles,
+                        explicitTTYHandles,
                         posixRunTerm,
                         fileRunTerm
                  ) where
@@ -286,6 +287,15 @@ openTerm :: IOMode -> MaybeT IO ExternalHandle
 openTerm mode = handle (\(_::IOException) -> mzero)
             $ liftIO $ openInCodingMode "/dev/tty" mode
 
+explicitTTYHandles :: Handle -> Handle -> MaybeT IO Handles
+explicitTTYHandles h_in h_out = do
+    isInTerm <- liftIO $ hIsTerminalDevice h_in
+    guard isInTerm
+    return Handles
+            { hIn = externalHandle h_in
+            , hOut = externalHandle h_out
+            , closeHandles = return ()
+            }
 
 posixRunTerm ::
     Handles

System/Console/Haskeline/Backend/Terminfo.hs

@@ -125,9 +125,9 @@ evalDraw term actions = EvalTerm eval liftE
                             . unDraw 
 
 
-runTerminfoDraw :: Handles -> MaybeT IO RunTerm
-runTerminfoDraw h = do
-    mterm <- liftIO $ Exception.try setupTermFromEnv
+runTerminfoDraw :: Maybe String -> Handles -> MaybeT IO RunTerm
+runTerminfoDraw termtype h = do
+    mterm <- liftIO $ Exception.try $ maybe setupTermFromEnv setupTerm termtype
     case mterm of
         Left (_::SetupTermError) -> mzero
         Right term -> do

System/Console/Haskeline/InputT.hs

@@ -216,6 +216,70 @@ useFile file = Behavior $ do
 preferTerm :: Behavior
 preferTerm = Behavior terminalRunTerm
 
+#ifndef MINGW
+-- | Use terminal-style interaction on the given input and output handles,
+-- taking the terminal type from the @TERM@ environment variable.
+--
+-- This behavior is for driving Haskeline against a terminal that is not the
+-- process's controlling terminal — for example, a serial console, a PTY pair
+-- you opened yourself, or a socket-backed TTY.  The caller is responsible for
+-- closing @input@ and @output@ after use.  Not available on Windows.
+--
+-- See 'useTermHandlesWith' to override the terminal type.
+useTermHandles :: Handle -> Handle -> Behavior
+useTermHandles input output =
+    Behavior $ useTermHandlesRunTerm Nothing input output
+
+-- | Like 'useTermHandles', but with the terminal type given explicitly
+-- (e.g. @\"xterm-256color\"@ or @\"vt100\"@) instead of read from the @TERM@
+-- environment variable.
+--
+-- The terminal type is only consulted when haskeline is built with terminfo
+-- support; in non-terminfo builds it is ignored and a dumb terminal is used.
+--
+-- ==== __Example: a Haskeline session over a WebSocket__
+--
+-- Bridge a WebSocket to the master end of a PTY pair and run Haskeline
+-- against the slave end.  Uses the @websockets@ and @unix@ packages.
+-- Pair this with a browser-side terminal emulator such as
+-- <https://xtermjs.org/ Xterm.js> for an in-browser shell.
+--
+-- > import qualified Network.WebSockets as WS
+-- > import System.Posix.Terminal (openPseudoTerminal)
+-- > import System.Posix.IO (dup, fdToHandle)
+-- > import Control.Applicative ((<|>))
+-- > import Control.Concurrent.Async (Concurrently(..), runConcurrently)
+-- > import Control.Monad (forever)
+-- > import qualified Data.ByteString as BS
+-- > import System.IO (hSetBuffering, BufferMode(..))
+-- > import System.Console.Haskeline
+-- >
+-- > websocketUI :: WS.Connection -> IO ()
+-- > websocketUI conn = do
+-- >     (master, slave) <- openPseudoTerminal
+-- >     slaveDup <- dup slave
+-- >     masterH  <- fdToHandle master
+-- >     slaveIn  <- fdToHandle slave
+-- >     slaveOut <- fdToHandle slaveDup
+-- >     hSetBuffering masterH NoBuffering
+-- >     -- Whichever of the three actions finishes first cancels the others.
+-- >     runConcurrently
+-- >         $   Concurrently (forever $ WS.receiveData conn >>= BS.hPut masterH)
+-- >         <|> Concurrently (forever $ BS.hGetSome masterH 4096 >>= WS.sendBinaryData conn)
+-- >         <|> Concurrently (runInputTBehavior
+-- >                              (useTermHandlesWith "vt100" slaveIn slaveOut)
+-- >                              defaultSettings loop)
+-- >   where
+-- >     loop = do
+-- >         minput <- getInputLine "% "
+-- >         case minput of
+-- >             Nothing     -> return ()
+-- >             Just "quit" -> return ()
+-- >             Just s      -> outputStrLn ("got: " ++ s) >> loop
+useTermHandlesWith :: String -> Handle -> Handle -> Behavior
+useTermHandlesWith termtype input output =
+    Behavior $ useTermHandlesRunTerm (Just termtype) input output
+#endif
 
 -- | Read 'Prefs' from @$XDG_CONFIG_HOME/haskeline/haskeline@ if present
 -- ortherwise @~/.haskeline.@ If there is an error reading the file,

examples/Test.hs

@@ -1,41 +1,138 @@
+{-# LANGUAGE CPP #-}
 module Main where
 
 import System.Console.Haskeline
-import System.Environment
+import Options.Applicative
+import Data.Monoid ((<>))
+#ifndef MINGW
+import System.IO (openFile, hClose, IOMode(..))
+#endif
 
 {--
 Testing the line-input functions and their interaction with ctrl-c signals.
 
 Usage:
-./Test          (line input)
-./Test chars    (character input)
-./Test password (no masking characters)
-./Test password \*
-./Test initial  (use initial text in the prompt)
+  ./Test                                  (line input, default Behavior)
+  ./Test chars                            (character input)
+  ./Test password                         (no masking)
+  ./Test password \*                      (masking with '*')
+  ./Test initial                          (initial text in the prompt)
+
+  ./Test --mode useTermHandles            (POSIX only)
+  ./Test --mode useTermHandlesWith --term-type vt100
+                                          (POSIX only)
+
+The --mode flag selects the haskeline Behavior; positional INPUT_ARG
+selects which prompt function to use, and works with any --mode.
 --}
 
+data Mode
+    = UseTerm                    -- ^ defaultBehavior
+    | UseTermHandles             -- ^ useTermHandles on /dev/tty
+    | UseTermHandlesWith String  -- ^ useTermHandlesWith TERM on /dev/tty
+
+data InputMode
+    = LineInput
+    | CharInput
+    | PasswordInput (Maybe Char)
+    | InitialInput
+
+data Opts = Opts { optMode :: Mode, optInput :: InputMode }
+
 mySettings :: Settings IO
 mySettings = defaultSettings {historyFile = Just "myhist"}
 
 main :: IO ()
 main = do
-        args <- getArgs
-        let inputFunc = case args of
-                ["chars"] -> fmap (fmap (\c -> [c])) . getInputChar
-                ["password"] -> getPassword Nothing
-                ["password", [c]] -> getPassword (Just c)
-                ["initial"] -> flip getInputLineWithInitial ("left ", "right")
-                _ -> getInputLine
-        runInputT mySettings $ withInterrupt $ loop inputFunc 0
-    where
-        loop :: (String -> InputT IO (Maybe String)) -> Int -> InputT IO ()
-        loop inputFunc n = do
-            minput <-  handleInterrupt (return (Just "Caught interrupted"))
-                        $ inputFunc (show n ++ ":")
-            case minput of
-                Nothing -> return ()
-                Just "quit" -> return ()
-                Just "q" -> return ()
-                Just s -> do
-                            outputStrLn ("line " ++ show n ++ ":" ++ s)
-                            loop inputFunc (n+1)
+    Opts {optMode = m, optInput = im} <- execParser optsInfo
+    case m of
+        UseTerm ->
+            runInputT mySettings (runAction im)
+#ifndef MINGW
+        UseTermHandles ->
+            runWithHandles Nothing im
+        UseTermHandlesWith t ->
+            runWithHandles (Just t) im
+#else
+        _ -> error "useTermHandles[With] is not available on Windows"
+#endif
+
+runAction :: InputMode -> InputT IO ()
+runAction im = withInterrupt $ loop (inputFunc im) 0
+
+inputFunc :: InputMode -> String -> InputT IO (Maybe String)
+inputFunc LineInput          = getInputLine
+inputFunc CharInput          = fmap (fmap (\c -> [c])) . getInputChar
+inputFunc (PasswordInput mc) = getPassword mc
+inputFunc InitialInput       = flip getInputLineWithInitial ("left ", "right")
+
+loop :: (String -> InputT IO (Maybe String)) -> Int -> InputT IO ()
+loop f n = do
+    minput <- handleInterrupt (return (Just "Caught interrupted"))
+                $ f (show n ++ ":")
+    case minput of
+        Nothing     -> return ()
+        Just "quit" -> return ()
+        Just "q"    -> return ()
+        Just s      -> do
+            outputStrLn ("line " ++ show n ++ ":" ++ s)
+            loop f (n+1)
+
+#ifndef MINGW
+-- Drive Haskeline against /dev/tty (the controlling terminal) via the
+-- useTermHandles[With] Behaviors.  This still happens to be the controlling
+-- tty in our test setup, but it goes through the new code path.
+runWithHandles :: Maybe String -> InputMode -> IO ()
+runWithHandles mTerm im = do
+    input  <- openFile "/dev/tty" ReadMode
+    output <- openFile "/dev/tty" WriteMode
+    let beh = case mTerm of
+            Nothing -> useTermHandles input output
+            Just t  -> useTermHandlesWith t input output
+    runInputTBehavior beh mySettings (runAction im)
+    hClose input
+    hClose output
+#endif
+
+----------------------------------------------------------------
+-- Command-line parsing
+
+optsInfo :: ParserInfo Opts
+optsInfo = info (optsP <**> helper)
+                (fullDesc <> progDesc "Haskeline test program")
+
+optsP :: Parser Opts
+optsP = Opts <$> modeP <*> inputModeP
+
+modeP :: Parser Mode
+modeP = mkMode
+    <$> strOption
+            ( long "mode"
+           <> value "useTerm"
+           <> showDefault
+           <> metavar "MODE"
+           <> help "useTerm | useTermHandles | useTermHandlesWith" )
+    <*> optional
+            (strOption
+                ( long "term-type"
+               <> metavar "TERM"
+               <> help "term type for --mode useTermHandlesWith" ))
+  where
+    mkMode "useTerm"            _         = UseTerm
+    mkMode "useTermHandles"     _         = UseTermHandles
+    mkMode "useTermHandlesWith" (Just t)  = UseTermHandlesWith t
+    mkMode "useTermHandlesWith" Nothing   =
+        error "--mode useTermHandlesWith requires --term-type"
+    mkMode other                _         =
+        error ("unknown --mode: " ++ other)
+
+inputModeP :: Parser InputMode
+inputModeP = mkInput <$> many (argument str (metavar "INPUT_ARG"))
+  where
+    mkInput []                  = LineInput
+    mkInput ["chars"]           = CharInput
+    mkInput ["password"]        = PasswordInput Nothing
+    mkInput ["password", [c]]   = PasswordInput (Just c)
+    mkInput ["initial"]         = InitialInput
+    mkInput xs                  =
+        error ("unrecognized positional args: " ++ show xs)

haskeline.cabal

@@ -169,7 +169,7 @@ Executable haskeline-examples-Test
     if !flag(examples) {
         buildable: False
     }
-    Build-depends: base, containers, haskeline
+    Build-depends: base, containers, haskeline, optparse-applicative
     Default-Language: Haskell2010
     hs-source-dirs: examples
     Main-Is: Test.hs

tests/RunTTY.hs

@@ -23,11 +23,18 @@ import Pty
 
 data Invocation = Invocation {
             prog :: FilePath
-            , progArgs :: [String]
+              -- | Mode-selection flags passed before any positional args
+              -- (e.g. @[\"--mode\", \"useTermHandles\"]@).
+            , progModeArgs :: [String]
+              -- | Positional input-mode args (e.g. @[\"chars\"]@).
+            , progInputArgs :: [String]
             , runInTTY :: Bool
             , environment :: [(String,String)]
             }
 
+progArgs :: Invocation -> [String]
+progArgs Invocation{..} = progModeArgs ++ progInputArgs
+
 setEnv :: String -> String -> Invocation -> Invocation
 setEnv var val Invocation {..} = Invocation{
         environment = (var,val) : Prelude.filter ((/=var).fst) environment
@@ -51,11 +58,11 @@ runInvocation :: Invocation
                         -- simulate real user input and prevent Haskeline
                         -- from coalescing the changes.)
         -> IO [B.ByteString]
-runInvocation Invocation {..} inputs
-    | runInTTY = runCommandInPty prog progArgs (Just environment) inputs
+runInvocation inv@Invocation {..} inputs
+    | runInTTY = runCommandInPty prog (progArgs inv) (Just environment) inputs
     | otherwise = do
     (Just inH, Just outH, Nothing, ph)
-        <- createProcess (proc prog progArgs)
+        <- createProcess (proc prog (progArgs inv))
                             { env = Just environment
                             , std_in = CreatePipe
                             , std_out = CreatePipe