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.

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

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
 

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 (client, Private{..})
-
-      pure ((tsize, client), Private{..})
 
     stop :: HasLogFunc e
-         => ((TermSize, Client), Private) -> RIO e ()
+         => (Client, Private) -> RIO e ()
-    stop ((_, Client{..}), 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
@@ -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
@@ -620,12 +635,15 @@ term env (tsize, Client{..}) plan serfSIGINT = runTerm
     readLoop = forever $ do
         atomically take >>= \case
             Nothing                              -> pure ()
-            Just b  -> do
+            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

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 ()
     }
 

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.TermSize
-import Urbit.Arvo          (Belt)
+import Urbit.Vere.Term.API (Client(Client), ClientTake(..))
-import Urbit.Vere.Term.API (Client(Client))
 
 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 :: TermSize -> STM Demux
-mkDemux = Demux <$> newTVar mempty <*> newTVar Logic.init
+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
+    waitForTake conns >>= \case
-        (_, Just b ) -> pure (Just b)
+        (_, Just (ClientTakeBelt b)) -> pure (Just (ClientTakeBelt b))
-        (k, Nothing) -> do writeTVar dConns (ksDelete k conns)
+
-                           pure Nothing
+        (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)
+    waitForTake :: KeyedSet Client -> STM (Int, Maybe ClientTake)
-    waitForBelt ks = asum
+    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)

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