Posix.hsc

{-# LANGUAGE CApiFFI #-}

module System.Console.Haskeline.Backend.Posix (
                        withPosixGetEvent,
                        posixLayouts,
                        tryGetLayouts,
                        PosixT,
                        Handles(),
                        ehIn,
                        ehOut,
                        mapLines,
                        stdinTTYHandles,
                        ttyHandles,
                        explicitTTYHandles,
                        posixRunTerm,
                        fileRunTerm
                 ) where

import Foreign
import Foreign.C.Types
import qualified Data.Map as Map
import System.Posix.Terminal hiding (Interrupt)
import Control.Exception (throwTo)
import Control.Monad
import Control.Monad.Catch (MonadMask, handle, finally)
import Control.Concurrent.STM
import Control.Concurrent hiding (throwTo)
import Data.Maybe (catMaybes)
import System.Posix.Signals.Exts
import System.Posix.Types(Fd(..))
import Data.Foldable (foldl')
import System.IO
import System.Environment

import System.Console.Haskeline.Monads
import System.Console.Haskeline.Key
import System.Console.Haskeline.Term as Term
import System.Console.Haskeline.Prefs

import System.Console.Haskeline.Backend.Posix.Encoder

import GHC.IO.FD (fdFD)
import Data.Typeable (cast)
import System.IO.Error
import GHC.IO.Exception
import GHC.IO.Handle.Types hiding (getState)
import GHC.IO.Handle.Internals
import System.Posix.Internals (FD)

#if defined(USE_TERMIOS_H) || defined(__ANDROID__)
#include <termios.h>
#endif
#include <sys/ioctl.h>

#include <HsBaseConfig.h>

-----------------------------------------------
-- Input/output handles
data Handles = Handles {hIn, hOut :: ExternalHandle
                        , closeHandles :: IO ()}

ehIn, ehOut :: Handles -> Handle
ehIn = eH . hIn
ehOut = eH . hOut

-------------------
-- Window size

#if !defined(HAVE_TERMIOS_H)
posixLayouts :: Handles -> [IO (Maybe Layout)]
posixLayouts _ = error "System.Console.Haskeline.Backend.Posix.posixLayouts"
#else
foreign import capi "sys/ioctl.h ioctl" ioctl :: FD -> CULong -> Ptr a -> IO CInt

posixLayouts :: Handles -> [IO (Maybe Layout)]
posixLayouts h = [ioctlLayout $ ehOut h, envLayout]

ioctlLayout :: Handle -> IO (Maybe Layout)
ioctlLayout h = allocaBytes (#size struct winsize) $ \ws -> do
                fd <- unsafeHandleToFD h
                ret <- ioctl fd (#const TIOCGWINSZ) ws
                rows :: CUShort <- (#peek struct winsize,ws_row) ws
                cols :: CUShort <- (#peek struct winsize,ws_col) ws
                if ret >= 0
                    then return $ Just Layout {height=fromEnum rows,width=fromEnum cols}
                    else return Nothing

#endif

unsafeHandleToFD :: Handle -> IO FD
unsafeHandleToFD h =
  withHandle_ "unsafeHandleToFd" h $ \Handle__{haDevice=dev} -> do
  case cast dev of
    Nothing -> ioError (ioeSetErrorString (mkIOError IllegalOperation
                                           "unsafeHandleToFd" (Just h) Nothing)
                        "handle is not a file descriptor")
    Just fd -> return (fdFD fd)

envLayout :: IO (Maybe Layout)
envLayout = handle (\(_::IOException) -> return Nothing) $ do
    -- note the handle catches both undefined envs and bad reads
    r <- getEnv "ROWS"
    c <- getEnv "COLUMNS"
    return $ Just $ Layout {height=read r,width=read c}

tryGetLayouts :: [IO (Maybe Layout)] -> IO Layout
tryGetLayouts [] = return Layout {height=24,width=80}
tryGetLayouts (f:fs) = do
    ml <- f
    case ml of
        Just l | height l > 2 && width l > 2 -> return l
        _ -> tryGetLayouts fs


--------------------
-- Key sequences

getKeySequences :: (MonadIO m, MonadReader Prefs m)
        => Handle -> [(String,Key)] -> m (TreeMap Char Key)
getKeySequences h tinfos = do
    sttys <- liftIO $ sttyKeys h
    customKeySeqs <- getCustomKeySeqs
    -- note ++ acts as a union; so the below favors sttys over tinfos
    return $ listToTree
        $ ansiKeys ++ tinfos ++ sttys ++ customKeySeqs
  where
    getCustomKeySeqs = do
        kseqs <- asks customKeySequences
        termName <- liftIO $ handle (\(_::IOException) -> return "") (getEnv "TERM")
        let isThisTerm = maybe True (==termName)
        return $ map (\(_,cs,k) ->(cs,k))
            $ filter (\(kseqs',_,_) -> isThisTerm kseqs')
            $ kseqs


ansiKeys :: [(String, Key)]
ansiKeys = [("\ESC[D",  simpleKey LeftKey)
            ,("\ESC[C",  simpleKey RightKey)
            ,("\ESC[A",  simpleKey UpKey)
            ,("\ESC[B",  simpleKey DownKey)
            ,("\b",      simpleKey Backspace)
            -- ctrl-left/right aren't a standard
            -- part of terminfo, but enough people have complained
            -- that I've decided to hard-code them in.
            -- (Note they will be overridden by terminfo or .haskeline.)
            -- These appear to be the most common bindings:
            -- xterm:
            ,("\ESC[1;5D", ctrlKey $ simpleKey LeftKey)
            ,("\ESC[1;5C", ctrlKey $ simpleKey RightKey)
            -- Terminal.app:
            ,("\ESC[5D", ctrlKey $ simpleKey LeftKey)
            ,("\ESC[5C", ctrlKey $ simpleKey RightKey)
            -- rxvt: (Note: these will be superseded by e.g. xterm-color,
            -- which uses them as regular arrow keys.)
            ,("\ESC[OD", ctrlKey $ simpleKey LeftKey)
            ,("\ESC[OC", ctrlKey $ simpleKey RightKey)
            ]


sttyKeys :: Handle -> IO [(String, Key)]
sttyKeys h = do
    fd <- unsafeHandleToFD h
    attrs <- getTerminalAttributes (Fd fd)
    let getStty (k,c) = do {str <- controlChar attrs k; return ([str],c)}
    return $ catMaybes $ map getStty [(Erase,simpleKey Backspace),(Kill,simpleKey KillLine)]

newtype TreeMap a b = TreeMap (Map.Map a (Maybe b, TreeMap a b))
                        deriving Show

emptyTreeMap :: TreeMap a b
emptyTreeMap = TreeMap Map.empty

insertIntoTree :: Ord a => ([a], b) -> TreeMap a b -> TreeMap a b
insertIntoTree ([],_) _ = error "Can't insert empty list into a treemap!"
insertIntoTree ((c:cs),k) (TreeMap m) = TreeMap (Map.alter f c m)
    where
        alterSubtree = insertIntoTree (cs,k)
        f Nothing = Just $ if null cs
                            then (Just k, emptyTreeMap)
                            else (Nothing, alterSubtree emptyTreeMap)
        f (Just (y,t)) = Just $ if null cs
                                    then (Just k, t)
                                    else (y, alterSubtree t)

listToTree :: Ord a => [([a],b)] -> TreeMap a b
listToTree = foldl' (flip insertIntoTree) emptyTreeMap

-- for debugging '
mapLines :: (Show a, Show b) => TreeMap a b -> [String]
mapLines (TreeMap m) = let
    m2 = Map.map (\(k,t) -> show k : mapLines t) m
    in concatMap (\(k,ls) -> show k : map (' ':) ls) $ Map.toList m2

lexKeys :: TreeMap Char Key -> [Char] -> [Key]
lexKeys _ [] = []
lexKeys baseMap cs
    | Just (k,ds) <- lookupChars baseMap cs
            = k : lexKeys baseMap ds
lexKeys baseMap ('\ESC':cs)
-- TODO: what's the right thing ' to do here?
    | k:ks <- lexKeys baseMap cs
            = metaKey k : ks
lexKeys baseMap (c:cs) = simpleChar c : lexKeys baseMap cs

-- | Walk @cs@ through the tree, returning the /longest/ key found along
-- the path together with whatever bytes follow it.
--
-- If a longer match is attempted but doesn't pan out (the next byte
-- isn't in the deeper subtree), we fall back to the most recent shorter
-- key we passed.  This avoids the well-known sharp edge where input
-- like @\\ESC[AC@ — with @\\ESC[A@ registered (up-arrow) and the @A@
-- node having children that don't include @C@ — would previously be
-- reported as no match at all, instead of @up-arrow + 'C'@.
--
-- 'Nothing' is returned only when no key is reached anywhere along the
-- walk.
lookupChars :: TreeMap Char Key -> [Char] -> Maybe (Key, [Char])
lookupChars _    [] = Nothing
lookupChars tree cs = go Nothing tree cs
  where
    -- 'best' holds the longest committed match so far (or Nothing if
    -- we haven't passed a key node yet).  When the next byte doesn't
    -- extend the path we return 'best'.
    go best (TreeMap m) (c:cs') = case Map.lookup c m of
        Nothing          -> best
        Just (mKey, sub) ->
            let best' = maybe best (\k -> Just (k, cs')) mKey
            in case cs' of
                _:_ -> go best' sub cs'
                []  -> best'
    go best _ [] = best  -- unreachable: top-level [] handled above

-- | Greedily peel complete keys off the front of @cs@.  Returns the
-- decoded keys (in forward order) and the leftover bytes that didn't
-- (yet) form a complete tree match.
peelCompleteKeys :: TreeMap Char Key -> [Char] -> ([Key], [Char])
peelCompleteKeys tree = go id
  where
    go acc cs = case lookupChars tree cs of
        Just (k, rest) -> go (acc . (k:)) rest
        Nothing        -> (acc [], cs)

-- | True if @cs@ matches a /strict/ (non-terminal) prefix of some path
-- in the @TreeMap@ — i.e. it could still be extended into a complete
-- key sequence if more bytes arrive.
isStrictTreePrefix :: TreeMap Char b -> [Char] -> Bool
isStrictTreePrefix _ [] = False
isStrictTreePrefix (TreeMap m) (c:cs) = case Map.lookup c m of
    Nothing                    -> False
    Just (_, sub@(TreeMap sm)) -> case cs of
        [] -> not (Map.null sm)
        _  -> isStrictTreePrefix sub cs

-----------------------------

withPosixGetEvent :: (MonadIO m, MonadMask m, MonadReader Prefs m)
        => TChan Event -> Handles -> [(String,Key)]
                -> (m Event -> m a) -> m a
withPosixGetEvent eventChan h termKeys f = wrapTerminalOps h $ do
    baseMap <- getKeySequences (ehIn h) termKeys
    timeoutMs <- asks (fromIntegral . keyseqTimeoutMs :: Prefs -> Int)
    withWindowHandler eventChan
        $ f $ liftIO $ getEvent (ehIn h) timeoutMs baseMap eventChan

withWindowHandler :: (MonadIO m, MonadMask m) => TChan Event -> m a -> m a
withWindowHandler eventChan = withHandler windowChange $
    Catch $ atomically $ writeTChan eventChan WindowResize

withSigIntHandler :: (MonadIO m, MonadMask m) => m a -> m a
withSigIntHandler f = do
    tid <- liftIO myThreadId
    withHandler keyboardSignal
            (Catch (throwTo tid Interrupt))
            f

withHandler :: (MonadIO m, MonadMask m) => Signal -> Handler -> m a -> m a
withHandler signal handler f = do
    old_handler <- liftIO $ installHandler signal handler Nothing
    f `finally` liftIO (installHandler signal old_handler Nothing)

getEvent :: Handle -> Int -> TreeMap Char Key -> TChan Event -> IO Event
getEvent h timeoutMs baseMap = keyEventLoop $ do
        ks <- getBlockOfKeys h baseMap timeoutMs
        return [KeyInput ks]

-- | Read at least one key of input, and more if available.
--
-- A multi-byte control sequence (e.g. @\\ESC[A@ for arrow-up) may not
-- arrive in a single read on a slow link such as a low-bandwidth serial
-- port: the @\\ESC@ can land before the @[A@.  When the buffer ends in
-- bytes that are a strict prefix of some known key sequence, we wait up
-- to @timeoutMs@ for the rest before returning.  Otherwise we return as
-- soon as nothing more is buffered.  This mirrors GNU Readline's
-- @keyseq-timeout@.
--
-- The loop tracks bytes and decoded keys side by side: every time we
-- run out of immediately-available input we peel complete keys from the
-- front of the byte buffer and shrink it down to just its trailing
-- (possibly partial) prefix.  That keeps the per-decision work bounded
-- by the size of the in-flight sequence rather than the whole accrued
-- buffer, which matters when bytes trickle in slowly.
--
-- Win32 is unaffected: that backend reads structured @INPUT_RECORD@
-- key events rather than raw bytes, so escape sequences are never
-- fragmented in the first place.
getBlockOfKeys :: Handle -> TreeMap Char Key -> Int -> IO [Key]
getBlockOfKeys h baseMap timeoutMs = do
    c <- hGetChar h
    loop [c] []
  where
    -- Both lists hold values in reverse (newest first) so that consing a
    -- new element is O(1).  We reverse only at decision points or on
    -- return.
    loop bytesRev keysRev = do
        ready <- hWaitForInput h 0
        if ready
            then do
                c <- hGetChar h
                loop (c:bytesRev) keysRev
            else
                -- Drain whatever complete keys are sitting at the head of
                -- the byte buffer; what's left is either empty (done) or a
                -- still-in-flight partial sequence.
                let (peeled, partial) = peelCompleteKeys baseMap (reverse bytesRev)
                    keysRev'          = reverse peeled ++ keysRev
                in if null partial
                    then pure (reverse keysRev')
                    else if isStrictTreePrefix baseMap partial
                        then do
                            arrived <- hWaitForInput h timeoutMs
                            if arrived
                                then do
                                    c <- hGetChar h
                                    loop (c : reverse partial) keysRev'
                                else pure (reverse keysRev' ++ lexKeys baseMap partial)
                        else pure (reverse keysRev' ++ lexKeys baseMap partial)

stdinTTYHandles, ttyHandles :: MaybeT IO Handles
stdinTTYHandles = do
    isInTerm <- liftIO $ hIsTerminalDevice stdin
    guard isInTerm
    h <- openTerm WriteMode
    -- Don't close stdin, since a different part of the program may use it later.
    return Handles
            { hIn = externalHandle stdin
            , hOut = h
            , closeHandles = hClose $ eH h
            }

ttyHandles = do
    -- Open the input and output as two separate Handles, since they need
    -- different buffering.
    h_in <- openTerm ReadMode
    h_out <- openTerm WriteMode
    return Handles
            { hIn = h_in
            , hOut = h_out
            , closeHandles = hClose (eH h_in) >> hClose (eH h_out)
            }

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
    -> [IO (Maybe Layout)]
    -> [(String,Key)]
    -> (forall m b . (MonadIO m, MonadMask m) => m b -> m b)
    -> (forall m . (MonadMask m, CommandMonad m) => EvalTerm (PosixT m))
    -> IO RunTerm
posixRunTerm hs layoutGetters keys wrapGetEvent evalBackend = do
    ch <- newTChanIO
    fileRT <- posixFileRunTerm hs
    return fileRT
                { termOps = Left TermOps
                            { getLayout = tryGetLayouts layoutGetters
                            , withGetEvent = wrapGetEvent
                                            . withPosixGetEvent ch hs
                                                keys
                            , saveUnusedKeys = saveKeys ch
                            , evalTerm = mapEvalTerm
                                            (runPosixT hs) lift evalBackend
                            , externalPrint = atomically . writeTChan ch . ExternalPrint
                            }
                , closeTerm = do
                    flushEventQueue (putStrOut fileRT) ch
                    closeTerm fileRT
                }

type PosixT m = ReaderT Handles m

runPosixT :: Handles -> PosixT m a -> m a
runPosixT h = runReaderT' h

fileRunTerm :: Handle -> IO RunTerm
fileRunTerm h_in = posixFileRunTerm Handles
                        { hIn = externalHandle h_in
                        , hOut = externalHandle stdout
                        , closeHandles = return ()
                        }

posixFileRunTerm :: Handles -> IO RunTerm
posixFileRunTerm hs = do
    return RunTerm
                { putStrOut = \str -> withCodingMode (hOut hs) $ do
                                        hPutStr (ehOut hs) str
                                        hFlush (ehOut hs)
                , closeTerm = closeHandles hs
                , wrapInterrupt = withSigIntHandler
                , termOps = let h_in = ehIn hs
                            in Right FileOps
                          { withoutInputEcho = bracketSet (hGetEcho h_in)
                                                          (hSetEcho h_in)
                                                          False
                          , wrapFileInput = withCodingMode (hIn hs)
                          , getLocaleChar = guardedEOF hGetChar h_in
                          , maybeReadNewline = hMaybeReadNewline h_in
                          , getLocaleLine = guardedEOF hGetLine h_in
                          }
                }

-- NOTE: If we set stdout to NoBuffering, there can be a flicker effect when many
-- characters are printed at once.  We'll keep it buffered here, and let the Draw
-- monad manually flush outputs that don't print a newline.
wrapTerminalOps :: (MonadIO m, MonadMask m) => Handles -> m a -> m a
wrapTerminalOps hs =
    bracketSet (hGetBuffering h_in) (hSetBuffering h_in) NoBuffering
    -- TODO: block buffering?  Certain \r and \n's are causing flicker...
    -- - moving to the right
    -- - breaking line after offset widechar?
    . bracketSet (hGetBuffering h_out) (hSetBuffering h_out) LineBuffering
    . bracketSet (hGetEcho h_in) (hSetEcho h_in) False
    . withCodingMode (hIn hs)
    . withCodingMode (hOut hs)
  where
    h_in = ehIn hs
    h_out = ehOut hs