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

pkg/king/lib/Vere/Pier.hs

@@ -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

pkg/king/lib/Vere/Term.hs

@@ -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

pkg/king/lib/Vere/Term/Demux.hs

@@ -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)