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..d45fa6aa46 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,14 @@ main = do CLI.CmdBug (CLI.ValidatePill pax pil seq) -> testPill pax pil seq CLI.CmdBug (CLI.ValidateEvents pax f l) -> checkEvs pax f l CLI.CmdBug (CLI.ValidateFX pax f l) -> checkFx pax f l + CLI.CmdCon port -> connTerm port + + +-------------------------------------------------------------------------------- + +connTerm :: ∀e. HasLogFunc e => Word16 -> RIO e () +connTerm port = + Term.runTerminalClient (fromIntegral port) -------------------------------------------------------------------------------- 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/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 ed88d0a0fd..ff517016e3 100644 --- a/pkg/king/lib/Vere/Pier.hs +++ b/pkg/king/lib/Vere/Pier.hs @@ -18,14 +18,17 @@ import Vere.Http.Client (client) import Vere.Http.Server (serv) import Vere.Log (EventLog) import Vere.Serf (Serf, SerfState(..), doJob, sStderr) -import Vere.Term import RIO.Directory -import qualified System.Entropy as Ent -import qualified Urbit.Time as Time -import qualified Vere.Log as Log -import qualified Vere.Serf as Serf +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 -------------------------------------------------------------------------------- @@ -132,38 +135,71 @@ resumed top flags = do -- Run Pier -------------------------------------------------------------------- +acquireWorker :: RIO e () -> RAcquire e (Async ()) +acquireWorker act = mkRAcquire (async act) cancel + pier :: ∀e. HasLogFunc e => FilePath -> Maybe Port -> (Serf e, EventLog, SerfState) -> RAcquire e () pier pierPath mPort (serf, log, ss) = do - computeQ <- newTQueueIO :: RAcquire e (TQueue Ev) - 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) (tsStderr terminalSystem) + (sz, local) <- Term.localClient + + (waitExternalTerm, termServPort) <- Term.termServer + + (demux, muxed) <- atomically $ do + res <- Term.mkDemux + Term.addDemux local res + pure (res, Term.useDemux res) + + rio $ logInfo $ display $ + "TERMSERV Terminal Server running on port: " <> tshow termServPort + + let listenLoop = do + logTrace "TERMSERV Waiting for external terminal." + ok <- atomically $ do + waitExternalTerm >>= \case + Nothing -> pure False + Just ext -> Term.addDemux ext demux >> pure True + if ok + then do logTrace "TERMSERV External terminal connected" + listenLoop + else logTrace "TERMSERV Termainal server is dead" + + acquireWorker listenLoop + + swapMVar (sStderr serf) (atomically . Term.trace muxed) let ship = who (Log.identity log) let (bootEvents, startDrivers) = - drivers pierPath inst ship mPort (writeTQueue computeQ) - shutdownEvent terminalSystem + drivers pierPath inst ship mPort + (writeTQueue computeQ) + shutdownEvent + (sz, muxed) io $ atomically $ for_ bootEvents (writeTQueue computeQ) tExe <- startDrivers >>= router (readTQueue executeQ) tDisk <- runPersist log persistQ (writeTQueue executeQ) - tCpu <- runCompute serf ss (readTQueue computeQ) (takeTMVar saveM) - (takeTMVar shutdownM) (tsShowSpinner terminalSystem) - (tsHideSpinner terminalSystem) (writeTQueue persistQ) + tCpu <- runCompute serf ss + (readTQueue computeQ) + (takeTMVar saveM) + (takeTMVar shutdownM) + (Term.spin muxed) + (Term.stopSpin muxed) + (writeTQueue persistQ) tSaveSignal <- saveSignalThread saveM @@ -205,7 +241,7 @@ data Drivers e = Drivers drivers :: HasLogFunc e => FilePath -> KingId -> Ship -> Maybe Port -> (Ev -> STM ()) -> STM() - -> TerminalSystem e + -> (TSize.Window Word, Term.Client) -> ([Ev], RAcquire e (Drivers e)) drivers pierPath inst who mPort plan shutdownSTM termSys = (initialEvents, runDrivers) @@ -215,7 +251,7 @@ drivers pierPath inst who mPort plan shutdownSTM termSys = (httpBorn, runHttp) = serv pierPath inst plan (clayBorn, runClay) = clay pierPath inst plan (irisBorn, runIris) = client inst plan - (termBorn, runTerm) = term termSys shutdownSTM pierPath inst plan + (termBorn, runTerm) = Term.term termSys shutdownSTM pierPath inst plan initialEvents = mconcat [behnBorn, clayBorn, amesBorn, httpBorn, termBorn, irisBorn] runDrivers = do @@ -286,7 +322,7 @@ runCompute :: ∀e. HasLogFunc e -> STM Ev -> STM () -> STM () - -> (Maybe String -> STM ()) + -> (Maybe Text -> STM ()) -> STM () -> ((Job, FX) -> STM ()) -> RAcquire e (Async ()) diff --git a/pkg/king/lib/Vere/Term.hs b/pkg/king/lib/Vere/Term.hs index 198b853ff7..52d0b0522d 100644 --- a/pkg/king/lib/Vere/Term.hs +++ b/pkg/king/lib/Vere/Term.hs @@ -1,43 +1,44 @@ -module Vere.Term (initializeLocalTerminal, term, TerminalSystem(..)) where - -import Arvo hiding (Term) -import Urbit.Time -import UrbitPrelude hiding (getCurrentTime) -import Vere.Pier.Types +module Vere.Term + ( module Term + , localClient + , connectToRemote + , runTerminalClient + , termServer + , term + ) where +import Arvo hiding (Term) import Data.Char -import Data.List ((!!)) import Foreign.Marshal.Alloc import Foreign.Ptr import Foreign.Storable +import RIO.FilePath import System.Posix.IO import System.Posix.Terminal +import Urbit.Time +import UrbitPrelude hiding (getCurrentTime) +import Vere.Pier.Types -import RIO.Directory (createDirectoryIfMissing) -import RIO.FilePath -import System.Console.Terminfo.Base +import Data.List ((!!)) +import RIO.Directory (createDirectoryIfMissing) +import Vere.Term.API (Client(Client)) -import Data.ByteString.Internal +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.UTF8 as BS +import qualified System.Console.Terminal.Size as TSize +import qualified System.Console.Terminfo.Base as T +import qualified Vere.NounServ as Serv +import qualified Vere.Term.API as Term -import qualified Data.ByteString as B -import qualified Data.ByteString.UTF8 as UTF8 -- Types ----------------------------------------------------------------------- --- Output to the attached terminal is either a series of vere blits, or it is an --- injected printf line from the interpreter. -data VereOutput = VereBlitOutput [Blit] - | VerePrintOutput String - | VereBlankLine - | VereShowSpinner (Maybe String) - | VereHideSpinner - -- All stateful data in the printing to stdOutput. data LineState = LineState - { lsLine :: String + { lsLine :: Text , lsCurPos :: Int , lsSpinTimer :: Maybe (Async ()) - , lsSpinCause :: Maybe String + , lsSpinCause :: Maybe Text , lsSpinFirstRender :: Bool , lsSpinFrame :: Int , lsPrevEndTime :: Wen @@ -52,21 +53,7 @@ data ReadData = ReadData , rdUTF8width :: Int } --- Minimal terminal interface. --- --- A Terminal can either be local or remote. Either way, the Terminal, from the --- view of the caller, a terminal has a thread which when exits indicates that --- the session is over, and has a general in/out queue in the types of the --- vere/arvo interface. -data TerminalSystem e = TerminalSystem - { tsReadQueue :: TQueue Belt - , tsWriteQueue :: TQueue VereOutput - , tsStderr :: Text -> RIO e () - , tsShowSpinner :: Maybe String -> STM () - , tsHideSpinner :: STM () - } - --- Private data to the TerminalSystem that we keep around for stop(). +-- Private data to the Client that we keep around for stop(). data Private = Private { pReaderThread :: Async () , pWriterThread :: Async () @@ -76,6 +63,9 @@ data Private = Private -- Utils ----------------------------------------------------------------------- +termText :: Text -> T.TermOutput +termText = T.termText . unpack + initialBlew w h = EvBlip $ BlipEvTerm $ TermEvBlew (UD 1, ()) w h initialHail = EvBlip $ BlipEvTerm $ TermEvHail (UD 1, ()) () @@ -83,10 +73,14 @@ initialHail = EvBlip $ BlipEvTerm $ TermEvHail (UD 1, ()) () -- Version one of this is punting on the ops_u.dem flag: whether we're running -- in daemon mode. -spinners = ['|', '/', '-', '\\'] +spinners :: [Text] +spinners = ["|", "/", "-", "\\"] -leftBracket = ['«'] -rightBracket = ['»'] +leftBracket :: Text +leftBracket = "«" + +rightBracket :: Text +rightBracket = "»" _spin_cool_us = 500000 _spin_warm_us = 50000 @@ -95,10 +89,10 @@ _spin_idle_us = 500000 -------------------------------------------------------------------------------- -runMaybeTermOutput :: Terminal -> (Terminal -> Maybe TermOutput) -> RIO e () +runMaybeTermOutput :: T.Terminal -> (T.Terminal -> Maybe T.TermOutput) -> RIO e () runMaybeTermOutput t getter = case (getter t) of Nothing -> pure () - Just x -> io $ runTermOutput t x + Just x -> io $ T.runTermOutput t x rioAllocaBytes :: (MonadIO m, MonadUnliftIO m) => Int -> (Ptr a -> m b) -> m b @@ -116,50 +110,100 @@ isTerminalBlit _ = True -------------------------------------------------------------------------------- --- Initializes the generalized input/output parts of the terminal. --- -initializeLocalTerminal :: forall e. HasLogFunc e - => RAcquire e (TerminalSystem e) -initializeLocalTerminal = fst <$> mkRAcquire start stop +{- + 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 (STM (Maybe Client), Port) +termServer = fst <$> mkRAcquire start stop where - start :: HasLogFunc e => RIO e (TerminalSystem e, Private) + stop = cancel . snd start = do - -- Initialize the writing side of the terminal - -- - pTerminal <- io $ setupTermFromEnv - -- TODO: We still need to actually get the size from the terminal somehow. + serv <- Serv.wsServer @Belt @[Term.Ev] - tsWriteQueue <- newTQueueIO - spinnerMVar <- newEmptyTMVarIO + 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) + , Serv.sAsync serv + ) + +connectToRemote :: ∀e. HasLogFunc e + => Port + -> Client + -> RAcquire e (Async (), Async ()) +connectToRemote port local = mkRAcquire start stop + where + stop (x, y) = cancel x >> cancel y + start = do + Serv.Client{..} <- Serv.wsClient (fromIntegral port) + + ferry <- async $ forever $ atomically $ asum + [ Term.take local >>= Serv.cSend cConn + , Serv.cRecv cConn >>= \case + Nothing -> empty + Just ev -> Term.give local ev + ] + + pure (ferry, cAsync) + +runTerminalClient :: ∀e. HasLogFunc e => Port -> RIO e () +runTerminalClient port = runRAcquire $ do + (tsize, local) <- localClient + (tid1, tid2) <- connectToRemote port local + atomically $ waitSTM tid1 <|> waitSTM tid2 + where + runRAcquire :: RAcquire e () -> RIO e () + runRAcquire act = rwith act $ const $ pure () + +{- + Initializes the generalized input/output parts of the terminal. +-} +localClient :: ∀e. HasLogFunc e => RAcquire e (TSize.Window Word, Client) +localClient = fst <$> mkRAcquire start stop + where + start :: HasLogFunc e => RIO e ((TSize.Window Word, Client), Private) + start = do + pTerminal <- io $ T.setupTermFromEnv + tsWriteQueue <- newTQueueIO + spinnerMVar <- newEmptyTMVarIO pWriterThread <- - asyncBound (writeTerminal pTerminal tsWriteQueue spinnerMVar) + asyncBound (writeTerminal pTerminal tsWriteQueue spinnerMVar) pPreviousConfiguration <- io $ getTerminalAttributes stdInput -- Create a new configuration where we put the terminal in raw mode and -- disable a bunch of preprocessing. - let newTermSettings = - 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 pReaderThread <- asyncBound (readTerminal tsReadQueue tsWriteQueue (bell tsWriteQueue)) - let tsStderr = \txt -> - atomically $ writeTQueue tsWriteQueue $ VerePrintOutput $ unpack txt + let client = Client { take = readTQueue tsReadQueue + , give = writeTQueue tsWriteQueue + } - let tsShowSpinner = \str -> - writeTQueue tsWriteQueue $ VereShowSpinner str - let tsHideSpinner = writeTQueue tsWriteQueue $ VereHideSpinner + tsize <- io $ TSize.size <&> fromMaybe (TSize.Window 80 24) - pure (TerminalSystem{..}, Private{..}) + pure ((tsize, client), Private{..}) stop :: HasLogFunc e - => (TerminalSystem e, Private) -> RIO e () - stop (TerminalSystem{..}, 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 @@ -173,21 +217,27 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop -- take the terminal out of raw mode io $ setTerminalAttributes stdInput pPreviousConfiguration Immediately - -- A list of terminal flags that we disable - disabledFlags = [ - -- 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 = - getCapability term (tiGetOutput1 cap) :: Maybe TermOutput + T.getCapability term (T.tiGetOutput1 cap) :: Maybe T.TermOutput vtClearScreen t = getCap t "clear" vtClearToBegin t = getCap t "el" @@ -209,48 +259,49 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop -- Writes data to the terminal. Both the terminal reading, normal logging, -- and effect handling can all emit bytes which go to the terminal. - writeTerminal :: Terminal -> TQueue VereOutput -> TMVar () -> RIO e () + writeTerminal :: T.Terminal -> TQueue [Term.Ev] -> TMVar () -> RIO e () writeTerminal t q spinner = do currentTime <- io $ now loop (LineState "" 0 Nothing Nothing True 0 currentTime) where - loop ls@LineState{..} = do - 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 + 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 + action and trigger immediately. Otherwise, if we receive an + event shortly after a previous spin, use a shorter delay to + avoid giving the impression of a half-idle system. + -} + doSpin :: LineState -> Maybe Text -> RIO e LineState + doSpin ls@LineState{..} mTxt = do + current <- io $ now + delay <- pure $ case mTxt of + Nothing -> 0 + Just _ -> + if (gap current lsPrevEndTime ^. microSecs) < _spin_idle_us + then _spin_warm_us + else _spin_cool_us + + spinTimer <- async $ spinnerHeartBeat delay _spin_rate_us spinner + + pure $ ls { lsSpinTimer = Just spinTimer + , lsSpinCause = mTxt + , lsSpinFirstRender = True + } + + unspin :: LineState -> RIO e LineState + unspin ls@LineState{..} = do maybe (pure ()) cancel lsSpinTimer -- We do a final flush of the spinner mvar to ensure we don't -- have a lingering signal which will redisplay the spinner after @@ -264,41 +315,55 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop else pure ls endTime <- io $ now - loop ls { lsSpinTimer = Nothing, lsPrevEndTime = endTime } - 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 -> Term.Ev -> RIO e LineState + execEv ls = \case + Term.Blits bs -> foldM (writeBlit t) ls bs + Term.Trace p -> writeTrace ls (unCord p) + Term.Blank -> writeBlank ls + Term.Spinr (Just txt) -> doSpin ls (unCord <$> txt) + Term.Spinr Nothing -> unspin ls - loop ls { lsSpinFirstRender = False, - 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 = do + join $ atomically $ asum + [ readTQueue q >>= pure . (foldM execEv ls >=> loop) + , takeTMVar spinner >> pure (spin ls >>= loop) + ] + -- Writes an individual blit to the screen - writeBlit :: Terminal -> LineState -> Blit -> RIO e LineState + writeBlit :: T.Terminal -> LineState -> Blit -> RIO e LineState writeBlit t ls = \case - Bel () -> do - 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 :: Terminal -> LineState -> Int -> RIO e LineState + termShowCursor :: T.Terminal -> LineState -> Int -> RIO e LineState termShowCursor t ls@LineState{..} {-line pos)-} newPos = do if newPos < lsCurPos then do replicateM_ (lsCurPos - newPos) (runMaybeTermOutput t vtParmLeft) @@ -309,33 +374,32 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop else pure ls - -- Moves the cursor left without any mutation of the LineState. Used only -- in cursor spinning. - termSpinnerMoveLeft :: Terminal -> Int -> RIO e () + termSpinnerMoveLeft :: T.Terminal -> Int -> RIO e () termSpinnerMoveLeft t count = replicateM_ count (runMaybeTermOutput t vtParmLeft) -- Displays and sets the current line - termShowLine :: Terminal -> LineState -> String -> RIO e LineState + termShowLine :: T.Terminal -> LineState -> Text -> RIO e LineState termShowLine t ls newStr = do - io $ runTermOutput t $ termText newStr + io $ T.runTermOutput t $ termText newStr pure ls { lsLine = newStr, lsCurPos = (length newStr) } - termShowClear :: Terminal -> LineState -> RIO e LineState + termShowClear :: T.Terminal -> LineState -> RIO e LineState termShowClear t ls = do - io $ runTermOutput t $ termText "\r" + io $ T.runTermOutput t $ termText "\r" runMaybeTermOutput t vtClearToBegin pure ls { lsLine = "", lsCurPos = 0 } -- New Current Line - termShowMore :: Terminal -> LineState -> RIO e LineState + termShowMore :: T.Terminal -> LineState -> RIO e LineState termShowMore t ls = do - io $ runTermOutput t $ termText "\r\n" + io $ T.runTermOutput t $ termText "\r\n" pure ls { lsLine = "", lsCurPos = 0 } -- Redraw the current LineState, maintaining the current curpos - termRefreshLine :: Terminal -> LineState -> RIO e LineState + termRefreshLine :: T.Terminal -> LineState -> RIO e LineState termRefreshLine t ls = do let line = (lsLine ls) curPos = (lsCurPos ls) @@ -344,8 +408,8 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop termShowCursor t ls curPos -- ring my bell - bell :: TQueue VereOutput -> RIO e () - bell q = atomically $ writeTQueue q $ VereBlitOutput [Bel ()] + bell :: TQueue [Term.Ev] -> RIO e () + bell q = atomically $ writeTQueue q $ [Term.Blits [Bel ()]] -- Reads data from stdInput and emit the proper effect -- @@ -356,9 +420,9 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop -- A better way to do this would be to get some sort of epoll on stdInput, -- since that's kinda closer to what libuv does? readTerminal :: forall e. HasLogFunc e - => TQueue Belt -> TQueue VereOutput -> (RIO e ()) -> RIO e () + => TQueue Belt -> TQueue [Term.Ev] -> (RIO e ()) -> RIO e () readTerminal rq wq bell = - rioAllocaBytes 1 $ \ buf -> loop (ReadData buf False False B.empty 0) + rioAllocaBytes 1 $ \ buf -> loop (ReadData buf False False mempty 0) where loop :: ReadData -> RIO e () loop rd@ReadData{..} = do @@ -375,7 +439,7 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop Right _ -> do w <- io $ peek rdBuf -- print ("{" ++ (show w) ++ "}") - let c = w2c w + let c = BS.w2c w if rdEscape then if rdBracket then do case c of @@ -404,13 +468,13 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop rd@ReadData{..} <- pure rd { rdUTF8 = snoc rdUTF8 w } if length rdUTF8 /= rdUTF8width then loop rd else do - case UTF8.decode rdUTF8 of + case BS.decode rdUTF8 of Nothing -> error "empty utf8 accumulation buffer" Just (c, bytes) | bytes /= rdUTF8width -> error "utf8 character size mismatch?!" Just (c, bytes) -> sendBelt $ Txt $ Tour $ [c] - loop rd { rdUTF8 = B.empty, rdUTF8width = 0 } + loop rd { rdUTF8 = mempty, rdUTF8width = 0 } else if w >= 32 && w < 127 then do sendBelt $ Txt $ Tour $ [c] loop rd @@ -427,11 +491,11 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop -- ETX (^C) logDebug $ displayShow "Ctrl-c interrupt" atomically $ do - writeTQueue wq $ VerePrintOutput "interrupt\r\n" + writeTQueue wq [Term.Trace "interrupt\r\n"] writeTQueue rq $ Ctl $ Cord "c" loop rd else if w <= 26 then do - sendBelt $ Ctl $ Cord $ pack [w2c (w + 97 - 1)] + sendBelt $ Ctl $ Cord $ pack [BS.w2c (w + 97 - 1)] loop rd else if w == 27 then do loop rd { rdEscape = True } @@ -450,12 +514,18 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop -------------------------------------------------------------------------------- term :: forall e. HasLogFunc e - => TerminalSystem e -> (STM ()) -> FilePath -> KingId -> QueueEv + => (TSize.Window Word, Client) + -> (STM ()) + -> FilePath + -> KingId + -> QueueEv -> ([Ev], RAcquire e (EffCb e TermEf)) -term TerminalSystem{..} shutdownSTM pierPath king enqueueEv = +term (tsize, Client{..}) shutdownSTM pierPath king enqueueEv = (initialEvents, runTerm) where - initialEvents = [(initialBlew 80 24), initialHail] + TSize.Window wi hi = tsize + + initialEvents = [(initialBlew hi wi), initialHail] runTerm :: RAcquire e (EffCb e TermEf) runTerm = do @@ -467,7 +537,7 @@ term TerminalSystem{..} shutdownSTM pierPath king enqueueEv = readBelt :: RIO e () readBelt = forever $ do - b <- atomically $ readTQueue tsReadQueue + b <- atomically take let blip = EvBlip $ BlipEvTerm $ TermEvBelt (UD 1, ()) $ b atomically $ enqueueEv $ blip @@ -475,7 +545,7 @@ term TerminalSystem{..} shutdownSTM pierPath king enqueueEv = handleEffect = \case TermEfBlit _ blits -> do let (termBlits, fsWrites) = partition isTerminalBlit blits - atomically $ writeTQueue tsWriteQueue (VereBlitOutput termBlits) + atomically $ give [Term.Blits termBlits] for_ fsWrites handleFsWrite TermEfInit _ _ -> pure () TermEfLogo path _ -> do diff --git a/pkg/king/lib/Vere/Term/API.hs b/pkg/king/lib/Vere/Term/API.hs new file mode 100644 index 0000000000..e18859ea0e --- /dev/null +++ b/pkg/king/lib/Vere/Term/API.hs @@ -0,0 +1,41 @@ +module Vere.Term.API (Ev(..), Client(..), trace, spin, stopSpin) where + +import UrbitPrelude hiding (trace) + +import Arvo (Blit, Belt) + + +-- External Types -------------------------------------------------------------- + +{- + Input Event for terminal driver: + + %blits -- list of blits from arvo. + %trace -- stderr line from runtime. + %blank -- print a blank line + %spinr -- Start or stop the spinner +-} +data Ev = Blits [Blit] + | Trace Cord + | Blank + | Spinr (Maybe (Maybe Cord)) + deriving (Show) + +data Client = Client + { take :: STM Belt + , give :: [Ev] -> STM () + } + +deriveNoun ''Ev + + +-- Utilities ------------------------------------------------------------------- + +trace :: Client -> Text -> STM () +trace ts = give ts . singleton . Trace . Cord + +spin :: Client -> Maybe Text -> STM () +spin ts = give ts . singleton . Spinr . Just . fmap Cord + +stopSpin :: Client -> STM () +stopSpin ts = give ts [Spinr Nothing] diff --git a/pkg/king/lib/Vere/Term/Demux.hs b/pkg/king/lib/Vere/Term/Demux.hs new file mode 100644 index 0000000000..840cbc986a --- /dev/null +++ b/pkg/king/lib/Vere/Term/Demux.hs @@ -0,0 +1,50 @@ +{-# OPTIONS_GHC -Wwarn #-} + +{- + This allows multiple (zero or more) terminal clients to connect to + the *same* logical arvo terminal. Terminals that connect will be + given full event history since the creation of the demuxer. +-} + +module Vere.Term.Demux (Demux, mkDemux, addDemux, useDemux) where + +import UrbitPrelude + +import Arvo (Belt) +import Vere.Term.API (Client(Client)) + +import qualified Vere.Term.API as Term + + +-------------------------------------------------------------------------------- + +data Demux = Demux + { dConns :: TVar [Client] + , dStash :: TVar [[Term.Ev]] + } + +mkDemux :: STM Demux +mkDemux = Demux <$> newTVar [] <*> newTVar [] + +addDemux :: Client -> Demux -> STM () +addDemux conn Demux{..} = do + stash <- concat . reverse <$> readTVar dStash + modifyTVar' dConns (conn:) + Term.give conn stash + +useDemux :: Demux -> Client +useDemux d = Client { give = dGive d, take = dTake d } + + +-- Internal -------------------------------------------------------------------- + +dGive :: Demux -> [Term.Ev] -> STM () +dGive Demux{..} ev = do + modifyTVar' dStash (ev:) + conns <- readTVar dConns + for_ conns $ \c -> Term.give c ev + +dTake :: Demux -> STM Belt +dTake Demux{..} = do + conns <- readTVar dConns + asum (Term.take <$> conns) 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