mirror of
https://github.com/urbit/shrub.git
synced 2024-12-30 07:35:19 +03:00
563 lines
20 KiB
Haskell
563 lines
20 KiB
Haskell
module Vere.Term
|
|
( module Term
|
|
, localClient
|
|
, connectToRemote
|
|
, runTerminalClient
|
|
, termServer
|
|
, term
|
|
) where
|
|
|
|
import Arvo hiding (Term)
|
|
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.Time
|
|
import UrbitPrelude hiding (getCurrentTime)
|
|
import Vere.Pier.Types
|
|
|
|
import Data.List ((!!))
|
|
import RIO.Directory (createDirectoryIfMissing)
|
|
import Vere.Term.API (Client(Client))
|
|
|
|
import qualified Data.ByteString.Internal as BS
|
|
import qualified Data.ByteString.UTF8 as BS
|
|
import qualified System.Console.Terminal.Size as TSize
|
|
import qualified System.Console.Terminfo.Base as T
|
|
import qualified Vere.NounServ as Serv
|
|
import qualified Vere.Term.API as Term
|
|
|
|
|
|
-- Types -----------------------------------------------------------------------
|
|
|
|
-- All stateful data in the printing to stdOutput.
|
|
data LineState = LineState
|
|
{ lsLine :: Text
|
|
, lsCurPos :: Int
|
|
, lsSpinTimer :: Maybe (Async ())
|
|
, lsSpinCause :: Maybe Text
|
|
, lsSpinFirstRender :: Bool
|
|
, lsSpinFrame :: Int
|
|
, lsPrevEndTime :: Wen
|
|
}
|
|
|
|
-- A record used in reading data from stdInput.
|
|
data ReadData = ReadData
|
|
{ rdBuf :: Ptr Word8
|
|
, rdEscape :: Bool
|
|
, rdBracket :: Bool
|
|
, 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 -----------------------------------------------------------------------
|
|
|
|
termText :: Text -> T.TermOutput
|
|
termText = T.termText . unpack
|
|
|
|
initialBlew w h = EvBlip $ BlipEvTerm $ TermEvBlew (UD 1, ()) w h
|
|
|
|
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.
|
|
|
|
spinners :: [Text]
|
|
spinners = ["|", "/", "-", "\\"]
|
|
|
|
leftBracket :: Text
|
|
leftBracket = "«"
|
|
|
|
rightBracket :: Text
|
|
rightBracket = "»"
|
|
|
|
_spin_cool_us = 500000
|
|
_spin_warm_us = 50000
|
|
_spin_rate_us = 250000
|
|
_spin_idle_us = 500000
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
runMaybeTermOutput :: T.Terminal -> (T.Terminal -> Maybe T.TermOutput) -> RIO e ()
|
|
runMaybeTermOutput t getter = case (getter t) of
|
|
Nothing -> pure ()
|
|
Just x -> io $ T.runTermOutput t x
|
|
|
|
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
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
{-
|
|
TODO XX HACK: We don't have any good way of handling client
|
|
disconnect, so we just retry. This will probably waste CPU.
|
|
-}
|
|
termServer :: ∀e. HasLogFunc e
|
|
=> RAcquire e (STM (Maybe Client), Port)
|
|
termServer = fst <$> mkRAcquire start stop
|
|
where
|
|
stop = cancel . snd
|
|
start = do
|
|
serv <- Serv.wsServer @Belt @[Term.Ev]
|
|
|
|
let getClient = do
|
|
Serv.sAccept serv <&> \case
|
|
Nothing -> Nothing
|
|
Just c -> Just $ Client
|
|
{ give = Serv.cSend c
|
|
, take = Serv.cRecv c >>= \case
|
|
Nothing -> empty
|
|
Just ev -> pure ev
|
|
}
|
|
|
|
pure ( (getClient, Port $ fromIntegral $ Serv.sData serv)
|
|
, Serv.sAsync serv
|
|
)
|
|
|
|
connectToRemote :: ∀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 (fromIntegral port)
|
|
|
|
ferry <- async $ forever $ atomically $ asum
|
|
[ Term.take local >>= Serv.cSend cConn
|
|
, Serv.cRecv cConn >>= \case
|
|
Nothing -> empty
|
|
Just ev -> Term.give local ev
|
|
]
|
|
|
|
pure (ferry, cAsync)
|
|
|
|
runTerminalClient :: ∀e. HasLogFunc e => Port -> RIO e ()
|
|
runTerminalClient port = runRAcquire $ do
|
|
(tsize, local) <- localClient
|
|
(tid1, tid2) <- connectToRemote port local
|
|
atomically $ waitSTM tid1 <|> waitSTM tid2
|
|
where
|
|
runRAcquire :: RAcquire e () -> RIO e ()
|
|
runRAcquire act = rwith act $ const $ pure ()
|
|
|
|
{-
|
|
Initializes the generalized input/output parts of the terminal.
|
|
-}
|
|
localClient :: ∀e. HasLogFunc e => RAcquire e (TSize.Window Word, Client)
|
|
localClient = fst <$> mkRAcquire start stop
|
|
where
|
|
start :: HasLogFunc e => RIO e ((TSize.Window Word, Client), Private)
|
|
start = do
|
|
t <- io $ T.setupTermFromEnv
|
|
tsWriteQueue <- newTQueueIO
|
|
spinnerMVar <- newEmptyTMVarIO
|
|
pWriterThread <- asyncBound (writeTerminal t tsWriteQueue spinnerMVar)
|
|
|
|
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 (bell tsWriteQueue))
|
|
|
|
let client = Client { take = readTQueue tsReadQueue
|
|
, give = writeTQueue tsWriteQueue
|
|
}
|
|
|
|
tsize <- io $ TSize.size <&> fromMaybe (TSize.Window 80 24)
|
|
|
|
pure ((tsize, client), Private{..})
|
|
|
|
stop :: HasLogFunc e
|
|
=> ((TSize.Window Word, 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
|
|
-- 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
|
|
]
|
|
|
|
getCap term cap =
|
|
T.getCapability term (T.tiGetOutput1 cap) :: Maybe T.TermOutput
|
|
|
|
vtClearScreen t = getCap t "clear"
|
|
vtClearToBegin t = getCap t "el"
|
|
vtSoundBell t = getCap t "bel"
|
|
vtParmLeft t = getCap t "cub1"
|
|
vtParmRight t = getCap t "cuf1"
|
|
|
|
-- An async which will put into an mvar after a delay. Used to spin the
|
|
-- spinner in writeTerminal.
|
|
spinnerHeartBeat :: Int -> Int -> TMVar () -> RIO e ()
|
|
spinnerHeartBeat first rest mvar = do
|
|
threadDelay first
|
|
loop
|
|
where
|
|
loop = do
|
|
atomically $ putTMVar mvar ()
|
|
threadDelay rest
|
|
loop
|
|
|
|
-- Writes data to the terminal. Both the terminal reading, normal logging,
|
|
-- and effect handling can all emit bytes which go to the terminal.
|
|
writeTerminal :: T.Terminal -> TQueue [Term.Ev] -> TMVar () -> RIO e ()
|
|
writeTerminal t q spinner = do
|
|
currentTime <- io $ now
|
|
loop (LineState "" 0 Nothing Nothing True 0 currentTime)
|
|
where
|
|
writeBlank :: LineState -> RIO e LineState
|
|
writeBlank ls = do
|
|
io $ T.runTermOutput t $ termText "\r\n"
|
|
pure ls
|
|
|
|
writeTrace :: LineState -> Text -> RIO e LineState
|
|
writeTrace ls p = do
|
|
io $ T.runTermOutput t $ termText "\r"
|
|
runMaybeTermOutput t vtClearToBegin
|
|
io $ T.runTermOutput t $ termText p
|
|
termRefreshLine t 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.
|
|
-}
|
|
doSpin :: LineState -> Maybe Text -> RIO e LineState
|
|
doSpin ls@LineState{..} mTxt = do
|
|
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 <- async $ spinnerHeartBeat delay _spin_rate_us 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 termRefreshLine below.
|
|
atomically $ tryTakeTMVar spinner
|
|
|
|
-- If we ever actually ran the spinner display callback, we need
|
|
-- to force a redisplay of the command prompt.
|
|
ls <- if not lsSpinFirstRender
|
|
then termRefreshLine t ls
|
|
else pure ls
|
|
|
|
endTime <- io $ now
|
|
pure $ ls { lsSpinTimer = Nothing, lsPrevEndTime = endTime }
|
|
|
|
execEv :: LineState -> Term.Ev -> RIO e LineState
|
|
execEv ls = \case
|
|
Term.Blits bs -> foldM (writeBlit t) ls bs
|
|
Term.Trace p -> writeTrace ls (unCord p)
|
|
Term.Blank -> writeBlank ls
|
|
Term.Spinr (Just txt) -> doSpin ls (unCord <$> txt)
|
|
Term.Spinr Nothing -> unspin ls
|
|
|
|
spin :: LineState -> RIO e LineState
|
|
spin ls@LineState{..} = do
|
|
let spinner = (spinners !! lsSpinFrame) ++ case lsSpinCause of
|
|
Nothing -> ""
|
|
Just str -> leftBracket ++ str ++ rightBracket
|
|
|
|
io $ T.runTermOutput t $ termText spinner
|
|
termSpinnerMoveLeft t (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 :: T.Terminal -> LineState -> Blit -> RIO e LineState
|
|
writeBlit t ls = \case
|
|
Bel () -> do runMaybeTermOutput t vtSoundBell
|
|
pure ls
|
|
Clr () -> do runMaybeTermOutput t vtClearScreen
|
|
termRefreshLine t ls
|
|
Hop w -> termShowCursor t ls (fromIntegral w)
|
|
Lin c -> do ls2 <- termShowClear t ls
|
|
termShowLine t ls2 (pack c)
|
|
Mor () -> termShowMore t ls
|
|
Sag path noun -> pure ls
|
|
Sav path atom -> pure ls
|
|
Url url -> pure ls
|
|
|
|
-- Moves the cursor to the requested position
|
|
termShowCursor :: T.Terminal -> LineState -> Int -> RIO e LineState
|
|
termShowCursor t ls@LineState{..} {-line pos)-} newPos = do
|
|
if newPos < lsCurPos then do
|
|
replicateM_ (lsCurPos - newPos) (runMaybeTermOutput t vtParmLeft)
|
|
pure ls { lsCurPos = newPos }
|
|
else if newPos > lsCurPos then do
|
|
replicateM_ (newPos - lsCurPos) (runMaybeTermOutput t vtParmRight)
|
|
pure ls { lsCurPos = newPos }
|
|
else
|
|
pure ls
|
|
|
|
-- Moves the cursor left without any mutation of the LineState. Used only
|
|
-- in cursor spinning.
|
|
termSpinnerMoveLeft :: T.Terminal -> Int -> RIO e ()
|
|
termSpinnerMoveLeft t count =
|
|
replicateM_ count (runMaybeTermOutput t vtParmLeft)
|
|
|
|
-- Displays and sets the current line
|
|
termShowLine :: T.Terminal -> LineState -> Text -> RIO e LineState
|
|
termShowLine t ls newStr = do
|
|
io $ T.runTermOutput t $ termText newStr
|
|
pure ls { lsLine = newStr, lsCurPos = (length newStr) }
|
|
|
|
termShowClear :: T.Terminal -> LineState -> RIO e LineState
|
|
termShowClear t ls = do
|
|
io $ T.runTermOutput t $ termText "\r"
|
|
runMaybeTermOutput t vtClearToBegin
|
|
pure ls { lsLine = "", lsCurPos = 0 }
|
|
|
|
-- New Current Line
|
|
termShowMore :: T.Terminal -> LineState -> RIO e LineState
|
|
termShowMore t ls = do
|
|
io $ T.runTermOutput t $ termText "\r\n"
|
|
pure ls { lsLine = "", lsCurPos = 0 }
|
|
|
|
-- Redraw the current LineState, maintaining the current curpos
|
|
termRefreshLine :: T.Terminal -> LineState -> RIO e LineState
|
|
termRefreshLine t ls = do
|
|
let line = (lsLine ls)
|
|
curPos = (lsCurPos ls)
|
|
ls <- termShowClear t ls
|
|
ls <- termShowLine t ls line
|
|
termShowCursor t ls curPos
|
|
|
|
-- 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] -> (RIO e ()) -> RIO e ()
|
|
readTerminal rq wq bell =
|
|
rioAllocaBytes 1 $ \ buf -> loop (ReadData buf False False 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.
|
|
--
|
|
t <- io $ try (fdReadBuf stdInput rdBuf 1)
|
|
case t of
|
|
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 $ Aro U
|
|
'B' -> sendBelt $ Aro D
|
|
'C' -> sendBelt $ Aro R
|
|
'D' -> sendBelt $ Aro L
|
|
_ -> bell
|
|
loop rd { rdEscape = False, rdBracket = False}
|
|
else if isAsciiLower c then do
|
|
sendBelt $ Met $ Cord $ pack [c]
|
|
loop rd { rdEscape = False }
|
|
else if c == '.' then do
|
|
sendBelt $ Met $ Cord "dot"
|
|
loop rd { rdEscape = False }
|
|
else if w == 8 || w == 127 then do
|
|
sendBelt $ Met $ Cord "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 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 $ Txt $ Tour $ [c]
|
|
loop rd { rdUTF8 = mempty, rdUTF8width = 0 }
|
|
else if w >= 32 && w < 127 then do
|
|
sendBelt $ Txt $ Tour $ [c]
|
|
loop rd
|
|
else if w == 0 then do
|
|
bell
|
|
loop rd
|
|
else if w == 8 || w == 127 then do
|
|
sendBelt $ Bac ()
|
|
loop rd
|
|
else if w == 13 then do
|
|
sendBelt $ Ret ()
|
|
loop rd
|
|
else if w == 3 then do
|
|
-- ETX (^C)
|
|
logDebug $ displayShow "Ctrl-c interrupt"
|
|
atomically $ do
|
|
writeTQueue wq [Term.Trace "interrupt\r\n"]
|
|
writeTQueue rq $ Ctl $ Cord "c"
|
|
loop rd
|
|
else if w <= 26 then do
|
|
sendBelt $ Ctl $ Cord $ pack [BS.w2c (w + 97 - 1)]
|
|
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
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
term :: forall e. HasLogFunc e
|
|
=> (TSize.Window Word, Client)
|
|
-> (STM ())
|
|
-> FilePath
|
|
-> KingId
|
|
-> QueueEv
|
|
-> ([Ev], RAcquire e (EffCb e TermEf))
|
|
term (tsize, Client{..}) shutdownSTM pierPath king enqueueEv =
|
|
(initialEvents, runTerm)
|
|
where
|
|
TSize.Window wi hi = tsize
|
|
|
|
initialEvents = [(initialBlew hi wi), initialHail]
|
|
|
|
runTerm :: RAcquire e (EffCb e TermEf)
|
|
runTerm = do
|
|
tim <- mkRAcquire start stop
|
|
pure handleEffect
|
|
|
|
start :: RIO e (Async ())
|
|
start = async readBelt
|
|
|
|
stop :: Async () -> RIO e ()
|
|
stop rb = cancel rb
|
|
|
|
readBelt :: RIO e ()
|
|
readBelt = forever $ do
|
|
b <- atomically take
|
|
let blip = EvBlip $ BlipEvTerm $ TermEvBelt (UD 1, ()) $ b
|
|
atomically $ enqueueEv $ blip
|
|
|
|
handleEffect :: TermEf -> RIO e ()
|
|
handleEffect = \case
|
|
TermEfBlit _ blits -> do
|
|
let (termBlits, fsWrites) = partition isTerminalBlit blits
|
|
atomically $ give [Term.Blits termBlits]
|
|
for_ fsWrites handleFsWrite
|
|
TermEfInit _ _ -> pure ()
|
|
TermEfLogo path _ -> do
|
|
atomically $ shutdownSTM
|
|
TermEfMass _ _ -> pure ()
|
|
|
|
handleFsWrite :: Blit -> RIO e ()
|
|
handleFsWrite (Sag path noun) = performPut path (jamBS noun)
|
|
handleFsWrite (Sav path atom) = performPut path (atom ^. atomBytes)
|
|
handleFsWrite _ = pure ()
|
|
|
|
performPut :: Path -> ByteString -> RIO e ()
|
|
performPut path bs = do
|
|
let putOutFile = pierPath </> ".urb" </> "put" </> (pathToFilePath path)
|
|
createDirectoryIfMissing True (takeDirectory putOutFile)
|
|
writeFile putOutFile bs
|