king: set initial terminal size and react to resizes

This changes startup so we get the size of the current terminal to send to Urbit on startup. We then subscribe to terminal size change notifications and send those to your Urbit via the terminal muxing system. In the case where there are multiple terminal connections to your Urbit, set the terminal size to the minimum of the widths.
2024-12-29 15:14:17 +03:00 · 2020-09-25 11:32:17 -04:00 · 2020-09-25 11:32:17 -04:00 · 20a6c0331c
commit 20a6c0331c
parent e9f09e32c1
6 changed files with 122 additions and 36 deletions
--- a/pkg/hs/urbit-king/lib/Urbit/King/API.hs
+++ b/pkg/hs/urbit-king/lib/Urbit/King/API.hs
@ -18,7 +18,6 @@ import Urbit.Prelude

 import Network.Socket (Socket)
 import Prelude        (read)
-import Urbit.Arvo     (Belt)
 import Urbit.King.App (HasPierPath(..))

 import qualified Network.HTTP.Types             as H
@ -32,7 +31,7 @@ import qualified Urbit.Vere.Term.API            as Term

 -- Types -----------------------------------------------------------------------

-type TermConn = NounServ.Conn Belt [Term.Ev]
+type TermConn = NounServ.Conn Term.ClientTake [Term.Ev]

 type TermConnAPI = TVar (Maybe (TermConn -> STM ()))

--- a/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs
+++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs
@ -31,7 +31,7 @@ import System.Posix.Files     (ownerModes, setFileMode)
 import Urbit.EventLog.LMDB    (EventLog)
 import Urbit.King.API         (TermConn)
 import Urbit.Noun.Time        (Wen)
-import Urbit.TermSize         (TermSize(..))
+import Urbit.TermSize         (TermSize(..), termSize)
 import Urbit.Vere.Serf        (Serf)

 import qualified Data.Text              as T
@ -283,8 +283,10 @@ pier (serf, log) vSlog startedSig = do
    writeTVar (King.kTermConn kingApi) (Just $ writeTQueue q)
    pure q

+  initialTermSize <- io $ termSize
+
  (demux :: Term.Demux, muxed :: Term.Client) <- atomically $ do
-    res <- Term.mkDemux
+    res <- Term.mkDemux initialTermSize
    pure (res, Term.useDemux res)

  void $ acquireWorker "TERMSERV Listener" $ forever $ do
@ -312,7 +314,7 @@ pier (serf, log) vSlog startedSig = do
  (bootEvents, startDrivers) <- do
    env <- ask
    let err = atomically . Term.trace muxed . (<> "\r\n")
-    let siz = TermSize { tsWide = 80, tsTall = 24 }
+    siz <- atomically $ Term.curDemuxSize demux
    let fak = isFake logId
    drivers env ship fak compute (siz, muxed) err sigint

--- a/pkg/hs/urbit-king/lib/Urbit/Vere/Term.hs
+++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Term.hs
@ -28,7 +28,7 @@ import Data.List           ((!!))
 import RIO.Directory       (createDirectoryIfMissing)
 import Urbit.King.API      (readPortsFile)
 import Urbit.TermSize      (TermSize(TermSize))
-import Urbit.Vere.Term.API (Client(Client))
+import Urbit.Vere.Term.API (Client(Client), ClientTake(..))

 import qualified Data.Set                 as S
 import qualified Data.ByteString.Internal as BS
@ -71,7 +71,7 @@ data Private = Private

 -- Utils -----------------------------------------------------------------------

-initialBlew w h = EvBlip $ BlipEvTerm $ TermEvBlew (UD 1, ()) w h
+blewEvent w h = EvBlip $ BlipEvTerm $ TermEvBlew (UD 1, ()) w h

 initialHail = EvBlip $ BlipEvTerm $ TermEvHail (UD 1, ()) ()

@ -98,7 +98,7 @@ isTerminalBlit _         = True

 --------------------------------------------------------------------------------

-connClient :: Serv.Conn Belt [Term.Ev] -> Client
+connClient :: Serv.Conn ClientTake [Term.Ev] -> Client
 connClient c = Client
    { give = Serv.cSend c
    , take = Serv.cRecv c
@ -135,7 +135,7 @@ runTerminalClient pier = runRAcquire $ do
    mPort      <- runRIO (HCD pier) readPortsFile
    port       <- maybe (error "Can't connect") pure mPort
    mExit      <- io newEmptyTMVarIO
-    (siz, cli) <- localClient (putTMVar mExit ())
+    cli        <- localClient (putTMVar mExit ())
    (tid, sid) <- connectToRemote (Port $ fromIntegral port) cli
    atomically $ waitSTM tid <|> waitSTM sid <|> takeTMVar mExit

@ -175,14 +175,28 @@ _spin_idle_us = 500000
 -}
 localClient :: ∀e. HasLogFunc e
            => STM ()
-            -> RAcquire e (TermSize, Client)
+            -> RAcquire e Client
 localClient doneSignal = fst <$> mkRAcquire start stop
  where
-    start :: HasLogFunc e => RIO e ((TermSize, Client), Private)
+    start :: HasLogFunc e => RIO e (Client, Private)
    start = do
      tsWriteQueue  <- newTQueueIO :: RIO e (TQueue [Term.Ev])
      spinnerMVar   <- newEmptyTMVarIO :: RIO e (TMVar ())
-      tsizeTVar     <- io $ T.termSize >>= newTVarIO
+
+      -- 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.
+      tsSizeChangeQueue <- newTQueueIO
+      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.
+                              writeTQueue tsSizeChangeQueue ts)
+
      pWriterThread <- asyncBound
        (writeTerminal tsWriteQueue spinnerMVar tsizeTVar)

@ -201,17 +215,18 @@ localClient doneSignal = fst <$> mkRAcquire start stop
      pReaderThread <- asyncBound
          (readTerminal tsReadQueue tsWriteQueue (bell tsWriteQueue))

-      let client = Client { take = Just <$> readTQueue tsReadQueue
+      let client = Client { take = Just <$> asum [
+                              readTQueue tsReadQueue <&> ClientTakeBelt,
+                              readTQueue tsSizeChangeQueue <&> ClientTakeSize
+                              ]
                          , give = writeTQueue tsWriteQueue
                          }

-      tsize <- io $ T.liveTermSize (\ts -> atomically $ writeTVar tsizeTVar ts)
-
-      pure ((tsize, client), Private{..})
+      pure (client, Private{..})

    stop :: HasLogFunc e
-         => ((TermSize, Client), Private) -> RIO e ()
-    stop ((_, Client{..}), Private{..}) = do
+         => (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
@ -583,7 +598,7 @@ term'
  -> RIO e ([Ev], RAcquire e (DriverApi TermEf))
 term' (tsize, client) serfSIGINT = do
  let TermSize wi hi = tsize
-      initEv = [initialBlew wi hi, initialHail]
+      initEv = [blewEvent wi hi, initialHail]

  pure (initEv, runDriver)
 where
@ -619,13 +634,16 @@ term env (tsize, Client{..}) plan serfSIGINT = runTerm
    readLoop :: RIO e ()
    readLoop = forever $ do
        atomically take >>= \case
-            Nothing -> pure ()
-            Just b  -> do
+            Nothing                              -> pure ()
+            Just (ClientTakeBelt b)              -> do
                when (b == Ctl (Cord "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
--- a/pkg/hs/urbit-king/lib/Urbit/Vere/Term/API.hs
+++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Term/API.hs
@ -3,6 +3,7 @@
 -}
 module Urbit.Vere.Term.API (Ev(..),
                            Client(..),
+                            ClientTake(..),
                            trace,
                            slog,
                            spin,
@ -12,6 +13,7 @@ import Urbit.Prelude hiding (trace)

 import Urbit.Arvo (Belt, Blit)

+import Urbit.TermSize

 -- External Types --------------------------------------------------------------

@ -31,8 +33,31 @@ data Ev = Blits [Blit]
        | Spinr (Maybe (Maybe Cord))
  deriving (Show)

+data ClientTake
+  = ClientTakeBelt Belt
+  | ClientTakeSize TermSize
+  deriving (Show)
+
+instance ToNoun ClientTake where
+  toNoun = \case
+    ClientTakeBelt b              -> toNoun $ (Cord "belt", b)
+    ClientTakeSize (TermSize w h) -> toNoun $ (Cord "size", (w, h))
+
+instance FromNoun ClientTake where
+  parseNoun n = named "ClientTake" $ do
+    (Cord name, rest) <- parseNoun n
+    case name of
+      "belt" -> do
+        b <- parseNoun rest
+        pure (ClientTakeBelt b)
+      "size" -> do
+        (w, h) <- parseNoun rest
+        pure (ClientTakeSize (TermSize w h))
+      _ -> fail "weird client take"
+
+
 data Client = Client
-    { take :: STM (Maybe Belt)
+    { take :: STM (Maybe ClientTake)
    , give :: [Ev] -> STM ()
    }

--- a/pkg/hs/urbit-king/lib/Urbit/Vere/Term/Demux.hs
+++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Term/Demux.hs
@ -4,12 +4,15 @@
    given full event history since the creation of the demuxer.
 -}

-module Urbit.Vere.Term.Demux (Demux, mkDemux, addDemux, useDemux) where
+module Urbit.Vere.Term.Demux (Demux,
+                              mkDemux,
+                              addDemux,
+                              useDemux,
+                              curDemuxSize) where

 import Urbit.Prelude
-
-import Urbit.Arvo          (Belt)
-import Urbit.Vere.Term.API (Client(Client))
+import Urbit.TermSize
+import Urbit.Vere.Term.API (Client(Client), ClientTake(..))

 import qualified Urbit.Vere.Term.API   as Term
 import qualified Urbit.Vere.Term.Logic as Logic
@ -42,11 +45,17 @@ ksDelete k (KeyedSet t n) = KeyedSet (deleteMap k t) n

 data Demux = Demux
    { dConns :: TVar (KeyedSet Client)
+    , dSizes :: TVar (IntMap TermSize)
    , dStash :: TVar Logic.St
+    , dMinSize :: TVar TermSize
    }

-mkDemux :: STM Demux
-mkDemux = Demux <$> newTVar mempty <*> newTVar Logic.init
+mkDemux :: TermSize -> STM Demux
+mkDemux ts = Demux <$>
+  newTVar mempty <*>
+  newTVar mempty <*>
+  newTVar Logic.init <*>
+  newTVar ts

 addDemux :: Client -> Demux -> STM ()
 addDemux conn Demux{..} = do
@ -57,6 +66,8 @@ addDemux conn Demux{..} = do
 useDemux :: Demux -> Client
 useDemux d = Client { give = dGive d, take = dTake d }

+curDemuxSize :: Demux -> STM TermSize
+curDemuxSize Demux{..} = readTVar dMinSize

 -- Internal --------------------------------------------------------------------

@ -77,16 +88,45 @@ dGive Demux{..} evs = do
    If there are no attached clients, this will not return until one
    is attached.
 -}
-dTake :: Demux -> STM (Maybe Belt)
+dTake :: Demux -> STM (Maybe ClientTake)
 dTake Demux{..} = do
    conns <- readTVar dConns
-    waitForBelt conns >>= \case
-        (_, Just b ) -> pure (Just b)
-        (k, Nothing) -> do writeTVar dConns (ksDelete k conns)
-                           pure Nothing
+    waitForTake conns >>= \case
+        (_, Just (ClientTakeBelt b)) -> pure (Just (ClientTakeBelt b))
+
+        (k, Just (ClientTakeSize s)) -> do
+          newSizeTree <- modifyAndReturnTVar dSizes (insertMap k s)
+          maybeUpdateTerminalSize newSizeTree
+
+        (k, Nothing) -> do
+          writeTVar dConns (ksDelete k conns)
+          newSizeTree <- modifyAndReturnTVar dSizes (deleteMap k)
+          maybeUpdateTerminalSize newSizeTree
+
  where
-    waitForBelt :: KeyedSet Client -> STM (Int, Maybe Belt)
-    waitForBelt ks = asum
+    waitForTake :: KeyedSet Client -> STM (Int, Maybe ClientTake)
+    waitForTake ks = asum
                   $ fmap (\(k,c) -> (k,) <$> Term.take c)
                   $ mapToList
                   $ _ksTable ks
+
+    maybeUpdateTerminalSize :: IntMap TermSize -> STM (Maybe ClientTake)
+    maybeUpdateTerminalSize newSizeTree = do
+      let termSize = foldr minTermSize (TermSize 1024 1024) newSizeTree
+      curSize <- readTVar dMinSize
+      if curSize == termSize
+        then pure Nothing
+        else do
+          writeTVar dMinSize termSize
+          pure $ Just (ClientTakeSize termSize)
+
+    modifyAndReturnTVar :: TVar a -> (a -> a) -> STM a
+    modifyAndReturnTVar var fun = do
+      pre <- readTVar var
+      let post = fun pre
+      writeTVar var post
+      pure post
+
+    minTermSize :: TermSize -> TermSize -> TermSize
+    minTermSize (TermSize wa ha) (TermSize wb hb) =
+      TermSize (min wa wb) (min ha hb)
--- a/pkg/hs/urbit-termsize/lib/Urbit/TermSize.hs
+++ b/pkg/hs/urbit-termsize/lib/Urbit/TermSize.hs
@ -37,4 +37,6 @@ termSize = size <&> \case
 liveTermSize :: (TermSize -> IO ()) -> IO TermSize
 liveTermSize cb = do
  Sys.installHandler Sys.sigWINCH (Sys.Catch (termSize >>= cb)) Nothing
-  termSize
+  ts <- termSize
+  cb ts
+  pure ts