Impement basic support for multiple terminals pretending to be one terminal.

This commit is contained in:
Benjamin Summers 2019-09-17 23:17:54 -07:00
parent ebf3d3e5c6
commit cd07b10946
3 changed files with 105 additions and 47 deletions

View File

@ -18,15 +18,16 @@ import Vere.Http.Client (client)
import Vere.Http.Server (serv)
import Vere.Log (EventLog)
import Vere.Serf (Serf, SerfState(..), doJob, sStderr)
import Vere.Term
import RIO.Directory
import qualified System.Entropy as Ent
import qualified Urbit.Time as Time
import qualified Vere.Log as Log
import qualified Vere.Serf as Serf
import qualified Vere.Term.API as Term
import qualified System.Entropy as Ent
import qualified Urbit.Time as Time
import qualified Vere.Log as Log
import qualified Vere.Serf as Serf
import qualified Vere.Term as Term
import qualified Vere.Term.API as Term
import qualified Vere.Term.Demux as Term
--------------------------------------------------------------------------------
@ -149,14 +150,22 @@ pier pierPath mPort (serf, log, ss) = do
inst <- io (KingId . UV . fromIntegral <$> randomIO @Word16)
terminalSystem <- initializeLocalTerminal
swapMVar (sStderr serf) (atomically . Term.trace terminalSystem)
local <- Term.localClient
muxed <- atomically $ do
res <- Term.mkDemux
Term.addDemux local res
pure (Term.useDemux res)
swapMVar (sStderr serf) (atomically . Term.trace muxed)
let ship = who (Log.identity log)
let (bootEvents, startDrivers) =
drivers pierPath inst ship mPort (writeTQueue computeQ)
shutdownEvent terminalSystem
drivers pierPath inst ship mPort
(writeTQueue computeQ)
shutdownEvent
muxed
io $ atomically $ for_ bootEvents (writeTQueue computeQ)
@ -166,8 +175,8 @@ pier pierPath mPort (serf, log, ss) = do
(readTQueue computeQ)
(takeTMVar saveM)
(takeTMVar shutdownM)
(Term.spin terminalSystem)
(Term.stopSpin terminalSystem)
(Term.spin muxed)
(Term.stopSpin muxed)
(writeTQueue persistQ)
tSaveSignal <- saveSignalThread saveM
@ -220,7 +229,7 @@ drivers pierPath inst who mPort plan shutdownSTM termSys =
(httpBorn, runHttp) = serv pierPath inst plan
(clayBorn, runClay) = clay pierPath inst plan
(irisBorn, runIris) = client inst plan
(termBorn, runTerm) = term termSys shutdownSTM pierPath inst plan
(termBorn, runTerm) = Term.term termSys shutdownSTM pierPath inst plan
initialEvents = mconcat [behnBorn, clayBorn, amesBorn, httpBorn,
termBorn, irisBorn]
runDrivers = do

View File

@ -1,6 +1,6 @@
module Vere.Term
( module Term
, initializeLocalTerminal
, localClient
, term
) where
@ -104,11 +104,11 @@ isTerminalBlit _ = True
--------------------------------------------------------------------------------
-- Initializes the generalized input/output parts of the terminal.
--
initializeLocalTerminal :: forall e. HasLogFunc e
=> RAcquire e Client
initializeLocalTerminal = fst <$> mkRAcquire start stop
{-
Initializes the generalized input/output parts of the terminal.
-}
localClient :: e. HasLogFunc e => RAcquire e Client
localClient = fst <$> mkRAcquire start stop
where
start :: HasLogFunc e => RIO e (Client, Private)
start = do
@ -154,18 +154,24 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop
-- take the terminal out of raw mode
io $ setTerminalAttributes stdInput pPreviousConfiguration Immediately
-- A list of terminal flags that we disable
disabledFlags = [
-- lflag
StartStopOutput, KeyboardInterrupts, EnableEcho, EchoLF,
ProcessInput, ExtendedFunctions,
-- iflag
MapCRtoLF, CheckParity, StripHighBit,
-- cflag, todo: Terminal library missing CSIZE?
EnableParity,
-- oflag
ProcessOutput
]
{-
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
@ -281,22 +287,17 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop
-- 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) -> do
termShowCursor t ls (fromIntegral w)
(Lin c) -> do
ls2 <- termShowClear t ls
termShowLine t ls2 (pack c)
(Mor ()) -> do
termShowMore t ls
(Sag path noun) -> pure ls
(Sav path atom) -> pure ls
(Url url) -> pure ls
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

View File

@ -0,0 +1,48 @@
{-
This allows multiple (zero or more) terminal clients to connect to
the *same* logical arvo terminal. Terminals that connect will be
given full event history since the creation of the demuxer.
-}
module Vere.Term.Demux (Demux, mkDemux, addDemux, useDemux) where
import UrbitPrelude
import Arvo (Belt)
import Vere.Term.API (Client(Client))
import qualified Vere.Term.API as Term
--------------------------------------------------------------------------------
data Demux = Demux
{ dConns :: TVar [Client]
, dStash :: TVar [Term.Ev]
}
mkDemux :: STM Demux
mkDemux = Demux <$> newTVar [] <*> newTVar []
addDemux :: Client -> Demux -> STM ()
addDemux conn Demux{..} = do
stash <- readTVar dStash
modifyTVar' dConns (conn:)
for_ stash (Term.give conn)
useDemux :: Demux -> Client
useDemux d = Client { give = dGive d, take = dTake d }
-- Internal --------------------------------------------------------------------
dGive :: Demux -> Term.Ev -> STM ()
dGive Demux{..} ev = do
modifyTVar' dStash (ev:)
conns <- readTVar dConns
for_ conns $ \c -> Term.give c ev
dTake :: Demux -> STM Belt
dTake Demux{..} = do
conns <- readTVar dConns
asum (Term.take <$> conns)