mirror of
https://github.com/urbit/shrub.git
synced 2024-12-29 23:23:52 +03:00
Merge branch 'king-haskell' into king-exit-cleanly
This commit is contained in:
Elliot Glaysher
GitHub
commit
ba9bd01e35
@ -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."
|
||||
)
|
||||
|
||||
@ -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)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
||||
@ -302,7 +302,12 @@ 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
|
||||
@ -314,11 +319,8 @@ getSpinnerNameForEvent = \case
|
||||
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"
|
||||
BlipEvTerm t | isRet t -> Nothing
|
||||
BlipEvTerm t -> Just "term"
|
||||
where
|
||||
isRet (TermEvBelt _ (Ret ())) = True
|
||||
isRet _ = False
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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.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 ())
|
||||
|
||||
@ -1,43 +1,44 @@
|
||||
module Vere.Term (initializeLocalTerminal, term, TerminalSystem(..)) where
|
||||
module Vere.Term
|
||||
( module Term
|
||||
, localClient
|
||||
, connectToRemote
|
||||
, runTerminalClient
|
||||
, termServer
|
||||
, term
|
||||
) where
|
||||
|
||||
import Arvo hiding (Term)
|
||||
import Data.Char
|
||||
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 Data.Char
|
||||
import Data.List ((!!))
|
||||
import Foreign.Marshal.Alloc
|
||||
import Foreign.Ptr
|
||||
import Foreign.Storable
|
||||
import System.Posix.IO
|
||||
import System.Posix.Terminal
|
||||
|
||||
import RIO.Directory (createDirectoryIfMissing)
|
||||
import RIO.FilePath
|
||||
import System.Console.Terminfo.Base
|
||||
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,19 +110,69 @@ 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]
|
||||
|
||||
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 <-
|
||||
@ -138,28 +182,28 @@ initializeLocalTerminal = fst <$> mkRAcquire start stop
|
||||
|
||||
-- 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"
|
||||
writeBlank :: LineState -> RIO e LineState
|
||||
writeBlank ls = do
|
||||
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 $ 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
|
||||
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
|
||||
-- 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
|
||||
delay <- pure $ case mTxt of
|
||||
Nothing -> 0
|
||||
Just _ ->
|
||||
if (gap current lsPrevEndTime ^. microSecs) <
|
||||
_spin_idle_us
|
||||
if (gap current lsPrevEndTime ^. microSecs) < _spin_idle_us
|
||||
then _spin_warm_us
|
||||
else _spin_cool_us
|
||||
|
||||
spinTimer <- async $ spinnerHeartBeat delay _spin_rate_us spinner
|
||||
loop ls { lsSpinTimer = Just spinTimer,
|
||||
lsSpinCause = txt,
|
||||
lsSpinFirstRender = True }
|
||||
Right VereHideSpinner -> do
|
||||
|
||||
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 -> []
|
||||
pure $ ls { lsSpinTimer = Nothing, lsPrevEndTime = endTime }
|
||||
|
||||
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
|
||||
|
||||
spin :: LineState -> RIO e LineState
|
||||
spin ls@LineState{..} = do
|
||||
let spinner = (spinners !! lsSpinFrame) ++ case lsSpinCause of
|
||||
Nothing -> ""
|
||||
Just str -> leftBracket ++ str ++ rightBracket
|
||||
|
||||
io $ runTermOutput t $ termText spinner
|
||||
io $ T.runTermOutput t $ termText spinner
|
||||
termSpinnerMoveLeft t (length spinner)
|
||||
|
||||
loop ls { lsSpinFirstRender = False,
|
||||
lsSpinFrame = (lsSpinFrame + 1) `mod` (length spinners)
|
||||
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
|
||||
Bel () -> do runMaybeTermOutput t vtSoundBell
|
||||
pure ls
|
||||
Clr () -> do
|
||||
runMaybeTermOutput t vtClearScreen
|
||||
Clr () -> do runMaybeTermOutput t vtClearScreen
|
||||
termRefreshLine t ls
|
||||
(Hop w) -> do
|
||||
termShowCursor t ls (fromIntegral w)
|
||||
(Lin c) -> do
|
||||
ls2 <- termShowClear t ls
|
||||
Hop w -> 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
|
||||
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
41
pkg/king/lib/Vere/Term/API.hs
Normal 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
50
pkg/king/lib/Vere/Term/Demux.hs
Normal 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)
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user