Merge pull request #2594 from urbit/siprel/sigwinch

[WIP]: King Gets Terminal Size Updates

pkg/hs/stack.yaml

@@ -9,6 +9,7 @@ packages:
   - urbit-azimuth
   - urbit-eventlog-lmdb
   - urbit-king
+  - urbit-termsize
   - urbit-noun
   - urbit-noun-core
 

pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs

@@ -21,16 +21,15 @@ import Urbit.Prelude
 import Control.Monad.Trans.Maybe
 import RIO.Directory
 import Urbit.Arvo
-import Urbit.King.Config
-import Urbit.Vere.Pier.Types
 import Urbit.King.App
+import Urbit.Vere.Pier.Types
 
 import Control.Monad.STM      (retry)
 import System.Posix.Files     (ownerModes, setFileMode)
 import Urbit.EventLog.LMDB    (EventLog)
 import Urbit.King.API         (TermConn)
 import Urbit.Noun.Time        (Wen)
-import Urbit.Vere.Behn        (behn')
+import Urbit.TermSize         (TermSize(..))
 import Urbit.Vere.Eyre.Multi  (MultiEyreApi)
 import Urbit.Vere.Serf        (Serf)
 
@@ -40,6 +39,7 @@ import qualified Urbit.EventLog.LMDB    as Log
 import qualified Urbit.King.API         as King
 import qualified Urbit.Noun.Time        as Time
 import qualified Urbit.Vere.Ames        as Ames
+import qualified Urbit.Vere.Behn        as Behn
 import qualified Urbit.Vere.Clay        as Clay
 import qualified Urbit.Vere.Eyre        as Eyre
 import qualified Urbit.Vere.Http.Client as Iris
@@ -47,7 +47,6 @@ import qualified Urbit.Vere.Serf        as Serf
 import qualified Urbit.Vere.Term        as Term
 import qualified Urbit.Vere.Term.API    as Term
 import qualified Urbit.Vere.Term.Demux  as Term
-import qualified Urbit.Vere.Term.Render as Term
 
 
 -- Initialize pier directory. --------------------------------------------------
@@ -254,6 +253,7 @@ acquireWorkerBound nam act = mkRAcquire (asyncBound act) kill
     cancel tid
 
 
+
 -- Run Pier --------------------------------------------------------------------
 
 pier
@@ -309,7 +309,7 @@ pier (serf, log) vSlog startedSig multi = do
   (bootEvents, startDrivers) <- do
     env <- ask
     let err = atomically . Term.trace muxed . (<> "\r\n")
-    let siz = Term.TSize { tsWide = 80, tsTall = 24 }
+    let siz = TermSize { tsWide = 80, tsTall = 24 }
     let fak = isFake logId
     drivers env multi ship fak compute (siz, muxed) err sigint
 
@@ -416,12 +416,12 @@ drivers
   -> Ship
   -> Bool
   -> (RunReq -> STM ())
-  -> (Term.TSize, Term.Client)
+  -> (TermSize, Term.Client)
   -> (Text -> RIO e ())
   -> IO ()
   -> RAcquire e ([Ev], RAcquire e Drivers)
 drivers env multi who isFake plan termSys stderr serfSIGINT = do
-  (behnBorn, runBehn) <- rio behn'
+  (behnBorn, runBehn) <- rio Behn.behn'
   (termBorn, runTerm) <- rio (Term.term' termSys serfSIGINT)
   (amesBorn, runAmes) <- rio (Ames.ames' who isFake stderr)
   (httpBorn, runEyre) <- rio (Eyre.eyre' multi who isFake)

pkg/hs/urbit-king/lib/Urbit/Vere/Term.hs

@@ -19,6 +19,7 @@ import RIO.FilePath
 import System.Posix.IO
 import System.Posix.Terminal
 import Urbit.Arvo            hiding (Term)
+import Urbit.King.App
 import Urbit.Noun.Time
 import Urbit.Prelude         hiding (getCurrentTime)
 import Urbit.Vere.Pier.Types
@@ -26,12 +27,13 @@ import Urbit.Vere.Pier.Types
 import Data.List           ((!!))
 import RIO.Directory       (createDirectoryIfMissing)
 import Urbit.King.API      (readPortsFile)
-import Urbit.King.App      (HasPierPath(..), HasPierEnv, killPierActionL)
+import Urbit.TermSize      (TermSize(TermSize))
 import Urbit.Vere.Term.API (Client(Client))
 
 import qualified Data.ByteString.Internal as BS
 import qualified Data.ByteString.UTF8     as BS
 import qualified System.Console.ANSI      as ANSI
+import qualified Urbit.TermSize           as T
 import qualified Urbit.Vere.NounServ      as Serv
 import qualified Urbit.Vere.Term.API      as Term
 import qualified Urbit.Vere.Term.Render   as T
@@ -172,10 +174,10 @@ _spin_idle_us = 500000
 -}
 localClient :: ∀e. HasLogFunc e
             => STM ()
-            -> RAcquire e (T.TSize, Client)
+            -> RAcquire e (TermSize, Client)
 localClient doneSignal = fst <$> mkRAcquire start stop
   where
-    start :: HasLogFunc e => RIO e ((T.TSize, Client), Private)
+    start :: HasLogFunc e => RIO e ((TermSize, Client), Private)
     start = do
       tsWriteQueue  <- newTQueueIO :: RIO e (TQueue [Term.Ev])
       spinnerMVar   <- newEmptyTMVarIO :: RIO e (TMVar ())
@@ -200,12 +202,12 @@ localClient doneSignal = fst <$> mkRAcquire start stop
                           , give = writeTQueue tsWriteQueue
                           }
 
-      tsize <- io $ T.tsize
+      tsize <- io $ T.termSize
 
       pure ((tsize, client), Private{..})
 
     stop :: HasLogFunc e
-         => ((T.TSize, Client), Private) -> RIO e ()
+         => ((TermSize, 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
@@ -510,11 +512,11 @@ localClient doneSignal = fst <$> mkRAcquire start stop
 -}
 term'
   :: HasPierEnv e
-  => (T.TSize, Client)
+  => (TermSize, Client)
   -> IO ()
   -> RIO e ([Ev], RAcquire e (DriverApi TermEf))
 term' (tsize, client) serfSIGINT = do
-  let T.TSize wi hi = tsize
+  let TermSize wi hi = tsize
       initEv = [initialBlew wi hi, initialHail]
 
   pure (initEv, runDriver)
@@ -533,7 +535,7 @@ term' (tsize, client) serfSIGINT = do
 -}
 term :: forall e. (HasPierEnv e)
      => e
-     -> (T.TSize, Client)
+     -> (TermSize, Client)
      -> (EvErr -> STM ())
      -> IO ()
      -> RAcquire e (TermEf -> IO ())

pkg/hs/urbit-king/lib/Urbit/Vere/Term/Render.hs

@@ -2,9 +2,7 @@
     Terminal Driver
 -}
 module Urbit.Vere.Term.Render
-    ( TSize(..)
+    ( clearScreen
-    , tsize
-    , clearScreen
     , clearLine
     , cursorRight
     , cursorLeft
@@ -13,29 +11,11 @@ module Urbit.Vere.Term.Render
 
 import ClassyPrelude
 
-import qualified System.Console.Terminal.Size as TSize
+import qualified System.Console.ANSI as ANSI
-import qualified System.Console.ANSI          as ANSI
 
 
 -- Types -----------------------------------------------------------------------
 
-data TSize = TSize
-    { tsWide ∷ Word
-    , tsTall ∷ Word
-    }
-
-
---------------------------------------------------------------------------------
-
-{- |
-    Get terminal size.  Produces 80x24 as a fallback if unable to figure
-    out terminal size.
--}
-tsize ∷ IO TSize
-tsize = do
-    TSize.Window wi hi <- TSize.size <&> fromMaybe (TSize.Window 80 24)
-    pure $ TSize { tsWide = wi, tsTall = hi }
-
 clearScreen ∷ MonadIO m ⇒ m ()
 clearScreen = liftIO $ ANSI.clearScreen
 

pkg/hs/urbit-king/package.yaml

@@ -89,7 +89,6 @@ dependencies:
   - tasty-th
   - template-haskell
   - terminal-progress-bar
-  - terminal-size
   - text
   - these
   - time
@@ -105,6 +104,7 @@ dependencies:
   - urbit-hob
   - urbit-noun
   - urbit-noun-core
+  - urbit-termsize
   - utf8-string
   - vector
   - wai

pkg/hs/urbit-termsize/.gitignore

@@ -0,0 +1,3 @@
+.stack-work/
+urbit-termsize.cabal
+*~

pkg/hs/urbit-termsize/LICENSE

@@ -0,0 +1,21 @@
+The MIT License (MIT)
+
+Copyright (c) 2016 urbit
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

pkg/hs/urbit-termsize/app/Main.hs

@@ -0,0 +1,13 @@
+module Main where
+
+import Prelude
+
+import Urbit.TermSize (liveTermSize)
+import System.IO (getLine)
+
+main :: IO ()
+main = do
+  init <- liveTermSize (putStrLn . ("New Size: " <>) . show)
+  putStrLn ("Initial Size: " <> show init)
+  _ <- getLine
+  pure ()

pkg/hs/urbit-termsize/lib/Urbit/TermSize.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE DeriveAnyClass  #-}
+{-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Urbit.TermSize
+  ( TermSize(..)
+  , termSize
+  , liveTermSize
+  )
+where
+
+import Prelude
+
+import Data.Functor                 ((<&>))
+import System.Console.Terminal.Size (Window(..), size)
+
+import qualified System.Posix.Signals      as Sys
+import qualified System.Posix.Signals.Exts as Sys
+
+
+-- Types -----------------------------------------------------------------------
+
+data TermSize = TermSize
+  { tsWide :: !Word
+  , tsTall :: !Word
+  }
+ deriving (Eq, Ord, Show)
+
+
+-- Utilities -------------------------------------------------------------------
+
+termSize :: IO TermSize
+termSize = size <&> \case
+  Nothing            -> TermSize 80 24
+  Just (Window {..}) -> TermSize width height
+
+liveTermSize :: (TermSize -> IO ()) -> IO TermSize
+liveTermSize cb = do
+  Sys.installHandler Sys.sigWINCH (Sys.Catch (termSize >>= cb)) Nothing
+  termSize

pkg/hs/urbit-termsize/package.yaml

@@ -0,0 +1,25 @@
+name: urbit-termsize
+version: 0.1.0
+license: MIT
+license-file: LICENSE
+
+dependencies:
+  - base
+  - terminal-size
+  - unix
+
+ghc-options:
+  - -fwarn-incomplete-patterns
+  - -fwarn-unused-binds
+  - -fwarn-unused-imports
+  - -O2
+
+library:
+  source-dirs: lib
+
+executables:
+  urbit-test-termsize-updates:
+    main: Main.hs
+    source-dirs: app
+    dependencies:
+      - urbit-termsize