Merge branch 'king-haskell' into king-exit-cleanly

pkg/king/app/CLI.hs

@@ -68,6 +68,7 @@ data Cmd
     = CmdNew New Opts
     | CmdRun Run Opts
     | CmdBug Bug
+    | CmdCon Word16
   deriving (Show)
 
 --------------------------------------------------------------------------------
@@ -270,6 +271,13 @@ bugCmd = fmap CmdBug
             $ progDesc "Parse all data in event log"
             )
 
+conCmd :: Parser Cmd
+conCmd = do
+    port <- argument auto ( metavar "PORT"
+                         <> help "Port of terminal server"
+                          )
+    pure (CmdCon port)
+
 allFx :: Parser Bug
 allFx = do
     bPierPath <- strArgument (metavar "PIER" <> help "Path to pier")
@@ -286,3 +294,6 @@ cmd = subparser
        <> command "bug" ( info (bugCmd <**> helper)
                         $ progDesc "Run a debugging sub-command."
                         )
+       <> command "con" ( info (conCmd <**> helper)
+                        $ progDesc "Connect a terminal to a running urbit."
+                        )

pkg/king/app/Main.hs

@@ -113,6 +113,7 @@ import qualified System.IO.LockFile.Internal as Lock
 import qualified Vere.Log                    as Log
 import qualified Vere.Pier                   as Pier
 import qualified Vere.Serf                   as Serf
+import qualified Vere.Term                   as Term
 
 --------------------------------------------------------------------------------
 
@@ -341,6 +342,14 @@ main = do
         CLI.CmdBug (CLI.ValidatePill pax pil seq) -> testPill pax pil seq
         CLI.CmdBug (CLI.ValidateEvents pax f l)   -> checkEvs pax f l
         CLI.CmdBug (CLI.ValidateFX pax f l)       -> checkFx  pax f l
+        CLI.CmdCon port                           -> connTerm port
+
+
+--------------------------------------------------------------------------------
+
+connTerm :: ∀e. HasLogFunc e => Word16 -> RIO e ()
+connTerm port =
+    Term.runTerminalClient (fromIntegral port)
 
 --------------------------------------------------------------------------------
 

pkg/king/lib/Arvo/Event.hs

@@ -302,23 +302,25 @@ instance FromNoun Ev where
 
 -- Short Event Names -----------------------------------------------------------
 
-getSpinnerNameForEvent :: Ev -> Maybe String
+{-
+    In the case of the user hitting enter, the cause is technically a
+    terminal event, but we don't display any name because the cause is
+    really the user.
+-}
+getSpinnerNameForEvent :: Ev -> Maybe Text
 getSpinnerNameForEvent = \case
-  EvVane _ -> Nothing
+    EvVane _ -> Nothing
-  EvBlip b -> case b of
+    EvBlip b -> case b of
-    BlipEvAmes _ -> Just "ames"
+        BlipEvAmes _           -> Just "ames"
-    BlipEvArvo _ -> Just "arvo"
+        BlipEvArvo _           -> Just "arvo"
-    BlipEvBehn _ -> Just "behn"
+        BlipEvBehn _           -> Just "behn"
-    BlipEvBoat _ -> Just "boat"
+        BlipEvBoat _           -> Just "boat"
-    BlipEvHttpClient _ -> Just "iris"
+        BlipEvHttpClient _     -> Just "iris"
-    BlipEvHttpServer _ -> Just "eyre"
+        BlipEvHttpServer _     -> Just "eyre"
-    BlipEvNewt _       -> Just "newt"
+        BlipEvNewt _           -> Just "newt"
-    BlipEvSync _       -> Just "clay"
+        BlipEvSync _           -> Just "clay"
-    BlipEvTerm t -> case t of
+        BlipEvTerm t | isRet t -> Nothing
-      TermEvBelt _ belt -> case belt of
+        BlipEvTerm t           -> Just "term"
-        -- In the case of the user hitting enter, the cause is technically a
+  where
-        -- terminal event, but we don't display any name because the cause is
+    isRet (TermEvBelt _ (Ret ())) = True
-        -- really the user.
+    isRet _                       = False
-        Ret () -> Nothing
-        _      -> Just "term"
-      _ -> Just "term"

pkg/king/lib/Vere/NounServ.hs

@@ -44,6 +44,9 @@ wsConn :: (FromNoun i, ToNoun o, Show o, HasLogFunc e)
        -> RIO e ()
 wsConn pre inp out wsc = do
     env <- ask
+
+    logWarn (pre <> "(wcConn) Connected!")
+
     writer <- io $ async $ runRIO env $ forever $ do
         logWarn (pre <> "(wsConn) Waiting for data.")
         byt <- io $ toStrict <$> WS.receiveData wsc
@@ -81,11 +84,11 @@ wsClient por = do
     out <- io $ newTBMChanIO 5
     con <- pure (mkConn inp out)
 
-    logDebug "(wsClie) Trying to connect"
+    logDebug "NOUNSERV (wsClie) Trying to connect"
 
     tid <- io $ async
               $ WS.runClient "127.0.0.1" por "/"
-              $ runRIO env . wsConn "(wsClie) " inp out
+              $ runRIO env . wsConn "NOUNSERV (wsClie) " inp out
 
     pure $ Client con tid
 
@@ -97,18 +100,18 @@ wsServer = do
     con <- io $ newTBMChanIO 5
 
     let app pen = do
-            logError "(wsServer) Got connection! Accepting"
+            logError "NOUNSERV (wsServer) Got connection! Accepting"
             wsc <- io $ WS.acceptRequest pen
             inp <- io $ newTBMChanIO 5
             out <- io $ newTBMChanIO 5
             atomically $ writeTBMChan con (mkConn inp out)
-            wsConn "(wsServ) " inp out wsc
+            wsConn "NOUNSERV (wsServ) " inp out wsc
 
     tid <- async $ do
         env <- ask
-        logError "(wsServer) Starting server"
+        logError "NOUNSERV (wsServer) Starting server"
         io $ WS.runServer "127.0.0.1" 9999 (runRIO env . app)
-        logError "(wsServer) Server died"
+        logError "NOUNSERV (wsServer) Server died"
         atomically $ closeTBMChan con
 
     pure $ Server (readTBMChan con) tid 9999

pkg/king/lib/Vere/Pier.hs

@@ -18,14 +18,17 @@ 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 System.Console.Terminal.Size as TSize
-import qualified Urbit.Time     as Time
+import qualified System.Entropy               as Ent
-import qualified Vere.Log       as Log
+import qualified Urbit.Time                   as Time
-import qualified Vere.Serf      as Serf
+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
 
 
 --------------------------------------------------------------------------------
@@ -132,38 +135,71 @@ resumed top flags = do
 
 -- Run Pier --------------------------------------------------------------------
 
+acquireWorker :: RIO e () -> RAcquire e (Async ())
+acquireWorker act = mkRAcquire (async act) cancel
+
 pier :: ∀e. HasLogFunc e
      => FilePath
      -> Maybe Port
      -> (Serf e, EventLog, SerfState)
      -> RAcquire e ()
 pier pierPath mPort (serf, log, ss) = do
-    computeQ <- newTQueueIO :: RAcquire e (TQueue Ev)
+    computeQ  <- newTQueueIO
-    persistQ <- newTQueueIO :: RAcquire e (TQueue (Job, FX))
+    persistQ  <- newTQueueIO
-    executeQ <- newTQueueIO :: RAcquire e (TQueue FX)
+    executeQ  <- newTQueueIO
+    saveM     <- newEmptyTMVarIO
+    shutdownM <- newEmptyTMVarIO
 
-    saveM <- newEmptyTMVarIO :: RAcquire e (TMVar ())
-    shutdownM <- newEmptyTMVarIO :: RAcquire e (TMVar ())
     let shutdownEvent = putTMVar shutdownM ()
 
     inst <- io (KingId . UV . fromIntegral <$> randomIO @Word16)
 
-    terminalSystem <- initializeLocalTerminal
+    (sz, local) <- Term.localClient
-    swapMVar (sStderr serf) (tsStderr terminalSystem)
+
+    (waitExternalTerm, termServPort) <- Term.termServer
+
+    (demux, muxed) <- atomically $ do
+        res <- Term.mkDemux
+        Term.addDemux local res
+        pure (res, Term.useDemux res)
+
+    rio $ logInfo $ display $
+        "TERMSERV Terminal Server running on port: " <> tshow termServPort
+
+    let listenLoop = do
+            logTrace "TERMSERV Waiting for external terminal."
+            ok <- atomically $ do
+                waitExternalTerm >>= \case
+                    Nothing  -> pure False
+                    Just ext -> Term.addDemux ext demux >> pure True
+            if ok
+               then do logTrace "TERMSERV External terminal connected"
+                       listenLoop
+               else logTrace "TERMSERV Termainal server is dead"
+
+    acquireWorker listenLoop
+
+    swapMVar (sStderr serf) (atomically . Term.trace muxed)
 
     let ship = who (Log.identity log)
 
     let (bootEvents, startDrivers) =
-          drivers pierPath inst ship mPort (writeTQueue computeQ)
+            drivers pierPath inst ship mPort
-            shutdownEvent terminalSystem
+                (writeTQueue computeQ)
+                shutdownEvent
+                (sz, muxed)
 
     io $ atomically $ for_ bootEvents (writeTQueue computeQ)
 
     tExe  <- startDrivers >>= router (readTQueue executeQ)
     tDisk <- runPersist log persistQ (writeTQueue executeQ)
-    tCpu  <- runCompute serf ss (readTQueue computeQ) (takeTMVar saveM)
+    tCpu  <- runCompute serf ss
-      (takeTMVar shutdownM) (tsShowSpinner terminalSystem)
+               (readTQueue computeQ)
-      (tsHideSpinner terminalSystem) (writeTQueue persistQ)
+               (takeTMVar saveM)
+               (takeTMVar shutdownM)
+               (Term.spin muxed)
+               (Term.stopSpin muxed)
+               (writeTQueue persistQ)
 
     tSaveSignal <- saveSignalThread saveM
 
@@ -205,7 +241,7 @@ data Drivers e = Drivers
 
 drivers :: HasLogFunc e
         => FilePath -> KingId -> Ship -> Maybe Port -> (Ev -> STM ()) -> STM()
-        -> TerminalSystem e
+        -> (TSize.Window Word, Term.Client)
         -> ([Ev], RAcquire e (Drivers e))
 drivers pierPath inst who mPort plan shutdownSTM termSys =
     (initialEvents, runDrivers)
@@ -215,7 +251,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
@@ -286,7 +322,7 @@ runCompute :: ∀e. HasLogFunc e
            -> STM Ev
            -> STM ()
            -> STM ()
-           -> (Maybe String -> STM ())
+           -> (Maybe Text -> STM ())
            -> STM ()
            -> ((Job, FX) -> STM ())
            -> RAcquire e (Async ())

pkg/king/lib/Vere/Term.hs

@@ -1,43 +1,44 @@
-module Vere.Term (initializeLocalTerminal, term, TerminalSystem(..)) where
+module Vere.Term
-
+    ( module Term
-import Arvo            hiding (Term)
+    , localClient
-import Urbit.Time
+    , connectToRemote
-import UrbitPrelude    hiding (getCurrentTime)
+    , runTerminalClient
-import Vere.Pier.Types
+    , termServer
+    , term
+    ) where
 
+import Arvo                  hiding (Term)
 import Data.Char
-import Data.List             ((!!))
 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 RIO.Directory                (createDirectoryIfMissing)
+import Data.List     ((!!))
-import RIO.FilePath
+import RIO.Directory (createDirectoryIfMissing)
-import System.Console.Terminfo.Base
+import Vere.Term.API (Client(Client))
 
-import Data.ByteString.Internal
+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
 
-import qualified Data.ByteString      as B
-import qualified Data.ByteString.UTF8 as UTF8
 
 -- Types -----------------------------------------------------------------------
 
--- Output to the attached terminal is either a series of vere blits, or it is an
--- injected printf line from the interpreter.
-data VereOutput = VereBlitOutput [Blit]
-                | VerePrintOutput String
-                | VereBlankLine
-                | VereShowSpinner (Maybe String)
-                | VereHideSpinner
-
 -- All stateful data in the printing to stdOutput.
 data LineState = LineState
-  { lsLine            :: String
+  { lsLine            :: Text
   , lsCurPos          :: Int
   , lsSpinTimer       :: Maybe (Async ())
-  , lsSpinCause       :: Maybe String
+  , lsSpinCause       :: Maybe Text
   , lsSpinFirstRender :: Bool
   , lsSpinFrame       :: Int
   , lsPrevEndTime     :: Wen
@@ -52,21 +53,7 @@ data ReadData = ReadData
   , rdUTF8width :: Int
   }
 
--- Minimal terminal interface.
+-- Private data to the Client that we keep around for stop().
---
--- A Terminal can either be local or remote. Either way, the Terminal, from the
--- view of the caller, a terminal has a thread which when exits indicates that
--- the session is over, and has a general in/out queue in the types of the
--- vere/arvo interface.
-data TerminalSystem e = TerminalSystem
-  { tsReadQueue   :: TQueue Belt
-  , tsWriteQueue  :: TQueue VereOutput
-  , tsStderr      :: Text -> RIO e ()
-  , tsShowSpinner :: Maybe String -> STM ()
-  , tsHideSpinner :: STM ()
-  }
-
--- Private data to the TerminalSystem that we keep around for stop().
 data Private = Private
   { pReaderThread          :: Async ()
   , pWriterThread          :: Async ()
@@ -76,6 +63,9 @@ data Private = Private
 
 -- 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, ()) ()
@@ -83,10 +73,14 @@ 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 = ['|', '/', '-', '\\']
+spinners :: [Text]
+spinners = ["|", "/", "-", "\\"]
 
-leftBracket = ['«']
+leftBracket :: Text
-rightBracket = ['»']
+leftBracket = "«"
+
+rightBracket :: Text
+rightBracket = "»"
 
 _spin_cool_us = 500000
 _spin_warm_us = 50000
@@ -95,10 +89,10 @@ _spin_idle_us = 500000
 
 --------------------------------------------------------------------------------
 
-runMaybeTermOutput :: Terminal -> (Terminal -> Maybe TermOutput) -> RIO e ()
+runMaybeTermOutput :: T.Terminal -> (T.Terminal -> Maybe T.TermOutput) -> RIO e ()
 runMaybeTermOutput t getter = case (getter t) of
   Nothing -> pure ()
-  Just x  -> io $ runTermOutput t x
+  Just x  -> io $ T.runTermOutput t x
 
 rioAllocaBytes :: (MonadIO m, MonadUnliftIO m)
                => Int -> (Ptr a -> m b) -> m b
@@ -116,50 +110,100 @@ isTerminalBlit _         = True
 
 --------------------------------------------------------------------------------
 
--- Initializes the generalized input/output parts of the terminal.
+{-
---
+    TODO XX HACK: We don't have any good way of handling client
-initializeLocalTerminal :: forall e. HasLogFunc e
+        disconnect, so we just retry. This will probably waste CPU.
-                        => RAcquire e (TerminalSystem e)
+-}
-initializeLocalTerminal = fst <$> mkRAcquire start stop
+termServer :: ∀e. HasLogFunc e
+           => RAcquire e (STM (Maybe Client), Port)
+termServer = fst <$> mkRAcquire start stop
   where
-    start :: HasLogFunc e => RIO e (TerminalSystem e, Private)
+    stop = cancel . snd
     start = do
-      --  Initialize the writing side of the terminal
+        serv <- Serv.wsServer @Belt @[Term.Ev]
-      --
-      pTerminal <- io $ setupTermFromEnv
-      -- TODO: We still need to actually get the size from the terminal somehow.
 
-      tsWriteQueue <- newTQueueIO
+        let getClient = do
-      spinnerMVar <- newEmptyTMVarIO
+                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
+      pTerminal     <- io $ T.setupTermFromEnv
+      tsWriteQueue  <- newTQueueIO
+      spinnerMVar   <- newEmptyTMVarIO
       pWriterThread <-
-        asyncBound (writeTerminal pTerminal tsWriteQueue spinnerMVar)
+          asyncBound (writeTerminal pTerminal 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 =
+      let newTermSettings = flip withTime     0
-            flip withTime     0 .
+                          $ flip withMinInput 1
-            flip withMinInput 1 $
+                          $ foldl' withoutMode pPreviousConfiguration
-            foldl' withoutMode pPreviousConfiguration disabledFlags
+                          $ disabledFlags
+
       io $ setTerminalAttributes stdInput newTermSettings Immediately
 
       tsReadQueue <- newTQueueIO
       pReaderThread <- asyncBound
           (readTerminal tsReadQueue tsWriteQueue (bell tsWriteQueue))
 
-      let tsStderr = \txt ->
+      let client = Client { take = readTQueue tsReadQueue
-            atomically $ writeTQueue tsWriteQueue $ VerePrintOutput $ unpack txt
+                          , give = writeTQueue tsWriteQueue
+                          }
 
-      let tsShowSpinner = \str ->
+      tsize <- io $ TSize.size <&> fromMaybe (TSize.Window 80 24)
-            writeTQueue tsWriteQueue $ VereShowSpinner str
-      let tsHideSpinner = writeTQueue tsWriteQueue $ VereHideSpinner
 
-      pure (TerminalSystem{..}, Private{..})
+      pure ((tsize, client), Private{..})
 
     stop :: HasLogFunc e
-         => (TerminalSystem e, Private) -> RIO e ()
+         => ((TSize.Window Word, Client), Private) -> RIO e ()
-    stop (TerminalSystem{..}, Private{..}) = do
+    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
@@ -173,21 +217,27 @@ 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 = [
+        A list of terminal flags that we disable.
-      -- lflag
+
-      StartStopOutput, KeyboardInterrupts, EnableEcho, EchoLF,
+        TODO: Terminal library missing CSIZE?
-      ProcessInput, ExtendedFunctions,
+    -}
-      -- iflag
+    disabledFlags :: [TerminalMode]
-      MapCRtoLF, CheckParity, StripHighBit,
+    disabledFlags = [ StartStopOutput
-      -- cflag, todo: Terminal library missing CSIZE?
+                    , KeyboardInterrupts
-      EnableParity,
+                    , EnableEcho
-      -- oflag
+                    , EchoLF
-      ProcessOutput
+                    , ProcessInput
-      ]
+                    , ExtendedFunctions
+                    , MapCRtoLF
+                    , CheckParity
+                    , StripHighBit
+                    , EnableParity
+                    , ProcessOutput
+                    ]
 
     getCap term cap =
-      getCapability term (tiGetOutput1 cap) :: Maybe TermOutput
+      T.getCapability term (T.tiGetOutput1 cap) :: Maybe T.TermOutput
 
     vtClearScreen t  = getCap t "clear"
     vtClearToBegin t = getCap t "el"
@@ -209,48 +259,49 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop
 
     -- Writes data to the terminal. Both the terminal reading, normal logging,
     -- and effect handling can all emit bytes which go to the terminal.
-    writeTerminal :: Terminal -> TQueue VereOutput -> TMVar () -> RIO e ()
+    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
-        loop ls@LineState{..} = do
+        writeBlank :: LineState -> RIO e LineState
-          x <- atomically $
+        writeBlank ls = do
-                 Right <$> readTQueue q <|>
+            io $ T.runTermOutput t $ termText "\r\n"
-                 Left <$> takeTMVar spinner
+            pure ls
-          case x of
-            Right (VereBlitOutput blits) -> do
-              ls <- foldM (writeBlit t) ls blits
-              loop ls
-            Right (VerePrintOutput p) -> do
-              io $ runTermOutput t $ termText "\r"
-              runMaybeTermOutput t vtClearToBegin
-              io $ runTermOutput t $ termText p
-              ls <- termRefreshLine t ls
-              loop ls
-            Right VereBlankLine -> do
-              io $ runTermOutput t $ termText "\r\n"
-              loop ls
-            Right (VereShowSpinner txt) -> do
-              current <- io $ now
-              -- 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.
-              let delay = case txt 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
+        writeTrace :: LineState -> Text -> RIO e LineState
-              loop ls { lsSpinTimer = Just spinTimer,
+        writeTrace ls p = do
-                        lsSpinCause = txt,
+            io $ T.runTermOutput t $ termText "\r"
-                        lsSpinFirstRender = True }
+            runMaybeTermOutput t vtClearToBegin
-            Right VereHideSpinner -> do
+            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
@@ -264,41 +315,55 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop
                     else pure ls
 
               endTime <- io $ now
-              loop ls { lsSpinTimer = Nothing, lsPrevEndTime = endTime }
+              pure $ ls { lsSpinTimer = Nothing, lsPrevEndTime = endTime }
-            Left () -> do
-              let spinner = [spinners !! lsSpinFrame] ++ case lsSpinCause of
-                    Nothing  -> []
-                    Just str -> leftBracket ++ str ++ rightBracket
 
-              io $ runTermOutput t $ termText spinner
+        execEv :: LineState -> Term.Ev -> RIO e LineState
-              termSpinnerMoveLeft t (length spinner)
+        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
 
-              loop ls { lsSpinFirstRender = False,
+        spin :: LineState -> RIO e LineState
-                        lsSpinFrame = (lsSpinFrame + 1) `mod` (length spinners)
+        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 :: Terminal -> LineState -> Blit -> RIO e LineState
+    writeBlit :: T.Terminal -> LineState -> Blit -> RIO e LineState
     writeBlit t ls = \case
-      Bel () -> do
+      Bel ()        -> do runMaybeTermOutput t vtSoundBell
-        runMaybeTermOutput t vtSoundBell
+                          pure ls
-        pure ls
+      Clr ()        -> do runMaybeTermOutput t vtClearScreen
-      Clr () -> do
+                          termRefreshLine t ls
-        runMaybeTermOutput t vtClearScreen
+      Hop w         -> termShowCursor t ls (fromIntegral w)
-        termRefreshLine t ls
+      Lin c         -> do ls2 <- termShowClear t ls
-      (Hop w) -> do
+                          termShowLine t ls2 (pack c)
-        termShowCursor t ls (fromIntegral w)
+      Mor ()        -> termShowMore t ls
-      (Lin c)  -> do
+      Sag path noun -> pure ls
-        ls2 <- termShowClear t ls
+      Sav path atom -> pure ls
-        termShowLine t ls2 (pack c)
+      Url url       -> pure ls
-      (Mor ()) -> do
-        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 :: Terminal -> LineState -> Int -> RIO e LineState
+    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)
@@ -309,33 +374,32 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop
       else
         pure ls
 
-
     -- Moves the cursor left without any mutation of the LineState. Used only
     -- in cursor spinning.
-    termSpinnerMoveLeft :: Terminal -> Int -> RIO e ()
+    termSpinnerMoveLeft :: T.Terminal -> Int -> RIO e ()
     termSpinnerMoveLeft t count =
       replicateM_ count (runMaybeTermOutput t vtParmLeft)
 
     -- Displays and sets the current line
-    termShowLine :: Terminal -> LineState -> String -> RIO e LineState
+    termShowLine :: T.Terminal -> LineState -> Text -> RIO e LineState
     termShowLine t ls newStr = do
-      io $ runTermOutput t $ termText newStr
+      io $ T.runTermOutput t $ termText newStr
       pure ls { lsLine = newStr, lsCurPos = (length newStr) }
 
-    termShowClear :: Terminal -> LineState -> RIO e LineState
+    termShowClear :: T.Terminal -> LineState -> RIO e LineState
     termShowClear t ls = do
-      io $ runTermOutput t $ termText "\r"
+      io $ T.runTermOutput t $ termText "\r"
       runMaybeTermOutput t vtClearToBegin
       pure ls { lsLine = "", lsCurPos = 0  }
 
     -- New Current Line
-    termShowMore :: Terminal -> LineState -> RIO e LineState
+    termShowMore :: T.Terminal -> LineState -> RIO e LineState
     termShowMore t ls = do
-      io $ runTermOutput t $ termText "\r\n"
+      io $ T.runTermOutput t $ termText "\r\n"
       pure ls { lsLine = "", lsCurPos = 0  }
 
     -- Redraw the current LineState, maintaining the current curpos
-    termRefreshLine :: Terminal -> LineState -> RIO e LineState
+    termRefreshLine :: T.Terminal -> LineState -> RIO e LineState
     termRefreshLine t ls = do
       let line = (lsLine ls)
           curPos = (lsCurPos ls)
@@ -344,8 +408,8 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop
       termShowCursor t ls curPos
 
     -- ring my bell
-    bell :: TQueue VereOutput -> RIO e ()
+    bell :: TQueue [Term.Ev] -> RIO e ()
-    bell q = atomically $ writeTQueue q $ VereBlitOutput [Bel ()]
+    bell q = atomically $ writeTQueue q $ [Term.Blits [Bel ()]]
 
     -- Reads data from stdInput and emit the proper effect
     --
@@ -356,9 +420,9 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop
     -- 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 VereOutput -> (RIO e ()) -> RIO e ()
+                 => TQueue Belt -> TQueue [Term.Ev] -> (RIO e ()) -> RIO e ()
     readTerminal rq wq bell =
-      rioAllocaBytes 1 $ \ buf -> loop (ReadData buf False False B.empty 0)
+      rioAllocaBytes 1 $ \ buf -> loop (ReadData buf False False mempty 0)
       where
         loop :: ReadData -> RIO e ()
         loop rd@ReadData{..} = do
@@ -375,7 +439,7 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop
             Right _ -> do
               w   <- io $ peek rdBuf
               -- print ("{" ++ (show w) ++ "}")
-              let c = w2c w
+              let c = BS.w2c w
               if rdEscape then
                 if rdBracket then do
                   case c of
@@ -404,13 +468,13 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop
                 rd@ReadData{..} <- pure rd { rdUTF8 = snoc rdUTF8 w }
                 if length rdUTF8 /= rdUTF8width then loop rd
                 else do
-                  case UTF8.decode rdUTF8 of
+                  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 = B.empty, rdUTF8width = 0 }
+                  loop rd { rdUTF8 = mempty, rdUTF8width = 0 }
               else if w >= 32 && w < 127 then do
                 sendBelt $ Txt $ Tour $ [c]
                 loop rd
@@ -427,11 +491,11 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop
                 -- ETX (^C)
                 logDebug $ displayShow "Ctrl-c interrupt"
                 atomically $ do
-                  writeTQueue wq $ VerePrintOutput "interrupt\r\n"
+                  writeTQueue wq [Term.Trace "interrupt\r\n"]
                   writeTQueue rq $ Ctl $ Cord "c"
                 loop rd
               else if w <= 26 then do
-                sendBelt $ Ctl $ Cord $ pack [w2c (w + 97 - 1)]
+                sendBelt $ Ctl $ Cord $ pack [BS.w2c (w + 97 - 1)]
                 loop rd
               else if w == 27 then do
                 loop rd { rdEscape = True }
@@ -450,12 +514,18 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop
 --------------------------------------------------------------------------------
 
 term :: forall e. HasLogFunc e
-     => TerminalSystem e -> (STM ()) -> FilePath -> KingId -> QueueEv
+     => (TSize.Window Word, Client)
+     -> (STM ())
+     -> FilePath
+     -> KingId
+     -> QueueEv
      -> ([Ev], RAcquire e (EffCb e TermEf))
-term TerminalSystem{..} shutdownSTM pierPath king enqueueEv =
+term (tsize, Client{..}) shutdownSTM pierPath king enqueueEv =
     (initialEvents, runTerm)
   where
-    initialEvents = [(initialBlew 80 24), initialHail]
+    TSize.Window wi hi = tsize
+
+    initialEvents = [(initialBlew hi wi), initialHail]
 
     runTerm :: RAcquire e (EffCb e TermEf)
     runTerm = do
@@ -467,7 +537,7 @@ term TerminalSystem{..} shutdownSTM pierPath king enqueueEv =
 
     readBelt :: RIO e ()
     readBelt = forever $ do
-      b <- atomically $ readTQueue tsReadQueue
+      b <- atomically take
       let blip = EvBlip $ BlipEvTerm $ TermEvBelt (UD 1, ()) $ b
       atomically $ enqueueEv $ blip
 
@@ -475,7 +545,7 @@ term TerminalSystem{..} shutdownSTM pierPath king enqueueEv =
     handleEffect = \case
       TermEfBlit _ blits -> do
         let (termBlits, fsWrites) = partition isTerminalBlit blits
-        atomically $ writeTQueue tsWriteQueue (VereBlitOutput termBlits)
+        atomically $ give [Term.Blits termBlits]
         for_ fsWrites handleFsWrite
       TermEfInit _ _ -> pure ()
       TermEfLogo path _ -> do

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

@@ -0,0 +1,41 @@
+module Vere.Term.API (Ev(..), Client(..), trace, spin, stopSpin) where
+
+import UrbitPrelude hiding (trace)
+
+import Arvo (Blit, Belt)
+
+
+-- External Types --------------------------------------------------------------
+
+{-
+    Input Event for terminal driver:
+
+    %blits -- list of blits from arvo.
+    %trace -- stderr line from runtime.
+    %blank -- print a blank line
+    %spinr -- Start or stop the spinner
+-}
+data Ev = Blits [Blit]
+        | Trace Cord
+        | Blank
+        | Spinr (Maybe (Maybe Cord))
+  deriving (Show)
+
+data Client = Client
+    { take :: STM Belt
+    , give :: [Ev] -> STM ()
+    }
+
+deriveNoun ''Ev
+
+
+-- Utilities -------------------------------------------------------------------
+
+trace :: Client -> Text -> STM ()
+trace ts = give ts . singleton . Trace . Cord
+
+spin :: Client -> Maybe Text -> STM ()
+spin ts = give ts . singleton . Spinr . Just . fmap Cord
+
+stopSpin :: Client -> STM ()
+stopSpin ts = give ts [Spinr Nothing]

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

@@ -0,0 +1,50 @@
+{-# OPTIONS_GHC -Wwarn #-}
+
+{-
+    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 <- concat . reverse <$> readTVar dStash
+    modifyTVar' dConns (conn:)
+    Term.give conn stash
+
+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)

pkg/king/package.yaml

@@ -37,6 +37,7 @@ dependencies:
   - classy-prelude
   - conduit
   - containers
+  - data-default
   - data-fix
   - directory
   - entropy
@@ -81,6 +82,7 @@ dependencies:
   - tasty-th
   - template-haskell
   - terminal-progress-bar
+  - terminal-size
   - terminfo
   - text
   - these
@@ -98,7 +100,6 @@ dependencies:
   - warp
   - warp-tls
   - websockets
-  - data-default
 
 default-extensions:
   - ApplicativeDo