urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-12-20 17:32:11 +03:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'king-haskell' into king-exit-cleanly

Browse Source
This commit is contained in:
Elliot Glaysher 2019-09-18 11:02:46 -07:00 committed by GitHub
commit ba9bd01e35
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
9 changed files with 437 additions and 214 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
pkg/king/app/CLI.hs
View File

@ -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."
)

9
pkg/king/app/Main.hs
View File

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

40
pkg/king/lib/Arvo/Event.hs
View File

@ -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

15
pkg/king/lib/Vere/NounServ.hs
View File

@ -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

76
pkg/king/lib/Vere/Pier.hs
View File

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

406
pkg/king/lib/Vere/Term.hs
View File

@ -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

41
pkg/king/lib/Vere/Term/API.hs Normal file
View File

@ -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]

50
pkg/king/lib/Vere/Term/Demux.hs Normal file
View File

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

3
pkg/king/package.yaml
View File

@ -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