mirror of
https://github.com/urbit/shrub.git
synced 2024-12-20 09:21:42 +03:00
0a75ca19f3
This comes with the caveat that this specific mouse reporting mode (which should only report clicks of the primary button) doesn't actually seem to be supported by most terminal emulators, even though it precedes the more complex reporting modes. (Enabling a more complex reporting mode instead would also capture scroll events, which interferes with expected behavior while in tmux.)
734 lines
26 KiB
Haskell
734 lines
26 KiB
Haskell
{-|
|
|
Terminal Driver
|
|
-}
|
|
module Urbit.Vere.Term
|
|
( module Term
|
|
, localClient
|
|
, connectToRemote
|
|
, runTerminalClient
|
|
, connClient
|
|
, term
|
|
, term'
|
|
) where
|
|
|
|
import Data.Char
|
|
import Foreign.Marshal.Alloc
|
|
import Foreign.Ptr
|
|
import Foreign.Storable
|
|
import RIO.FilePath
|
|
import System.Posix.IO
|
|
import System.Posix.Terminal
|
|
import Urbit.Arvo
|
|
import Urbit.King.App
|
|
import Urbit.Noun.Time
|
|
import Urbit.Prelude hiding (getCurrentTime)
|
|
import Urbit.Vere.Pier.Types
|
|
|
|
import Data.List ((!!))
|
|
import RIO.Directory (createDirectoryIfMissing)
|
|
import Urbit.King.API (readPortsFile)
|
|
import Urbit.Vere.Stat (RenderedStat)
|
|
import Urbit.TermSize (TermSize(TermSize))
|
|
import Urbit.Vere.Term.API (Client(Client), ClientTake(..))
|
|
|
|
import qualified Data.Set as S
|
|
import qualified Data.ByteString.Internal as BS
|
|
import qualified Data.ByteString.UTF8 as BS
|
|
import qualified System.Console.ANSI as ANSI
|
|
import qualified Urbit.TermSize as T
|
|
import qualified Urbit.Vere.NounServ as Serv
|
|
import qualified Urbit.Vere.Term.API as Term
|
|
import qualified Urbit.Vere.Term.Render as T
|
|
|
|
|
|
-- Types -----------------------------------------------------------------------
|
|
|
|
-- | All stateful data in the printing to stdOutput.
|
|
data LineState = LineState
|
|
{ lsLine :: Text
|
|
, lsCurPos :: CurPos
|
|
, lsSpinTimer :: Maybe (Async ())
|
|
, lsSpinCause :: Maybe Text
|
|
, lsSpinFirstRender :: Bool
|
|
, lsSpinFrame :: Int
|
|
, lsPrevEndTime :: Wen
|
|
}
|
|
|
|
data CurPos = CurPos
|
|
{ row :: Int
|
|
, col :: Int
|
|
}
|
|
|
|
-- | A record used in reading data from stdInput.
|
|
data ReadData = ReadData
|
|
{ rdBuf :: Ptr Word8
|
|
, rdEscape :: Bool
|
|
, rdBracket :: Bool
|
|
, rdMouse :: Bool
|
|
, rdMouseBut :: Word8
|
|
, rdMouseCol :: Word8
|
|
, rdUTF8 :: ByteString
|
|
, rdUTF8width :: Int
|
|
}
|
|
|
|
-- | Private data to the Client that we keep around for stop().
|
|
data Private = Private
|
|
{ pReaderThread :: Async ()
|
|
, pWriterThread :: Async ()
|
|
, pPreviousConfiguration :: TerminalAttributes
|
|
}
|
|
|
|
-- Utils -----------------------------------------------------------------------
|
|
|
|
blewEvent :: Word -> Word -> Ev
|
|
blewEvent w h = EvBlip $ BlipEvTerm $ TermEvBlew (UD 1, ()) w h
|
|
|
|
initialHail :: Ev
|
|
initialHail = EvBlip $ BlipEvTerm $ TermEvHail (UD 1, ()) ()
|
|
|
|
-- Version one of this is punting on the ops_u.dem flag: whether we're running
|
|
-- in daemon mode.
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
rioAllocaBytes :: (MonadIO m, MonadUnliftIO m)
|
|
=> Int -> (Ptr a -> m b) -> m b
|
|
rioAllocaBytes size action =
|
|
withRunInIO $ \run ->
|
|
allocaBytes size $ \x -> run (action x)
|
|
|
|
{-|
|
|
Because of legacy reasons, some file operations are in the terminal
|
|
driver. These should be filtered out and handled locally instead of
|
|
in any abstractly connected terminal.
|
|
-}
|
|
isTerminalBlit :: Blit -> Bool
|
|
isTerminalBlit (Sav _ _) = False
|
|
isTerminalBlit (Sag _ _) = False
|
|
isTerminalBlit _ = True
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
connClient :: Serv.Conn ClientTake [Term.Ev] -> Client
|
|
connClient c = Client
|
|
{ give = Serv.cSend c
|
|
, take = Serv.cRecv c
|
|
}
|
|
|
|
connectToRemote :: forall e. HasLogFunc e
|
|
=> Port
|
|
-> Client
|
|
-> RAcquire e (Async (), Async ())
|
|
connectToRemote port local = mkRAcquire start stop
|
|
where
|
|
stop (x, y) = cancel x >> cancel y
|
|
start = do
|
|
Serv.Client{..} <- Serv.wsClient "/terminal/0" (fromIntegral port)
|
|
|
|
-- TODO XX Handle disconnect more cleanly.
|
|
ferry <- async $ forever $ atomically $ asum
|
|
[ Term.take local >>= \case
|
|
Nothing -> empty
|
|
Just ev -> Serv.cSend cConn ev
|
|
, Serv.cRecv cConn >>= \case
|
|
Nothing -> empty
|
|
Just ev -> Term.give local ev
|
|
]
|
|
|
|
pure (ferry, cAsync)
|
|
|
|
data HackConfigDir = HCD { _hcdPax :: FilePath }
|
|
makeLenses ''HackConfigDir
|
|
instance HasPierPath HackConfigDir where pierPathL = hcdPax
|
|
|
|
runTerminalClient :: forall e. HasLogFunc e => FilePath -> RIO e ()
|
|
runTerminalClient pier = runRAcquire $ do
|
|
mPort <- runRIO (HCD pier) readPortsFile
|
|
port <- maybe (error "Can't connect") pure mPort
|
|
mExit <- io newEmptyTMVarIO
|
|
cli <- localClient (putTMVar mExit ())
|
|
(tid, sid) <- connectToRemote (Port $ fromIntegral port) cli
|
|
atomically $ waitSTM tid <|> waitSTM sid <|> takeTMVar mExit
|
|
|
|
where
|
|
runRAcquire :: RAcquire e () -> RIO e ()
|
|
runRAcquire act = rwith act $ const $ pure ()
|
|
|
|
|
|
-- Spinner ---------------------------------------------------------------------
|
|
|
|
-- Call an STM action after delay of `first` microseconds and then every
|
|
-- `rest` microseconds after that.
|
|
repeatedly :: Int -> Int -> STM () -> IO ()
|
|
repeatedly first rest action = do
|
|
threadDelay first
|
|
forever $ do
|
|
atomically action
|
|
threadDelay rest
|
|
|
|
spinners :: [Text]
|
|
spinners = ["|", "/", "-", "\\"]
|
|
|
|
leftBracket, rightBracket :: Text
|
|
leftBracket = "«"
|
|
rightBracket = "»"
|
|
|
|
_spin_cool_us, _spin_warm_us, _spin_rate_us, _spin_idle_us :: Integral i => i
|
|
_spin_cool_us = 500000
|
|
_spin_warm_us = 50000
|
|
_spin_rate_us = 250000
|
|
_spin_idle_us = 500000
|
|
|
|
|
|
-- Client ----------------------------------------------------------------------
|
|
|
|
{-|
|
|
Initializes the generalized input/output parts of the terminal.
|
|
-}
|
|
localClient :: forall e. HasLogFunc e
|
|
=> STM ()
|
|
-> RAcquire e Client
|
|
localClient doneSignal = fst <$> mkRAcquire start stop
|
|
where
|
|
start :: HasLogFunc e => RIO e (Client, Private)
|
|
start = do
|
|
tsWriteQueue <- newTQueueIO :: RIO e (TQueue [Term.Ev])
|
|
spinnerMVar <- newEmptyTMVarIO :: RIO e (TMVar ())
|
|
|
|
-- Track the terminal size, keeping track of the size of the local
|
|
-- terminal for our own printing, as well as putting size changes into an
|
|
-- event queue so we can send changes to the terminal muxing system.
|
|
tsizeTVar <- newTVarIO (TermSize 80 24) -- Value doesn't matter.
|
|
tsSizeChange <- newEmptyTMVarIO
|
|
io $ T.liveTermSize (\ts -> atomically $ do
|
|
-- We keep track of the console's local size for
|
|
-- our own tank washing.
|
|
writeTVar tsizeTVar ts
|
|
|
|
-- We queue up changes so we can broadcast them
|
|
-- to the muxing client.
|
|
putTMVar tsSizeChange ts)
|
|
|
|
-- start mouse reporting
|
|
putStr "\x1b[?9h"
|
|
|
|
pWriterThread <- asyncBound
|
|
(writeTerminal tsWriteQueue spinnerMVar tsizeTVar)
|
|
|
|
pPreviousConfiguration <- io $ getTerminalAttributes stdInput
|
|
|
|
-- Create a new configuration where we put the terminal in raw mode and
|
|
-- disable a bunch of preprocessing.
|
|
let newTermSettings = flip withTime 0
|
|
$ flip withMinInput 1
|
|
$ foldl' withoutMode pPreviousConfiguration
|
|
$ disabledFlags
|
|
|
|
io $ setTerminalAttributes stdInput newTermSettings Immediately
|
|
|
|
tsReadQueue <- newTQueueIO
|
|
pReaderThread <- asyncBound
|
|
(readTerminal tsReadQueue tsWriteQueue tsizeTVar (bell tsWriteQueue))
|
|
|
|
let client = Client { take = Just <$> asum
|
|
[ readTQueue tsReadQueue <&> ClientTakeBelt,
|
|
takeTMVar tsSizeChange <&> ClientTakeSize
|
|
]
|
|
, give = writeTQueue tsWriteQueue
|
|
}
|
|
|
|
pure (client, Private{..})
|
|
|
|
stop :: HasLogFunc e
|
|
=> (Client, Private) -> RIO e ()
|
|
stop (Client{..}, Private{..}) = do
|
|
-- Note that we don't `cancel pReaderThread` here. This is a deliberate
|
|
-- decision because fdRead calls into a native function which the runtime
|
|
-- can't kill. If we were to cancel here, the internal `waitCatch` would
|
|
-- block until the next piece of keyboard input. Since this only happens
|
|
-- at shutdown, just leak the file descriptor.
|
|
cancel pWriterThread
|
|
|
|
-- stop mouse reporting
|
|
putStr "\x1b[?9l"
|
|
|
|
-- inject one final newline, as we're usually on the prompt.
|
|
putStr "\r\n"
|
|
|
|
-- take the terminal out of raw mode
|
|
io $ setTerminalAttributes stdInput pPreviousConfiguration Immediately
|
|
|
|
{-
|
|
A list of terminal flags that we disable.
|
|
|
|
TODO: Terminal library missing CSIZE?
|
|
-}
|
|
disabledFlags :: [TerminalMode]
|
|
disabledFlags = [ StartStopOutput
|
|
, KeyboardInterrupts
|
|
, EnableEcho
|
|
, EchoLF
|
|
, ProcessInput
|
|
, ExtendedFunctions
|
|
, MapCRtoLF
|
|
, CheckParity
|
|
, StripHighBit
|
|
, EnableParity
|
|
, ProcessOutput
|
|
]
|
|
|
|
|
|
-- Writes data to the terminal. Both the terminal reading, normal logging,
|
|
-- and effect handling can all emit bytes which go to the terminal.
|
|
--TODO blanks, traces and slogs should only be written into the default
|
|
-- terminal session.
|
|
writeTerminal :: TQueue [Term.Ev] -> TMVar () -> TVar TermSize -> RIO e ()
|
|
writeTerminal q spinner termSizeVar = do
|
|
currentTime <- io $ now
|
|
loop (LineState "" (CurPos 0 0) Nothing Nothing True 0 currentTime)
|
|
where
|
|
writeBlank :: LineState -> RIO e LineState
|
|
writeBlank ls = do
|
|
TermSize _ height <- readTVarIO termSizeVar
|
|
--NOTE hijack creates a blank line
|
|
T.hijack $ fromIntegral height
|
|
T.lojack
|
|
pure ls
|
|
|
|
writeTrace :: LineState -> Text -> RIO e LineState
|
|
writeTrace ls p = do
|
|
TermSize _ height <- readTVarIO termSizeVar
|
|
T.hijack $ fromIntegral height
|
|
putStr p
|
|
T.lojack
|
|
pure ls
|
|
|
|
writeSlog :: LineState -> (Atom, Tank) -> RIO e LineState
|
|
writeSlog ls slog = do
|
|
TermSize width height <- readTVarIO termSizeVar
|
|
T.hijack $ fromIntegral height
|
|
-- TODO: Ignoring priority for now. Priority changes the color of,
|
|
-- and adds a prefix of '>' to, the output.
|
|
let lines = fmap unTape $ wash (WashCfg 0 width) $ tankTree $ snd slog
|
|
T.putCSI 'm' [90] --NOTE print slogs in grey
|
|
forM (intersperse "\n" lines) $ \line -> putStr line
|
|
T.putCSI 'm' [0]
|
|
T.lojack
|
|
pure ls
|
|
|
|
{-
|
|
Figure out how long to wait to show the spinner. When we
|
|
don't have a vane name to display, we assume its a user
|
|
action and trigger immediately. Otherwise, if we receive an
|
|
event shortly after a previous spin, use a shorter delay to
|
|
avoid giving the impression of a half-idle system.
|
|
-}
|
|
--TODO this is too eager and does termRestoreLine on every keypress!
|
|
doSpin :: LineState -> Maybe Text -> RIO e LineState
|
|
doSpin ls@LineState{..} mTxt = do
|
|
maybe (pure ()) cancel lsSpinTimer
|
|
|
|
current <- io $ now
|
|
delay <- pure $ case mTxt of
|
|
Nothing -> 0
|
|
Just _ ->
|
|
if (gap current lsPrevEndTime ^. microSecs) < _spin_idle_us
|
|
then _spin_warm_us
|
|
else _spin_cool_us
|
|
|
|
spinTimer <- io $ async
|
|
$ repeatedly delay _spin_rate_us
|
|
$ void
|
|
$ tryPutTMVar spinner ()
|
|
|
|
pure $ ls { lsSpinTimer = Just spinTimer
|
|
, lsSpinCause = mTxt
|
|
, lsSpinFirstRender = True
|
|
}
|
|
|
|
unspin :: LineState -> RIO e LineState
|
|
unspin ls@LineState{..} = do
|
|
maybe (pure ()) cancel lsSpinTimer
|
|
-- We do a final flush of the spinner mvar to ensure we don't
|
|
-- have a lingering signal which will redisplay the spinner after
|
|
-- we call termRestoreLine below.
|
|
atomically $ tryTakeTMVar spinner
|
|
|
|
-- If we ever actually ran the spinner display callback, we need
|
|
-- to force a redisplay of the command prompt.
|
|
if not lsSpinFirstRender || True
|
|
then termRestoreLine ls termSizeVar
|
|
else pure ()
|
|
|
|
endTime <- io $ now
|
|
pure $ ls { lsSpinTimer = Nothing, lsPrevEndTime = endTime }
|
|
|
|
execEv :: LineState -> Term.Ev -> RIO e LineState
|
|
execEv ls = \case
|
|
Term.Blits bs -> foldM (writeBlit termSizeVar) ls bs
|
|
Term.Trace p -> writeTrace ls (unCord p)
|
|
Term.Slog s -> writeSlog ls s
|
|
Term.Blank -> writeBlank ls
|
|
Term.Spinr (Just txt) -> doSpin ls (unCord <$> txt)
|
|
Term.Spinr Nothing -> unspin ls
|
|
|
|
-- TODO What does this do?
|
|
spin :: LineState -> RIO e LineState
|
|
spin ls@LineState{..} = do
|
|
let spinner = (spinners !! lsSpinFrame) ++ case lsSpinCause of
|
|
Nothing -> ""
|
|
Just str -> leftBracket ++ str ++ rightBracket
|
|
|
|
putStr (spinner <> pack (ANSI.cursorBackwardCode (length spinner)))
|
|
|
|
let newFrame = (lsSpinFrame + 1) `mod` length spinners
|
|
|
|
pure $ ls { lsSpinFirstRender = False
|
|
, lsSpinFrame = newFrame
|
|
}
|
|
|
|
loop :: LineState -> RIO e ()
|
|
loop ls = do
|
|
join $ atomically $ asum
|
|
[ readTQueue q >>= pure . (foldM execEv ls >=> loop)
|
|
, takeTMVar spinner >> pure (spin ls >>= loop)
|
|
]
|
|
|
|
-- Writes an individual blit to the screen
|
|
writeBlit :: TVar TermSize -> LineState -> Blit -> RIO e LineState
|
|
writeBlit ts ls = \case
|
|
Bel () -> T.soundBell $> ls
|
|
Clr () -> do T.clearScreen
|
|
T.cursorRestore
|
|
pure ls
|
|
Hop t -> case t of
|
|
Col c -> termShowCursor ls ts 0 (fromIntegral c)
|
|
Roc r c -> termShowCursor ls ts (fromIntegral r) (fromIntegral c)
|
|
Klr s -> termShowStub ls s
|
|
Put c -> termShowLine ls (pack c)
|
|
Nel () -> termShowNewline ls
|
|
Sag path noun -> pure ls
|
|
Sav path atom -> pure ls
|
|
Url url -> pure ls
|
|
Wyp () -> termShowClear ls
|
|
|
|
termRenderDeco :: Deco -> Char
|
|
termRenderDeco = \case
|
|
DecoBr -> '1'
|
|
DecoUn -> '4'
|
|
DecoBl -> '5'
|
|
DecoNull -> '0'
|
|
|
|
termRenderTint :: Tint -> [Char]
|
|
termRenderTint = \case
|
|
TintK -> ['0']
|
|
TintR -> ['1']
|
|
TintG -> ['2']
|
|
TintY -> ['3']
|
|
TintB -> ['4']
|
|
TintM -> ['5']
|
|
TintC -> ['6']
|
|
TintW -> ['7']
|
|
TintNull -> ['9']
|
|
TintTrue r g b ->
|
|
mconcat ["8;2;", show r, ";", show g, ";", show b]
|
|
|
|
-- Wraps the appropriate escape sequence around a piece of styled text
|
|
termRenderStubSegment :: Stye -> [Char] -> [Char]
|
|
termRenderStubSegment Stye {..} tape =
|
|
case (S.null decoset, back, fore) of
|
|
(True, TintNull, TintNull) -> tape
|
|
_ -> styled
|
|
where
|
|
decoset = setFromHoonSet deco
|
|
escape = [chr 27, '[']
|
|
|
|
styles = intercalate ";" $ filter (not . null)
|
|
[ intersperse ';' $ fmap termRenderDeco $ toList decoset
|
|
, case back of
|
|
TintNull -> []
|
|
tint -> '4' : termRenderTint tint
|
|
, case fore of
|
|
TintNull -> []
|
|
tint -> '3' : termRenderTint tint
|
|
]
|
|
|
|
styled = mconcat [escape, styles, "m", tape, escape, "0m"]
|
|
|
|
-- Displays styled text at the cursor
|
|
termShowStub :: LineState -> Stub -> RIO e LineState
|
|
termShowStub ls@LineState{lsCurPos} (Stub s) = do
|
|
let outText = pack $ mconcat $ fmap (uncurry termRenderStubSegment) s
|
|
putStr outText
|
|
T.cursorRestore
|
|
case row lsCurPos of
|
|
0 -> --TODO offset by col
|
|
pure ls { lsLine = outText }
|
|
_ -> pure ls
|
|
|
|
-- Moves the cursor to the requested position
|
|
termShowCursor :: LineState -> TVar TermSize -> Int -> Int -> RIO e LineState
|
|
termShowCursor ls ts row col = do
|
|
TermSize _ h <- readTVarIO ts
|
|
T.cursorMove (max 0 (fromIntegral h - row - 1)) col
|
|
T.cursorSave
|
|
pure ls { lsCurPos = CurPos row col }
|
|
|
|
-- Moves the cursor left without any mutation of the LineState. Used only
|
|
-- in cursor spinning.
|
|
_termSpinnerMoveLeft :: Int -> RIO e ()
|
|
_termSpinnerMoveLeft = liftIO . ANSI.cursorBackward
|
|
|
|
-- Displays and sets the current line
|
|
termShowLine :: LineState -> Text -> RIO e LineState
|
|
termShowLine ls@LineState{lsCurPos} newStr = do
|
|
putStr newStr
|
|
T.cursorRestore
|
|
case row lsCurPos of
|
|
0 -> --TODO offset by col
|
|
pure ls { lsLine = newStr }
|
|
_ -> pure ls
|
|
|
|
termShowClear :: LineState -> RIO e LineState
|
|
termShowClear ls@LineState{lsCurPos} = do
|
|
putStr "\r"
|
|
T.clearLine
|
|
T.cursorRestore
|
|
case row lsCurPos of
|
|
0 -> pure ls { lsLine = "" }
|
|
_ -> pure ls
|
|
|
|
-- New Current Line
|
|
termShowNewline :: LineState -> RIO e LineState
|
|
termShowNewline ls@LineState{lsCurPos} = do
|
|
putStr "\r\n"
|
|
case row lsCurPos of
|
|
0 -> pure ls { lsLine = "", lsCurPos = lsCurPos { col = 0 } }
|
|
r -> pure ls { lsCurPos = CurPos (r-1) 0 }
|
|
|
|
-- Redraw the bottom LineState, maintaining the current curpos
|
|
termRestoreLine :: LineState -> TVar TermSize -> RIO e ()
|
|
termRestoreLine ls@LineState{lsLine} ts = do
|
|
TermSize _ h <- readTVarIO ts
|
|
T.cursorMove (fromIntegral h - 1) 0
|
|
T.clearLine
|
|
putStr lsLine
|
|
T.cursorRestore
|
|
|
|
-- ring my bell
|
|
bell :: TQueue [Term.Ev] -> RIO e ()
|
|
bell q = atomically $ writeTQueue q $ [Term.Blits [Bel ()]]
|
|
|
|
-- Reads data from stdInput and emit the proper effect
|
|
--
|
|
-- This entire path is a divergence from how term.c does things,
|
|
-- probably. First, the vtime is 0, not 1 in term.c. So (IIUC), we'll
|
|
-- always have a latency of 1/10 of a second.
|
|
--
|
|
-- A better way to do this would be to get some sort of epoll on stdInput,
|
|
-- since that's kinda closer to what libuv does?
|
|
readTerminal :: forall e. HasLogFunc e
|
|
=> TQueue Belt
|
|
-> TQueue [Term.Ev]
|
|
-> TVar TermSize
|
|
-> RIO e ()
|
|
-> RIO e ()
|
|
readTerminal rq wq ts bell =
|
|
rioAllocaBytes 1 $ \ buf
|
|
-> loop (ReadData buf False False False 0 0 mempty 0)
|
|
where
|
|
loop :: ReadData -> RIO e ()
|
|
loop rd@ReadData{..} = do
|
|
-- The problem with using fdRead raw is that it will text encode
|
|
-- things like \ESC instead of 27. That makes it broken for our
|
|
-- purposes.
|
|
--
|
|
io (try $ fdReadBuf stdInput rdBuf 1) >>= \case
|
|
Left (e :: IOException) -> do
|
|
-- Ignore EAGAINs when doing reads
|
|
loop rd
|
|
Right 0 -> loop rd
|
|
Right _ -> do
|
|
w <- io $ peek rdBuf
|
|
-- print ("{" ++ (show w) ++ "}")
|
|
let c = BS.w2c w
|
|
if rdEscape then
|
|
if rdBracket then do
|
|
case c of
|
|
'A' -> sendBelt $ Bol $ Aro U
|
|
'B' -> sendBelt $ Bol $ Aro D
|
|
'C' -> sendBelt $ Bol $ Aro R
|
|
'D' -> sendBelt $ Bol $ Aro L
|
|
'M' -> pure ()
|
|
_ -> bell
|
|
rd <- case c of
|
|
'M' -> pure rd { rdMouse = True }
|
|
_ -> pure rd
|
|
loop rd { rdEscape = False, rdBracket = False }
|
|
else if isAsciiLower c then do
|
|
sendBelt $ Mod Met $ Key c
|
|
loop rd { rdEscape = False }
|
|
else if w == 8 || w == 127 then do
|
|
sendBelt $ Mod Met $ Bac ()
|
|
loop rd { rdEscape = False }
|
|
else if c == '[' || c == '0' then do
|
|
loop rd { rdBracket = True }
|
|
else do
|
|
bell
|
|
loop rd { rdEscape = False }
|
|
else if rdMouse then
|
|
if rdMouseBut == 0 then do
|
|
loop rd { rdMouseBut = w - 31 }
|
|
else if rdMouseCol == 0 then do
|
|
loop rd { rdMouseCol = w - 32 }
|
|
else do
|
|
if rdMouseBut == 1 then do
|
|
let rdMouseRow = w - 32
|
|
TermSize _ h <- readTVarIO ts
|
|
sendBelt $ Bol $ Hit
|
|
(fromIntegral h - fromIntegral rdMouseRow)
|
|
(fromIntegral rdMouseCol - 1)
|
|
else do pure ()
|
|
loop rd { rdMouse = False, rdMouseBut = 0, rdMouseCol = 0 }
|
|
else if rdUTF8width /= 0 then do
|
|
-- continue reading into the utf8 accumulation buffer
|
|
rd@ReadData{..} <- pure rd { rdUTF8 = snoc rdUTF8 w }
|
|
if length rdUTF8 /= rdUTF8width then loop rd
|
|
else do
|
|
case BS.decode rdUTF8 of
|
|
Nothing ->
|
|
error "empty utf8 accumulation buffer"
|
|
Just (c, bytes) | bytes /= rdUTF8width ->
|
|
error "utf8 character size mismatch?!"
|
|
Just (c, bytes) -> sendBelt $ Bol $ Key c
|
|
loop rd { rdUTF8 = mempty, rdUTF8width = 0 }
|
|
else if w >= 32 && w < 127 then do
|
|
sendBelt $ Bol $ Key c
|
|
loop rd
|
|
else if w == 0 then do
|
|
bell
|
|
loop rd
|
|
else if w == 8 || w == 127 then do
|
|
sendBelt $ Bol $ Bac ()
|
|
loop rd
|
|
else if w == 13 then do
|
|
sendBelt $ Bol $ Ret ()
|
|
loop rd
|
|
else if w == 3 then do
|
|
-- ETX (^C)
|
|
logInfo $ "Ctrl-c interrupt"
|
|
atomically $ do
|
|
writeTQueue wq [Term.Trace "interrupt"]
|
|
writeTQueue rq $ Mod Ctl $ Key 'c'
|
|
loop rd
|
|
else if w <= 26 then do
|
|
case BS.w2c (w + 97 - 1) of
|
|
'd' -> atomically doneSignal
|
|
c -> do sendBelt $ Mod Ctl $ Key c
|
|
loop rd
|
|
else if w == 27 then do
|
|
loop rd { rdEscape = True }
|
|
else do
|
|
-- start the utf8 accumulation buffer
|
|
loop rd { rdUTF8 = singleton w,
|
|
rdUTF8width = if w < 224 then 2
|
|
else if w < 240 then 3
|
|
else 4 }
|
|
|
|
sendBelt :: HasLogFunc e => Belt -> RIO e ()
|
|
sendBelt b = do
|
|
-- logDebug $ displayShow ("terminalBelt", b)
|
|
atomically $ writeTQueue rq b
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
{-|
|
|
Terminal Driver
|
|
|
|
Until blew/hail events succeeds, ignore effects.
|
|
Wait until blew/hail event callbacks invoked.
|
|
If success, signal success.
|
|
If failure, try again several times.
|
|
If still failure, bring down ship.
|
|
Don't wait for other drivers to boot
|
|
Begin normal operation (start accepting requests)
|
|
-}
|
|
term'
|
|
:: HasPierEnv e
|
|
=> (TermSize, Client)
|
|
-> IO RenderedStat
|
|
-> IO ()
|
|
-> RIO e ([Ev], RAcquire e (DriverApi TermEf))
|
|
term' (tsize, client) stat serfSIGINT = do
|
|
let TermSize wi hi = tsize
|
|
initEv = [blewEvent wi hi, initialHail]
|
|
|
|
pure (initEv, runDriver)
|
|
where
|
|
runDriver = do
|
|
env <- ask
|
|
ventQ :: TQueue EvErr <- newTQueueIO
|
|
diOnEffect <- term env (tsize, client) (writeTQueue ventQ) stat serfSIGINT
|
|
|
|
let diEventSource = fmap RRWork <$> tryReadTQueue ventQ
|
|
|
|
pure (DriverApi {..})
|
|
|
|
{-|
|
|
Terminal Driver
|
|
-}
|
|
term :: forall e. (HasPierEnv e)
|
|
=> e
|
|
-> (TermSize, Client)
|
|
-> (EvErr -> STM ())
|
|
-> IO RenderedStat
|
|
-> IO ()
|
|
-> RAcquire e (TermEf -> IO ())
|
|
term env (tsize, Client{..}) plan stat serfSIGINT = runTerm
|
|
where
|
|
runTerm :: RAcquire e (TermEf -> IO ())
|
|
runTerm = do
|
|
tim <- mkRAcquire (async readLoop) cancel
|
|
pure (runRIO env . handleEffect)
|
|
|
|
{-
|
|
Because our terminals are always `Demux`ed, we don't have to
|
|
care about disconnections.
|
|
-}
|
|
readLoop :: RIO e ()
|
|
readLoop = forever $ do
|
|
atomically take >>= \case
|
|
Nothing -> pure ()
|
|
Just (ClientTakeBelt b) -> do
|
|
when (b == Mod Ctl (Key 'c')) $ do
|
|
io serfSIGINT
|
|
let beltEv = EvBlip $ BlipEvTerm $ TermEvBelt (UD 1, ()) $ b
|
|
let beltFailed _ = pure ()
|
|
atomically $ plan (EvErr beltEv beltFailed)
|
|
Just (ClientTakeSize ts@(TermSize w h)) -> do
|
|
let blewFailed _ = pure ()
|
|
atomically $ plan (EvErr (blewEvent w h) blewFailed)
|
|
|
|
handleEffect :: TermEf -> RIO e ()
|
|
handleEffect = \case
|
|
TermEfInit _ _ -> pure ()
|
|
TermEfMass _ _ -> pure ()
|
|
TermEfLogo _ _ -> atomically =<< view killPierActionL
|
|
TermEfBlit _ blits -> do
|
|
let (termBlits, fsWrites) = partition isTerminalBlit blits
|
|
atomically $ give [Term.Blits termBlits]
|
|
for_ fsWrites handleFsWrite
|
|
|
|
handleFsWrite :: Blit -> RIO e ()
|
|
handleFsWrite (Sag path noun) = performPut path (jamBS noun)
|
|
handleFsWrite (Sav path atom) = performPut path (atomBytes atom)
|
|
handleFsWrite _ = pure ()
|
|
|
|
performPut :: Path -> ByteString -> RIO e ()
|
|
performPut path bs = do
|
|
pierPath <- view pierPathL
|
|
let putOutFile = pierPath </> ".urb" </> "put" </> (pathToFilePath path)
|
|
createDirectoryIfMissing True (takeDirectory putOutFile)
|
|
writeFile putOutFile bs
|