From c4be3e4a19a12d2cc97e3e270e52aaa6573c7bb8 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Tue, 17 Sep 2019 21:41:31 -0700 Subject: [PATCH 01/11] Terminal loop cleanup. --- pkg/king/lib/Arvo/Event.hs | 40 ++++--- pkg/king/lib/Vere/Pier.hs | 12 +- pkg/king/lib/Vere/Term.hs | 237 +++++++++++++++++++++---------------- 3 files changed, 163 insertions(+), 126 deletions(-) diff --git a/pkg/king/lib/Arvo/Event.hs b/pkg/king/lib/Arvo/Event.hs index 51ffc2417d..385f1bdaa3 100644 --- a/pkg/king/lib/Arvo/Event.hs +++ b/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 - EvBlip b -> case b of - BlipEvAmes _ -> Just "ames" - BlipEvArvo _ -> Just "arvo" - BlipEvBehn _ -> Just "behn" - BlipEvBoat _ -> Just "boat" - BlipEvHttpClient _ -> Just "iris" - BlipEvHttpServer _ -> Just "eyre" - BlipEvNewt _ -> Just "newt" - BlipEvSync _ -> Just "clay" - BlipEvTerm t -> case t of - TermEvBelt _ belt -> case belt of - -- 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. - Ret () -> Nothing - _ -> Just "term" - _ -> Just "term" + EvVane _ -> Nothing + EvBlip b -> case b of + BlipEvAmes _ -> Just "ames" + BlipEvArvo _ -> Just "arvo" + BlipEvBehn _ -> Just "behn" + BlipEvBoat _ -> Just "boat" + BlipEvHttpClient _ -> Just "iris" + BlipEvHttpServer _ -> Just "eyre" + BlipEvNewt _ -> Just "newt" + BlipEvSync _ -> Just "clay" + BlipEvTerm t | isRet t -> Nothing + BlipEvTerm t -> Just "term" + where + isRet (TermEvBelt _ (Ret ())) = True + isRet _ = False diff --git a/pkg/king/lib/Vere/Pier.hs b/pkg/king/lib/Vere/Pier.hs index 8393b7b3ea..6778e54a34 100644 --- a/pkg/king/lib/Vere/Pier.hs +++ b/pkg/king/lib/Vere/Pier.hs @@ -161,9 +161,13 @@ pier pierPath mPort (serf, log, ss) = do tExe <- startDrivers >>= router (readTQueue executeQ) tDisk <- runPersist log persistQ (writeTQueue executeQ) - tCpu <- runCompute serf ss (readTQueue computeQ) (takeTMVar saveM) - (takeTMVar shutdownM) (tsShowSpinner terminalSystem) - (tsHideSpinner terminalSystem) (writeTQueue persistQ) + tCpu <- runCompute serf ss + (readTQueue computeQ) + (takeTMVar saveM) + (takeTMVar shutdownM) + (tsShowSpinner terminalSystem) + (tsHideSpinner terminalSystem) + (writeTQueue persistQ) tSaveSignal <- saveSignalThread saveM @@ -286,7 +290,7 @@ runCompute :: ∀e. HasLogFunc e -> STM Ev -> STM () -> STM () - -> (Maybe String -> STM ()) + -> (Maybe Text -> STM ()) -> STM () -> ((Job, FX) -> STM ()) -> RAcquire e (Async ()) diff --git a/pkg/king/lib/Vere/Term.hs b/pkg/king/lib/Vere/Term.hs index 998e299464..04be048588 100644 --- a/pkg/king/lib/Vere/Term.hs +++ b/pkg/king/lib/Vere/Term.hs @@ -1,43 +1,48 @@ module Vere.Term (initializeLocalTerminal, term, TerminalSystem(..)) where -import Arvo hiding (Term) -import Urbit.Time -import UrbitPrelude hiding (getCurrentTime) -import Vere.Pier.Types - +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 RIO.FilePath -import System.Console.Terminfo.Base +import Data.List ((!!)) +import RIO.Directory (createDirectoryIfMissing) -import Data.ByteString.Internal - -import qualified Data.ByteString as B -import qualified Data.ByteString.UTF8 as UTF8 +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.UTF8 as BS +import qualified System.Console.Terminfo.Base as T -- 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 +termText :: Text -> T.TermOutput +termText = T.termText . unpack + +{- + 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 DrvEv = DEBlits [Blit] + | DETrace Text + | DEBlank + | DESpinr (Maybe (Maybe Text)) -- 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 @@ -60,9 +65,9 @@ data ReadData = ReadData -- vere/arvo interface. data TerminalSystem e = TerminalSystem { tsReadQueue :: TQueue Belt - , tsWriteQueue :: TQueue VereOutput + , tsWriteQueue :: TQueue DrvEv , tsStderr :: Text -> RIO e () - , tsShowSpinner :: Maybe String -> STM () + , tsShowSpinner :: Maybe Text -> STM () , tsHideSpinner :: STM () } @@ -82,10 +87,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 = ['«'] -rightBracket = ['»'] +leftBracket :: Text +leftBracket = "«" + +rightBracket :: Text +rightBracket = "»" _spin_cool_us = 500000 _spin_warm_us = 50000 @@ -94,10 +103,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 @@ -125,7 +134,7 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop start = do -- Initialize the writing side of the terminal -- - t <- io $ setupTermFromEnv + t <- io $ T.setupTermFromEnv -- TODO: We still need to actually get the size from the terminal somehow. tsWriteQueue <- newTQueueIO @@ -147,11 +156,12 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop (readTerminal tsReadQueue tsWriteQueue (bell tsWriteQueue)) let tsStderr = \txt -> - atomically $ writeTQueue tsWriteQueue $ VerePrintOutput $ unpack txt + atomically $ writeTQueue tsWriteQueue $ DETrace txt - let tsShowSpinner = \str -> - writeTQueue tsWriteQueue $ VereShowSpinner str - let tsHideSpinner = writeTQueue tsWriteQueue $ VereHideSpinner + let tsShowSpinner = \mTxt -> + writeTQueue tsWriteQueue $ DESpinr (Just mTxt) + + let tsHideSpinner = writeTQueue tsWriteQueue $ DESpinr Nothing pure (TerminalSystem{..}, Private{..}) @@ -182,7 +192,7 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop ] 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" @@ -202,51 +212,52 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop threadDelay rest loop + writeTrace :: T.Terminal -> LineState -> Text -> RIO e LineState + writeTrace t ls p = do + io $ T.runTermOutput t $ termText "\r" + runMaybeTermOutput t vtClearToBegin + io $ T.runTermOutput t $ termText p + termRefreshLine t ls + -- 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 DrvEv -> TMVar () -> RIO e () writeTerminal t q spinner = do currentTime <- io $ now loop (LineState "" 0 Nothing Nothing True 0 currentTime) where - loop ls@LineState{..} = do - x <- atomically $ - Right <$> readTQueue q <|> - Left <$> takeTMVar spinner - 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 + writeBlank :: LineState -> RIO e LineState + writeBlank ls = do + io $ T.runTermOutput t $ termText "\r\n" + pure ls - spinTimer <- async $ spinnerHeartBeat delay _spin_rate_us spinner - loop ls { lsSpinTimer = Just spinTimer, - lsSpinCause = txt, - lsSpinFirstRender = True } - Right VereHideSpinner -> do - maybe (pure ()) cancel lsSpinTimer + {- + 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 = do + maybe (pure ()) cancel (lsSpinTimer ls) -- We do a final flush of the spinner mvar to ensure we don't -- have a lingering signal which will redisplay the spinner after -- we call termRefreshLine below. @@ -254,26 +265,46 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop -- If we ever actually ran the spinner display callback, we need -- to force a redisplay of the command prompt. - ls <- if not lsSpinFirstRender + ls <- if not (lsSpinFirstRender ls) then termRefreshLine t ls else pure ls endTime <- io $ now - loop ls { lsSpinTimer = Nothing, lsPrevEndTime = endTime } - Left () -> do - let spinner = [spinners !! lsSpinFrame] ++ case lsSpinCause of - Nothing -> [] - Just str -> leftBracket ++ str ++ rightBracket + pure $ ls { lsSpinTimer = Nothing, lsPrevEndTime = endTime } - io $ runTermOutput t $ termText spinner - termSpinnerMoveLeft t (length spinner) + execEv :: LineState -> DrvEv -> RIO e LineState + execEv ls = \case + DEBlits bs -> foldM (writeBlit t) ls bs + DETrace p -> writeTrace t ls p + DEBlank -> writeBlank ls + DESpinr (Just txt) -> doSpin ls txt + DESpinr Nothing -> unspin ls - loop ls { lsSpinFirstRender = False, - lsSpinFrame = (lsSpinFrame + 1) `mod` (length spinners) + + spin :: LineState -> RIO e LineState + 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@LineState{..} = do + join $ atomically $ asum + [ readTQueue q >>= pure . (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 runMaybeTermOutput t vtSoundBell @@ -293,7 +324,7 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop (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) @@ -307,30 +338,30 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop -- 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) @@ -339,8 +370,8 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop termShowCursor t ls curPos -- ring my bell - bell :: TQueue VereOutput -> RIO e () - bell q = atomically $ writeTQueue q $ VereBlitOutput [Bel ()] + bell :: TQueue DrvEv -> RIO e () + bell q = atomically $ writeTQueue q $ DEBlits [Bel ()] -- Reads data from stdInput and emit the proper effect -- @@ -351,9 +382,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 DrvEv -> (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 @@ -370,7 +401,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 @@ -399,13 +430,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 @@ -422,11 +453,11 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop -- ETX (^C) logDebug $ displayShow "Ctrl-c interrupt" atomically $ do - writeTQueue wq $ VerePrintOutput "interrupt\r\n" + writeTQueue wq $ DETrace "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 } @@ -473,7 +504,7 @@ term TerminalSystem{..} shutdownSTM pierPath king enqueueEv = handleEffect = \case TermEfBlit _ blits -> do let (termBlits, fsWrites) = partition isTerminalBlit blits - atomically $ writeTQueue tsWriteQueue (VereBlitOutput termBlits) + atomically $ writeTQueue tsWriteQueue (DEBlits termBlits) for_ fsWrites handleFsWrite TermEfInit _ _ -> pure () TermEfLogo path _ -> do From 99dd161b864d1c40c07894c15eb9cae4bc2966da Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Tue, 17 Sep 2019 22:01:44 -0700 Subject: [PATCH 02/11] Simplify term interface. --- pkg/king/lib/Vere/Pier.hs | 4 +- pkg/king/lib/Vere/Term.hs | 88 ++++++++++++++++++++++----------------- 2 files changed, 52 insertions(+), 40 deletions(-) diff --git a/pkg/king/lib/Vere/Pier.hs b/pkg/king/lib/Vere/Pier.hs index 6778e54a34..aa3a96545d 100644 --- a/pkg/king/lib/Vere/Pier.hs +++ b/pkg/king/lib/Vere/Pier.hs @@ -149,7 +149,7 @@ pier pierPath mPort (serf, log, ss) = do inst <- io (KingId . UV . fromIntegral <$> randomIO @Word16) terminalSystem <- initializeLocalTerminal - swapMVar (sStderr serf) (tsStderr terminalSystem) + swapMVar (sStderr serf) (atomically . tsStderr terminalSystem) let ship = who (Log.identity log) @@ -209,7 +209,7 @@ data Drivers e = Drivers drivers :: HasLogFunc e => FilePath -> KingId -> Ship -> Maybe Port -> (Ev -> STM ()) -> STM() - -> TerminalSystem e + -> TerminalSystem -> ([Ev], RAcquire e (Drivers e)) drivers pierPath inst who mPort plan shutdownSTM termSys = (initialEvents, runDrivers) diff --git a/pkg/king/lib/Vere/Term.hs b/pkg/king/lib/Vere/Term.hs index 04be048588..b0fe307b9f 100644 --- a/pkg/king/lib/Vere/Term.hs +++ b/pkg/king/lib/Vere/Term.hs @@ -1,4 +1,11 @@ -module Vere.Term (initializeLocalTerminal, term, TerminalSystem(..)) where +module Vere.Term + ( TerminalSystem(..) + , initializeLocalTerminal + , term + , tsHideSpinner + , tsShowSpinner + , tsStderr + ) where import Arvo hiding (Term) import Data.Char @@ -19,10 +26,7 @@ import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.UTF8 as BS import qualified System.Console.Terminfo.Base as T --- Types ----------------------------------------------------------------------- - -termText :: Text -> T.TermOutput -termText = T.termText . unpack +-- External Types -------------------------------------------------------------- {- Input Event for terminal driver: @@ -37,6 +41,32 @@ data DrvEv = DEBlits [Blit] | DEBlank | DESpinr (Maybe (Maybe Text)) +{- + Minimal terminal interface. + + 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 = TerminalSystem + { tsRead :: STM Belt + , tsWrite :: DrvEv -> STM () + } + +tsStderr :: TerminalSystem -> Text -> STM () +tsStderr ts = tsWrite ts . DETrace + +tsShowSpinner :: TerminalSystem -> Maybe Text -> STM () +tsShowSpinner ts = tsWrite ts . DESpinr . Just + +tsHideSpinner :: TerminalSystem -> STM () +tsHideSpinner ts = tsWrite ts (DESpinr Nothing) + + + +-- Types ----------------------------------------------------------------------- + -- All stateful data in the printing to stdOutput. data LineState = LineState { lsLine :: Text @@ -57,20 +87,6 @@ data ReadData = ReadData , rdUTF8width :: Int } --- Minimal terminal interface. --- --- 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 DrvEv - , tsStderr :: Text -> RIO e () - , tsShowSpinner :: Maybe Text -> STM () - , tsHideSpinner :: STM () - } - -- Private data to the TerminalSystem that we keep around for stop(). data Private = Private { pReaderThread :: Async () @@ -80,6 +96,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, ()) () @@ -127,10 +146,10 @@ isTerminalBlit _ = True -- Initializes the generalized input/output parts of the terminal. -- initializeLocalTerminal :: forall e. HasLogFunc e - => RAcquire e (TerminalSystem e) + => RAcquire e TerminalSystem initializeLocalTerminal = fst <$> mkRAcquire start stop where - start :: HasLogFunc e => RIO e (TerminalSystem e, Private) + start :: HasLogFunc e => RIO e (TerminalSystem, Private) start = do -- Initialize the writing side of the terminal -- @@ -155,18 +174,13 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop pReaderThread <- asyncBound (readTerminal tsReadQueue tsWriteQueue (bell tsWriteQueue)) - let tsStderr = \txt -> - atomically $ writeTQueue tsWriteQueue $ DETrace txt - - let tsShowSpinner = \mTxt -> - writeTQueue tsWriteQueue $ DESpinr (Just mTxt) - - let tsHideSpinner = writeTQueue tsWriteQueue $ DESpinr Nothing + let tsRead = readTQueue tsReadQueue + tsWrite = writeTQueue tsWriteQueue pure (TerminalSystem{..}, Private{..}) stop :: HasLogFunc e - => (TerminalSystem e, Private) -> RIO e () + => (TerminalSystem, Private) -> RIO e () stop (TerminalSystem{..}, 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 @@ -256,8 +270,8 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop } unspin :: LineState -> RIO e LineState - unspin ls = do - maybe (pure ()) cancel (lsSpinTimer ls) + 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 -- we call termRefreshLine below. @@ -265,7 +279,7 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop -- If we ever actually ran the spinner display callback, we need -- to force a redisplay of the command prompt. - ls <- if not (lsSpinFirstRender ls) + ls <- if not lsSpinFirstRender then termRefreshLine t ls else pure ls @@ -280,7 +294,6 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop DESpinr (Just txt) -> doSpin ls txt DESpinr Nothing -> unspin ls - spin :: LineState -> RIO e LineState spin ls@LineState{..} = do let spinner = (spinners !! lsSpinFrame) ++ case lsSpinCause of @@ -297,7 +310,7 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop } loop :: LineState -> RIO e () - loop ls@LineState{..} = do + loop ls = do join $ atomically $ asum [ readTQueue q >>= pure . (execEv ls >=> loop) , takeTMVar spinner >> pure (spin ls >>= loop) @@ -335,7 +348,6 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop else pure ls - -- Moves the cursor left without any mutation of the LineState. Used only -- in cursor spinning. termSpinnerMoveLeft :: T.Terminal -> Int -> RIO e () @@ -476,7 +488,7 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop -------------------------------------------------------------------------------- term :: forall e. HasLogFunc e - => TerminalSystem e -> (STM ()) -> FilePath -> KingId -> QueueEv + => TerminalSystem -> (STM ()) -> FilePath -> KingId -> QueueEv -> ([Ev], RAcquire e (EffCb e TermEf)) term TerminalSystem{..} shutdownSTM pierPath king enqueueEv = (initialEvents, runTerm) @@ -496,7 +508,7 @@ term TerminalSystem{..} shutdownSTM pierPath king enqueueEv = readBelt :: RIO e () readBelt = forever $ do - b <- atomically $ readTQueue tsReadQueue + b <- atomically tsRead let blip = EvBlip $ BlipEvTerm $ TermEvBelt (UD 1, ()) $ b atomically $ enqueueEv $ blip @@ -504,7 +516,7 @@ term TerminalSystem{..} shutdownSTM pierPath king enqueueEv = handleEffect = \case TermEfBlit _ blits -> do let (termBlits, fsWrites) = partition isTerminalBlit blits - atomically $ writeTQueue tsWriteQueue (DEBlits termBlits) + atomically $ tsWrite (DEBlits termBlits) for_ fsWrites handleFsWrite TermEfInit _ _ -> pure () TermEfLogo path _ -> do From 4fdfab66df9bec999c66d9470b8cdec48b002049 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Tue, 17 Sep 2019 22:06:40 -0700 Subject: [PATCH 03/11] Minor --- pkg/king/lib/Vere/Term.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/pkg/king/lib/Vere/Term.hs b/pkg/king/lib/Vere/Term.hs index b0fe307b9f..c1b4fd5eef 100644 --- a/pkg/king/lib/Vere/Term.hs +++ b/pkg/king/lib/Vere/Term.hs @@ -226,13 +226,6 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop threadDelay rest loop - writeTrace :: T.Terminal -> LineState -> Text -> RIO e LineState - writeTrace t ls p = do - io $ T.runTermOutput t $ termText "\r" - runMaybeTermOutput t vtClearToBegin - io $ T.runTermOutput t $ termText p - termRefreshLine t ls - -- Writes data to the terminal. Both the terminal reading, normal logging, -- and effect handling can all emit bytes which go to the terminal. writeTerminal :: T.Terminal -> TQueue DrvEv -> TMVar () -> RIO e () @@ -245,6 +238,13 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop io $ T.runTermOutput t $ termText "\r\n" pure ls + writeTrace :: LineState -> Text -> RIO e LineState + writeTrace ls p = do + io $ T.runTermOutput t $ termText "\r" + runMaybeTermOutput t vtClearToBegin + 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 @@ -289,7 +289,7 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop execEv :: LineState -> DrvEv -> RIO e LineState execEv ls = \case DEBlits bs -> foldM (writeBlit t) ls bs - DETrace p -> writeTrace t ls p + DETrace p -> writeTrace ls p DEBlank -> writeBlank ls DESpinr (Just txt) -> doSpin ls txt DESpinr Nothing -> unspin ls From ebf3d3e5c65e7997f78678971146a08b26145fd8 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Tue, 17 Sep 2019 22:22:19 -0700 Subject: [PATCH 04/11] Move terminal client API into it's own module. --- pkg/king/lib/Vere/Pier.hs | 19 ++++---- pkg/king/lib/Vere/Term.hs | 92 ++++++++++------------------------- pkg/king/lib/Vere/Term/API.hs | 38 +++++++++++++++ 3 files changed, 75 insertions(+), 74 deletions(-) create mode 100644 pkg/king/lib/Vere/Term/API.hs diff --git a/pkg/king/lib/Vere/Pier.hs b/pkg/king/lib/Vere/Pier.hs index aa3a96545d..c69883fb5b 100644 --- a/pkg/king/lib/Vere/Pier.hs +++ b/pkg/king/lib/Vere/Pier.hs @@ -26,6 +26,7 @@ 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 -------------------------------------------------------------------------------- @@ -138,18 +139,18 @@ pier :: ∀e. HasLogFunc e -> (Serf e, EventLog, SerfState) -> RAcquire e () pier pierPath mPort (serf, log, ss) = do - computeQ <- newTQueueIO :: RAcquire e (TQueue Ev) - persistQ <- newTQueueIO :: RAcquire e (TQueue (Job, FX)) - executeQ <- newTQueueIO :: RAcquire e (TQueue FX) + computeQ <- newTQueueIO + persistQ <- newTQueueIO + 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 - swapMVar (sStderr serf) (atomically . tsStderr terminalSystem) + swapMVar (sStderr serf) (atomically . Term.trace terminalSystem) let ship = who (Log.identity log) @@ -165,8 +166,8 @@ pier pierPath mPort (serf, log, ss) = do (readTQueue computeQ) (takeTMVar saveM) (takeTMVar shutdownM) - (tsShowSpinner terminalSystem) - (tsHideSpinner terminalSystem) + (Term.spin terminalSystem) + (Term.stopSpin terminalSystem) (writeTQueue persistQ) tSaveSignal <- saveSignalThread saveM @@ -209,7 +210,7 @@ data Drivers e = Drivers drivers :: HasLogFunc e => FilePath -> KingId -> Ship -> Maybe Port -> (Ev -> STM ()) -> STM() - -> TerminalSystem + -> Term.Client -> ([Ev], RAcquire e (Drivers e)) drivers pierPath inst who mPort plan shutdownSTM termSys = (initialEvents, runDrivers) diff --git a/pkg/king/lib/Vere/Term.hs b/pkg/king/lib/Vere/Term.hs index c1b4fd5eef..e6201e16aa 100644 --- a/pkg/king/lib/Vere/Term.hs +++ b/pkg/king/lib/Vere/Term.hs @@ -1,10 +1,7 @@ module Vere.Term - ( TerminalSystem(..) + ( module Term , initializeLocalTerminal , term - , tsHideSpinner - , tsShowSpinner - , tsStderr ) where import Arvo hiding (Term) @@ -21,48 +18,12 @@ import Vere.Pier.Types import Data.List ((!!)) import RIO.Directory (createDirectoryIfMissing) +import Vere.Term.API (Client(Client)) import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.UTF8 as BS import qualified System.Console.Terminfo.Base as T - --- 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 DrvEv = DEBlits [Blit] - | DETrace Text - | DEBlank - | DESpinr (Maybe (Maybe Text)) - -{- - Minimal terminal interface. - - 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 = TerminalSystem - { tsRead :: STM Belt - , tsWrite :: DrvEv -> STM () - } - -tsStderr :: TerminalSystem -> Text -> STM () -tsStderr ts = tsWrite ts . DETrace - -tsShowSpinner :: TerminalSystem -> Maybe Text -> STM () -tsShowSpinner ts = tsWrite ts . DESpinr . Just - -tsHideSpinner :: TerminalSystem -> STM () -tsHideSpinner ts = tsWrite ts (DESpinr Nothing) - +import qualified Vere.Term.API as Term -- Types ----------------------------------------------------------------------- @@ -87,7 +48,7 @@ data ReadData = ReadData , rdUTF8width :: Int } --- Private data to the TerminalSystem that we keep around for stop(). +-- Private data to the Client that we keep around for stop(). data Private = Private { pReaderThread :: Async () , pWriterThread :: Async () @@ -146,10 +107,10 @@ isTerminalBlit _ = True -- Initializes the generalized input/output parts of the terminal. -- initializeLocalTerminal :: forall e. HasLogFunc e - => RAcquire e TerminalSystem + => RAcquire e Client initializeLocalTerminal = fst <$> mkRAcquire start stop where - start :: HasLogFunc e => RIO e (TerminalSystem, Private) + start :: HasLogFunc e => RIO e (Client, Private) start = do -- Initialize the writing side of the terminal -- @@ -174,14 +135,15 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop pReaderThread <- asyncBound (readTerminal tsReadQueue tsWriteQueue (bell tsWriteQueue)) - let tsRead = readTQueue tsReadQueue - tsWrite = writeTQueue tsWriteQueue + let client = Client { take = readTQueue tsReadQueue + , give = writeTQueue tsWriteQueue + } - pure (TerminalSystem{..}, Private{..}) + pure (client, Private{..}) stop :: HasLogFunc e - => (TerminalSystem, Private) -> RIO e () - stop (TerminalSystem{..}, 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 @@ -228,7 +190,7 @@ 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 :: T.Terminal -> TQueue DrvEv -> 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) @@ -286,13 +248,13 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop endTime <- io $ now pure $ ls { lsSpinTimer = Nothing, lsPrevEndTime = endTime } - execEv :: LineState -> DrvEv -> RIO e LineState + execEv :: LineState -> Term.Ev -> RIO e LineState execEv ls = \case - DEBlits bs -> foldM (writeBlit t) ls bs - DETrace p -> writeTrace ls p - DEBlank -> writeBlank ls - DESpinr (Just txt) -> doSpin ls txt - DESpinr Nothing -> unspin ls + Term.Blits bs -> foldM (writeBlit t) ls bs + Term.Trace p -> writeTrace ls p + Term.Blank -> writeBlank ls + Term.Spinr (Just txt) -> doSpin ls txt + Term.Spinr Nothing -> unspin ls spin :: LineState -> RIO e LineState spin ls@LineState{..} = do @@ -382,8 +344,8 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop termShowCursor t ls curPos -- ring my bell - bell :: TQueue DrvEv -> RIO e () - bell q = atomically $ writeTQueue q $ DEBlits [Bel ()] + bell :: TQueue Term.Ev -> RIO e () + bell q = atomically $ writeTQueue q $ Term.Blits [Bel ()] -- Reads data from stdInput and emit the proper effect -- @@ -394,7 +356,7 @@ 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 DrvEv -> (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 mempty 0) where @@ -465,7 +427,7 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop -- ETX (^C) logDebug $ displayShow "Ctrl-c interrupt" atomically $ do - writeTQueue wq $ DETrace "interrupt\r\n" + writeTQueue wq $ Term.Trace "interrupt\r\n" writeTQueue rq $ Ctl $ Cord "c" loop rd else if w <= 26 then do @@ -488,9 +450,9 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop -------------------------------------------------------------------------------- term :: forall e. HasLogFunc e - => TerminalSystem -> (STM ()) -> FilePath -> KingId -> QueueEv + => Client -> (STM ()) -> FilePath -> KingId -> QueueEv -> ([Ev], RAcquire e (EffCb e TermEf)) -term TerminalSystem{..} shutdownSTM pierPath king enqueueEv = +term Client{..} shutdownSTM pierPath king enqueueEv = (initialEvents, runTerm) where initialEvents = [(initialBlew 80 24), initialHail] @@ -508,7 +470,7 @@ term TerminalSystem{..} shutdownSTM pierPath king enqueueEv = readBelt :: RIO e () readBelt = forever $ do - b <- atomically tsRead + b <- atomically take let blip = EvBlip $ BlipEvTerm $ TermEvBelt (UD 1, ()) $ b atomically $ enqueueEv $ blip @@ -516,7 +478,7 @@ term TerminalSystem{..} shutdownSTM pierPath king enqueueEv = handleEffect = \case TermEfBlit _ blits -> do let (termBlits, fsWrites) = partition isTerminalBlit blits - atomically $ tsWrite (DEBlits termBlits) + atomically $ give (Term.Blits termBlits) for_ fsWrites handleFsWrite TermEfInit _ _ -> pure () TermEfLogo path _ -> do diff --git a/pkg/king/lib/Vere/Term/API.hs b/pkg/king/lib/Vere/Term/API.hs new file mode 100644 index 0000000000..9f4fd3fc7f --- /dev/null +++ b/pkg/king/lib/Vere/Term/API.hs @@ -0,0 +1,38 @@ +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 Text + | Blank + | Spinr (Maybe (Maybe Text)) + +data Client = Client + { take :: STM Belt + , give :: Ev -> STM () + } + + +-- Utilities ------------------------------------------------------------------- + +trace :: Client -> Text -> STM () +trace ts = give ts . Trace + +spin :: Client -> Maybe Text -> STM () +spin ts = give ts . Spinr . Just + +stopSpin :: Client -> STM () +stopSpin ts = give ts (Spinr Nothing) From cd07b109469a22f14ddc4b81a4a98d93ab342c88 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Tue, 17 Sep 2019 23:17:54 -0700 Subject: [PATCH 05/11] Impement basic support for multiple terminals pretending to be one terminal. --- pkg/king/lib/Vere/Pier.hs | 35 ++++++++++------- pkg/king/lib/Vere/Term.hs | 69 +++++++++++++++++---------------- pkg/king/lib/Vere/Term/Demux.hs | 48 +++++++++++++++++++++++ 3 files changed, 105 insertions(+), 47 deletions(-) create mode 100644 pkg/king/lib/Vere/Term/Demux.hs diff --git a/pkg/king/lib/Vere/Pier.hs b/pkg/king/lib/Vere/Pier.hs index c69883fb5b..65d42d73cb 100644 --- a/pkg/king/lib/Vere/Pier.hs +++ b/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 diff --git a/pkg/king/lib/Vere/Term.hs b/pkg/king/lib/Vere/Term.hs index e6201e16aa..1e35a4906b 100644 --- a/pkg/king/lib/Vere/Term.hs +++ b/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 diff --git a/pkg/king/lib/Vere/Term/Demux.hs b/pkg/king/lib/Vere/Term/Demux.hs new file mode 100644 index 0000000000..c1288b015d --- /dev/null +++ b/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) From 09b30bf16968982223cbb9385e12bf6a0e09b25c Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Tue, 17 Sep 2019 23:58:42 -0700 Subject: [PATCH 06/11] Collect terminal size. --- pkg/king/lib/Vere/Pier.hs | 21 +++++++------- pkg/king/lib/Vere/Term.hs | 52 ++++++++++++++++++++++++++++------- pkg/king/lib/Vere/Term/API.hs | 11 +++++--- pkg/king/package.yaml | 3 +- 4 files changed, 62 insertions(+), 25 deletions(-) diff --git a/pkg/king/lib/Vere/Pier.hs b/pkg/king/lib/Vere/Pier.hs index 65d42d73cb..b94766e151 100644 --- a/pkg/king/lib/Vere/Pier.hs +++ b/pkg/king/lib/Vere/Pier.hs @@ -21,13 +21,14 @@ import Vere.Serf (Serf, SerfState(..), doJob, sStderr) 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 as Term -import qualified Vere.Term.API as Term -import qualified Vere.Term.Demux as Term +import qualified System.Console.Terminal.Size as TSize +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 -------------------------------------------------------------------------------- @@ -150,7 +151,7 @@ pier pierPath mPort (serf, log, ss) = do inst <- io (KingId . UV . fromIntegral <$> randomIO @Word16) - local <- Term.localClient + (sz, local) <- Term.localClient muxed <- atomically $ do res <- Term.mkDemux @@ -165,7 +166,7 @@ pier pierPath mPort (serf, log, ss) = do drivers pierPath inst ship mPort (writeTQueue computeQ) shutdownEvent - muxed + (sz, muxed) io $ atomically $ for_ bootEvents (writeTQueue computeQ) @@ -219,7 +220,7 @@ data Drivers e = Drivers drivers :: HasLogFunc e => FilePath -> KingId -> Ship -> Maybe Port -> (Ev -> STM ()) -> STM() - -> Term.Client + -> (TSize.Window Word, Term.Client) -> ([Ev], RAcquire e (Drivers e)) drivers pierPath inst who mPort plan shutdownSTM termSys = (initialEvents, runDrivers) diff --git a/pkg/king/lib/Vere/Term.hs b/pkg/king/lib/Vere/Term.hs index 1e35a4906b..9cb4e1fa63 100644 --- a/pkg/king/lib/Vere/Term.hs +++ b/pkg/king/lib/Vere/Term.hs @@ -1,6 +1,7 @@ module Vere.Term ( module Term , localClient + , termServer , term ) where @@ -22,10 +23,15 @@ import Vere.Term.API (Client(Client)) 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 + + + -- Types ----------------------------------------------------------------------- -- All stateful data in the printing to stdOutput. @@ -104,13 +110,31 @@ isTerminalBlit _ = True -------------------------------------------------------------------------------- +termServer :: ∀e. HasLogFunc e + => RAcquire e (TChan Client, Port) +termServer = mkRAcquire start stop + where + stop = const (pure ()) + start = do + serv <- Serv.wsServer @Belt @Term.Ev + chan <- newTChanIO + pure (chan, 0) + +{- +data Server i o a = Server + { sAccept :: STM (Maybe (Conn i o)) + , sAsync :: Async () + , sData :: a + } +-} + {- Initializes the generalized input/output parts of the terminal. -} -localClient :: ∀e. HasLogFunc e => RAcquire e Client +localClient :: ∀e. HasLogFunc e => RAcquire e (TSize.Window Word, Client) localClient = fst <$> mkRAcquire start stop where - start :: HasLogFunc e => RIO e (Client, Private) + start :: HasLogFunc e => RIO e ((TSize.Window Word, Client), Private) start = do -- Initialize the writing side of the terminal -- @@ -139,11 +163,13 @@ localClient = fst <$> mkRAcquire start stop , give = writeTQueue tsWriteQueue } - pure (client, Private{..}) + tsize <- io $ TSize.size <&> fromMaybe (TSize.Window 80 24) + + pure ((tsize, client), Private{..}) stop :: HasLogFunc e - => (Client, Private) -> RIO e () - stop (Client{..}, Private{..}) = do + => ((TSize.Window Word, 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 @@ -257,9 +283,9 @@ localClient = fst <$> mkRAcquire start stop execEv :: LineState -> Term.Ev -> RIO e LineState execEv ls = \case Term.Blits bs -> foldM (writeBlit t) ls bs - Term.Trace p -> writeTrace ls p + Term.Trace p -> writeTrace ls (unCord p) Term.Blank -> writeBlank ls - Term.Spinr (Just txt) -> doSpin ls txt + Term.Spinr (Just txt) -> doSpin ls (unCord <$> txt) Term.Spinr Nothing -> unspin ls spin :: LineState -> RIO e LineState @@ -451,12 +477,18 @@ localClient = fst <$> mkRAcquire start stop -------------------------------------------------------------------------------- term :: forall e. HasLogFunc e - => Client -> (STM ()) -> FilePath -> KingId -> QueueEv + => (TSize.Window Word, Client) + -> (STM ()) + -> FilePath + -> KingId + -> QueueEv -> ([Ev], RAcquire e (EffCb e TermEf)) -term Client{..} 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 diff --git a/pkg/king/lib/Vere/Term/API.hs b/pkg/king/lib/Vere/Term/API.hs index 9f4fd3fc7f..20998aa4ba 100644 --- a/pkg/king/lib/Vere/Term/API.hs +++ b/pkg/king/lib/Vere/Term/API.hs @@ -16,23 +16,26 @@ import Arvo (Blit, Belt) %spinr -- Start or stop the spinner -} data Ev = Blits [Blit] - | Trace Text + | Trace Cord | Blank - | Spinr (Maybe (Maybe Text)) + | 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 . Trace +trace ts = give ts . Trace . Cord spin :: Client -> Maybe Text -> STM () -spin ts = give ts . Spinr . Just +spin ts = give ts . Spinr . Just . fmap Cord stopSpin :: Client -> STM () stopSpin ts = give ts (Spinr Nothing) diff --git a/pkg/king/package.yaml b/pkg/king/package.yaml index 2783a0f98e..d20954366e 100644 --- a/pkg/king/package.yaml +++ b/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 From 4c3342f9c6379371e36857f7a4317d20a0fd1f5f Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Tue, 17 Sep 2019 23:59:07 -0700 Subject: [PATCH 07/11] External terminals get added to the demuxed terminal set. --- pkg/king/lib/Vere/Pier.hs | 24 +++++++++++++++++++-- pkg/king/lib/Vere/Term.hs | 45 +++++++++++++++++++++------------------ 2 files changed, 46 insertions(+), 23 deletions(-) diff --git a/pkg/king/lib/Vere/Pier.hs b/pkg/king/lib/Vere/Pier.hs index b94766e151..79f4b2423d 100644 --- a/pkg/king/lib/Vere/Pier.hs +++ b/pkg/king/lib/Vere/Pier.hs @@ -135,6 +135,12 @@ resumed top flags = do -- Run Pier -------------------------------------------------------------------- +acquireWorker :: RIO e () -> RAcquire e (Async ()) +acquireWorker act = mkRAcquire start stop + where + stop t = cancel t >> void (waitCatch t) + start = async act + pier :: ∀e. HasLogFunc e => FilePath -> Maybe Port @@ -153,10 +159,24 @@ pier pierPath mPort (serf, log, ss) = do (sz, local) <- Term.localClient - muxed <- atomically $ do + (waitExternalTerm, termServPort) <- Term.termServer + + (demux, muxed) <- atomically $ do res <- Term.mkDemux Term.addDemux local res - pure (Term.useDemux res) + pure (res, Term.useDemux res) + + rio $ logInfo $ display $ + "Terminal Server running on port: " <> tshow termServPort + + let listenLoop = do + ok <- atomically $ do + waitExternalTerm >>= \case + Nothing -> pure False + Just ext -> Term.addDemux ext demux >> pure True + when ok listenLoop + + acquireWorker listenLoop swapMVar (sStderr serf) (atomically . Term.trace muxed) diff --git a/pkg/king/lib/Vere/Term.hs b/pkg/king/lib/Vere/Term.hs index 9cb4e1fa63..0522625302 100644 --- a/pkg/king/lib/Vere/Term.hs +++ b/pkg/king/lib/Vere/Term.hs @@ -110,23 +110,29 @@ isTerminalBlit _ = True -------------------------------------------------------------------------------- +{- + TODO XX HACK: We don't have any good way of handling client + disconnect, so we just retry. This will probably waste CPU. +-} termServer :: ∀e. HasLogFunc e - => RAcquire e (TChan Client, Port) + => RAcquire e (STM (Maybe Client), Port) termServer = mkRAcquire start stop where stop = const (pure ()) start = do serv <- Serv.wsServer @Belt @Term.Ev - chan <- newTChanIO - pure (chan, 0) -{- -data Server i o a = Server - { sAccept :: STM (Maybe (Conn i o)) - , sAsync :: Async () - , sData :: a - } --} + let getClient = do + 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) {- Initializes the generalized input/output parts of the terminal. @@ -136,23 +142,20 @@ localClient = fst <$> mkRAcquire start stop where start :: HasLogFunc e => RIO e ((TSize.Window Word, Client), Private) start = do - -- Initialize the writing side of the terminal - -- - t <- io $ T.setupTermFromEnv - -- TODO: We still need to actually get the size from the terminal somehow. - - tsWriteQueue <- newTQueueIO - spinnerMVar <- newEmptyTMVarIO + t <- io $ T.setupTermFromEnv + tsWriteQueue <- newTQueueIO + spinnerMVar <- newEmptyTMVarIO pWriterThread <- asyncBound (writeTerminal t 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 = - flip withTime 0 . - flip withMinInput 1 $ - foldl' withoutMode pPreviousConfiguration disabledFlags + let newTermSettings = flip withTime 0 + $ flip withMinInput 1 + $ foldl' withoutMode pPreviousConfiguration + $ disabledFlags + io $ setTerminalAttributes stdInput newTermSettings Immediately tsReadQueue <- newTQueueIO From 24bc28e8341ad0650471ee4a6576896b755415b4 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Wed, 18 Sep 2019 00:24:10 -0700 Subject: [PATCH 08/11] Hooked up a remote terminal, it runs but doesn't work yet. --- pkg/king/app/CLI.hs | 11 +++++++++++ pkg/king/app/Main.hs | 10 ++++++++++ pkg/king/lib/Vere/Term.hs | 41 +++++++++++++++++++++++++++++++++------ 3 files changed, 56 insertions(+), 6 deletions(-) diff --git a/pkg/king/app/CLI.hs b/pkg/king/app/CLI.hs index 074089fb5c..5d9547df50 100644 --- a/pkg/king/app/CLI.hs +++ b/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." + ) diff --git a/pkg/king/app/Main.hs b/pkg/king/app/Main.hs index 0136fdcfa3..71c2ed788d 100644 --- a/pkg/king/app/Main.hs +++ b/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,15 @@ 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) + -------------------------------------------------------------------------------- diff --git a/pkg/king/lib/Vere/Term.hs b/pkg/king/lib/Vere/Term.hs index 0522625302..341f8fa10f 100644 --- a/pkg/king/lib/Vere/Term.hs +++ b/pkg/king/lib/Vere/Term.hs @@ -1,6 +1,8 @@ module Vere.Term ( module Term , localClient + , connectToRemote + , runTerminalClient , termServer , term ) where @@ -29,9 +31,6 @@ import qualified Vere.NounServ as Serv import qualified Vere.Term.API as Term - - - -- Types ----------------------------------------------------------------------- -- All stateful data in the printing to stdOutput. @@ -116,9 +115,9 @@ isTerminalBlit _ = True -} termServer :: ∀e. HasLogFunc e => RAcquire e (STM (Maybe Client), Port) -termServer = mkRAcquire start stop +termServer = fst <$> mkRAcquire start stop where - stop = const (pure ()) + stop = cancel . snd start = do serv <- Serv.wsServer @Belt @Term.Ev @@ -132,7 +131,37 @@ termServer = mkRAcquire start stop Just ev -> pure ev } - pure (getClient, Port $ fromIntegral $ Serv.sData serv) + 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. From 6b8e88fdd860dc8b4237b7998faf499fa1d4295c Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Wed, 18 Sep 2019 01:08:13 -0700 Subject: [PATCH 09/11] Was replaying terminal events in the wrong order. --- pkg/king/lib/Vere/Term/Demux.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pkg/king/lib/Vere/Term/Demux.hs b/pkg/king/lib/Vere/Term/Demux.hs index c1288b015d..238260d9ad 100644 --- a/pkg/king/lib/Vere/Term/Demux.hs +++ b/pkg/king/lib/Vere/Term/Demux.hs @@ -26,7 +26,7 @@ mkDemux = Demux <$> newTVar [] <*> newTVar [] addDemux :: Client -> Demux -> STM () addDemux conn Demux{..} = do - stash <- readTVar dStash + stash <- reverse <$> readTVar dStash modifyTVar' dConns (conn:) for_ stash (Term.give conn) From b1a9dff197b1e2a00d17a37ce009eb7567142de7 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Wed, 18 Sep 2019 02:11:18 -0700 Subject: [PATCH 10/11] Fixes live-lock by changing type of Vere.Term.API.Client.give to take [Term.Ev]. --- pkg/king/app/Main.hs | 1 - pkg/king/lib/Vere/NounServ.hs | 15 +++++++++------ pkg/king/lib/Vere/Pier.hs | 10 +++++++--- pkg/king/lib/Vere/Term.hs | 16 ++++++++-------- pkg/king/lib/Vere/Term/API.hs | 8 ++++---- pkg/king/lib/Vere/Term/Demux.hs | 10 ++++++---- 6 files changed, 34 insertions(+), 26 deletions(-) diff --git a/pkg/king/app/Main.hs b/pkg/king/app/Main.hs index 71c2ed788d..d45fa6aa46 100644 --- a/pkg/king/app/Main.hs +++ b/pkg/king/app/Main.hs @@ -351,7 +351,6 @@ connTerm :: ∀e. HasLogFunc e => Word16 -> RIO e () connTerm port = Term.runTerminalClient (fromIntegral port) - -------------------------------------------------------------------------------- checkFx :: HasLogFunc e diff --git a/pkg/king/lib/Vere/NounServ.hs b/pkg/king/lib/Vere/NounServ.hs index f0b112d021..d8cbbc68c9 100644 --- a/pkg/king/lib/Vere/NounServ.hs +++ b/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 diff --git a/pkg/king/lib/Vere/Pier.hs b/pkg/king/lib/Vere/Pier.hs index 79f4b2423d..db7916438e 100644 --- a/pkg/king/lib/Vere/Pier.hs +++ b/pkg/king/lib/Vere/Pier.hs @@ -163,18 +163,22 @@ pier pierPath mPort (serf, log, ss) = do (demux, muxed) <- atomically $ do res <- Term.mkDemux - Term.addDemux local res + -- Term.addDemux local res pure (res, Term.useDemux res) rio $ logInfo $ display $ - "Terminal Server running on port: " <> tshow termServPort + "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 - when ok listenLoop + if ok + then do logTrace "TERMSERV External terminal connected" + listenLoop + else logTrace "TERMSERV Termainal server is dead" acquireWorker listenLoop diff --git a/pkg/king/lib/Vere/Term.hs b/pkg/king/lib/Vere/Term.hs index 341f8fa10f..712a20d4b6 100644 --- a/pkg/king/lib/Vere/Term.hs +++ b/pkg/king/lib/Vere/Term.hs @@ -119,7 +119,7 @@ termServer = fst <$> mkRAcquire start stop where stop = cancel . snd start = do - serv <- Serv.wsServer @Belt @Term.Ev + serv <- Serv.wsServer @Belt @[Term.Ev] let getClient = do Serv.sAccept serv <&> \case @@ -254,7 +254,7 @@ localClient = 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 :: T.Terminal -> TQueue Term.Ev -> 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) @@ -338,7 +338,7 @@ localClient = fst <$> mkRAcquire start stop loop :: LineState -> RIO e () loop ls = do join $ atomically $ asum - [ readTQueue q >>= pure . (execEv ls >=> loop) + [ readTQueue q >>= pure . (foldM execEv ls >=> loop) , takeTMVar spinner >> pure (spin ls >>= loop) ] @@ -403,8 +403,8 @@ localClient = fst <$> mkRAcquire start stop termShowCursor t ls curPos -- ring my bell - bell :: TQueue Term.Ev -> RIO e () - bell q = atomically $ writeTQueue q $ Term.Blits [Bel ()] + bell :: TQueue [Term.Ev] -> RIO e () + bell q = atomically $ writeTQueue q $ [Term.Blits [Bel ()]] -- Reads data from stdInput and emit the proper effect -- @@ -415,7 +415,7 @@ localClient = 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 Term.Ev -> (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 mempty 0) where @@ -486,7 +486,7 @@ localClient = fst <$> mkRAcquire start stop -- ETX (^C) logDebug $ displayShow "Ctrl-c interrupt" atomically $ do - writeTQueue wq $ Term.Trace "interrupt\r\n" + writeTQueue wq [Term.Trace "interrupt\r\n"] writeTQueue rq $ Ctl $ Cord "c" loop rd else if w <= 26 then do @@ -543,7 +543,7 @@ term (tsize, Client{..}) shutdownSTM pierPath king enqueueEv = handleEffect = \case TermEfBlit _ blits -> do let (termBlits, fsWrites) = partition isTerminalBlit blits - atomically $ give (Term.Blits termBlits) + atomically $ give [Term.Blits termBlits] for_ fsWrites handleFsWrite TermEfInit _ _ -> pure () TermEfLogo path _ -> do diff --git a/pkg/king/lib/Vere/Term/API.hs b/pkg/king/lib/Vere/Term/API.hs index 20998aa4ba..e18859ea0e 100644 --- a/pkg/king/lib/Vere/Term/API.hs +++ b/pkg/king/lib/Vere/Term/API.hs @@ -23,7 +23,7 @@ data Ev = Blits [Blit] data Client = Client { take :: STM Belt - , give :: Ev -> STM () + , give :: [Ev] -> STM () } deriveNoun ''Ev @@ -32,10 +32,10 @@ deriveNoun ''Ev -- Utilities ------------------------------------------------------------------- trace :: Client -> Text -> STM () -trace ts = give ts . Trace . Cord +trace ts = give ts . singleton . Trace . Cord spin :: Client -> Maybe Text -> STM () -spin ts = give ts . Spinr . Just . fmap Cord +spin ts = give ts . singleton . Spinr . Just . fmap Cord stopSpin :: Client -> STM () -stopSpin ts = give ts (Spinr Nothing) +stopSpin ts = give ts [Spinr Nothing] diff --git a/pkg/king/lib/Vere/Term/Demux.hs b/pkg/king/lib/Vere/Term/Demux.hs index 238260d9ad..840cbc986a 100644 --- a/pkg/king/lib/Vere/Term/Demux.hs +++ b/pkg/king/lib/Vere/Term/Demux.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wwarn #-} + {- This allows multiple (zero or more) terminal clients to connect to the *same* logical arvo terminal. Terminals that connect will be @@ -18,7 +20,7 @@ import qualified Vere.Term.API as Term data Demux = Demux { dConns :: TVar [Client] - , dStash :: TVar [Term.Ev] + , dStash :: TVar [[Term.Ev]] } mkDemux :: STM Demux @@ -26,9 +28,9 @@ mkDemux = Demux <$> newTVar [] <*> newTVar [] addDemux :: Client -> Demux -> STM () addDemux conn Demux{..} = do - stash <- reverse <$> readTVar dStash + stash <- concat . reverse <$> readTVar dStash modifyTVar' dConns (conn:) - for_ stash (Term.give conn) + Term.give conn stash useDemux :: Demux -> Client useDemux d = Client { give = dGive d, take = dTake d } @@ -36,7 +38,7 @@ useDemux d = Client { give = dGive d, take = dTake d } -- Internal -------------------------------------------------------------------- -dGive :: Demux -> Term.Ev -> STM () +dGive :: Demux -> [Term.Ev] -> STM () dGive Demux{..} ev = do modifyTVar' dStash (ev:) conns <- readTVar dConns From d3d42a7fdd2892decc744d32eeebc24e12beb234 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Wed, 18 Sep 2019 10:55:21 -0700 Subject: [PATCH 11/11] Re-enable local terminal (non-daemon mode) + cancelWait cleanup. --- pkg/king/lib/Vere/Pier.hs | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/pkg/king/lib/Vere/Pier.hs b/pkg/king/lib/Vere/Pier.hs index db7916438e..9ef646cadc 100644 --- a/pkg/king/lib/Vere/Pier.hs +++ b/pkg/king/lib/Vere/Pier.hs @@ -136,10 +136,7 @@ resumed top flags = do -- Run Pier -------------------------------------------------------------------- acquireWorker :: RIO e () -> RAcquire e (Async ()) -acquireWorker act = mkRAcquire start stop - where - stop t = cancel t >> void (waitCatch t) - start = async act +acquireWorker act = mkRAcquire (async act) cancel pier :: ∀e. HasLogFunc e => FilePath @@ -163,7 +160,7 @@ pier pierPath mPort (serf, log, ss) = do (demux, muxed) <- atomically $ do res <- Term.mkDemux - -- Term.addDemux local res + Term.addDemux local res pure (res, Term.useDemux res) rio $ logInfo $ display $ @@ -380,11 +377,8 @@ runPersist :: EventLog -> (FX -> STM ()) -> RAcquire e (Async ()) runPersist log inpQ out = - mkRAcquire runThread cancelWait + mkRAcquire runThread cancel where - cancelWait :: Async () -> RIO e () - cancelWait tid = cancel tid >> wait tid - runThread :: RIO e (Async ()) runThread = asyncBound $ forever $ do writs <- atomically getBatchFromQueue