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

531 lines
19 KiB
Haskell
Raw Normal View History

2019-09-18 08:01:44 +03:00
module Vere.Term
( module Term
, localClient
2019-09-18 09:58:42 +03:00
, termServer
2019-09-18 08:01:44 +03:00
, term
) where
2019-09-18 07:41:31 +03:00
import Arvo hiding (Term)
import Data.Char
import Foreign.Marshal.Alloc
import Foreign.Ptr
2019-08-29 21:12:50 +03:00
import Foreign.Storable
2019-09-18 07:41:31 +03:00
import RIO.FilePath
import System.Posix.IO
import System.Posix.Terminal
2019-09-18 07:41:31 +03:00
import Urbit.Time
import UrbitPrelude hiding (getCurrentTime)
import Vere.Pier.Types
2019-09-18 07:41:31 +03:00
import Data.List ((!!))
import RIO.Directory (createDirectoryIfMissing)
import Vere.Term.API (Client(Client))
2019-09-18 07:41:31 +03:00
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString.UTF8 as BS
2019-09-18 09:58:42 +03:00
import qualified System.Console.Terminal.Size as TSize
2019-09-18 07:41:31 +03:00
import qualified System.Console.Terminfo.Base as T
2019-09-18 09:58:42 +03:00
import qualified Vere.NounServ as Serv
import qualified Vere.Term.API as Term
2019-09-18 08:01:44 +03:00
2019-09-18 09:58:42 +03:00
2019-09-18 08:01:44 +03:00
-- Types -----------------------------------------------------------------------
-- All stateful data in the printing to stdOutput.
data LineState = LineState
2019-09-18 07:41:31 +03:00
{ lsLine :: Text
, lsCurPos :: Int
, lsSpinTimer :: Maybe (Async ())
2019-09-18 07:41:31 +03:00
, lsSpinCause :: Maybe Text
, lsSpinFirstRender :: Bool
, lsSpinFrame :: Int
, lsPrevEndTime :: Wen
}
-- A record used in reading data from stdInput.
data ReadData = ReadData
{ rdBuf :: Ptr Word8
, rdEscape :: Bool
, rdBracket :: Bool
, rdUTF8 :: ByteString
, rdUTF8width :: Int
}
-- Private data to the Client that we keep around for stop().
data Private = Private
2019-09-13 21:02:41 +03:00
{ pReaderThread :: Async ()
, pWriterThread :: Async ()
, pPreviousConfiguration :: TerminalAttributes
}
-- Utils -----------------------------------------------------------------------
2019-09-18 08:01:44 +03:00
termText :: Text -> T.TermOutput
termText = T.termText . unpack
initialBlew w h = EvBlip $ BlipEvTerm $ TermEvBlew (UD 1, ()) w h
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.
2019-09-18 07:41:31 +03:00
spinners :: [Text]
spinners = ["|", "/", "-", "\\"]
leftBracket :: Text
leftBracket = "«"
2019-09-18 07:41:31 +03:00
rightBracket :: Text
rightBracket = "»"
_spin_cool_us = 500000
_spin_warm_us = 50000
_spin_rate_us = 250000
_spin_idle_us = 500000
--------------------------------------------------------------------------------
2019-09-18 07:41:31 +03:00
runMaybeTermOutput :: T.Terminal -> (T.Terminal -> Maybe T.TermOutput) -> RIO e ()
runMaybeTermOutput t getter = case (getter t) of
Nothing -> pure ()
2019-09-18 07:41:31 +03:00
Just x -> io $ T.runTermOutput t x
2019-09-03 21:02:54 +03:00
rioAllocaBytes :: (MonadIO m, MonadUnliftIO m)
=> Int -> (Ptr a -> m b) -> m b
rioAllocaBytes size action =
withRunInIO $ \run ->
allocaBytes size $ \x -> run (action x)
-- Because of legacy reasons, some file operations are in the terminal
-- driver. These should be filtered out and handled locally instead of in any
-- abstractly connected terminal.
isTerminalBlit :: Blit -> Bool
isTerminalBlit (Sav _ _) = False
isTerminalBlit (Sag _ _) = False
isTerminalBlit _ = True
--------------------------------------------------------------------------------
2019-09-18 09:58:42 +03:00
termServer :: e. HasLogFunc e
=> RAcquire e (TChan Client, Port)
termServer = mkRAcquire start stop
where
stop = const (pure ())
start = do
serv <- Serv.wsServer @Belt @Term.Ev
chan <- newTChanIO
pure (chan, 0)
{-
data Server i o a = Server
{ sAccept :: STM (Maybe (Conn i o))
, sAsync :: Async ()
, sData :: a
}
-}
{-
Initializes the generalized input/output parts of the terminal.
-}
2019-09-18 09:58:42 +03:00
localClient :: e. HasLogFunc e => RAcquire e (TSize.Window Word, Client)
localClient = fst <$> mkRAcquire start stop
where
2019-09-18 09:58:42 +03:00
start :: HasLogFunc e => RIO e ((TSize.Window Word, Client), Private)
start = do
-- Initialize the writing side of the terminal
--
2019-09-18 07:41:31 +03:00
t <- io $ T.setupTermFromEnv
2019-09-03 21:02:54 +03:00
-- TODO: We still need to actually get the size from the terminal somehow.
tsWriteQueue <- newTQueueIO
spinnerMVar <- newEmptyTMVarIO
pWriterThread <- asyncBound (writeTerminal t tsWriteQueue spinnerMVar)
2019-09-03 21:02:54 +03:00
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
2019-09-03 21:02:54 +03:00
io $ setTerminalAttributes stdInput newTermSettings Immediately
tsReadQueue <- newTQueueIO
2019-09-13 21:02:41 +03:00
pReaderThread <- asyncBound
(readTerminal tsReadQueue tsWriteQueue (bell tsWriteQueue))
let client = Client { take = readTQueue tsReadQueue
, give = writeTQueue tsWriteQueue
}
2019-09-18 09:58:42 +03:00
tsize <- io $ TSize.size <&> fromMaybe (TSize.Window 80 24)
pure ((tsize, client), Private{..})
2019-09-04 01:17:20 +03:00
stop :: HasLogFunc e
2019-09-18 09:58:42 +03:00
=> ((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
-- block until the next piece of keyboard input. Since this only happens
-- at shutdown, just leak the file descriptor.
cancel pWriterThread
-- take the terminal out of raw mode
2019-09-03 21:02:54 +03:00
io $ setTerminalAttributes stdInput pPreviousConfiguration Immediately
{-
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 =
2019-09-18 07:41:31 +03:00
T.getCapability term (T.tiGetOutput1 cap) :: Maybe T.TermOutput
vtClearScreen t = getCap t "clear"
vtClearToBegin t = getCap t "el"
vtSoundBell t = getCap t "bel"
vtParmLeft t = getCap t "cub1"
vtParmRight t = getCap t "cuf1"
-- An async which will put into an mvar after a delay. Used to spin the
-- spinner in writeTerminal.
spinnerHeartBeat :: Int -> Int -> TMVar () -> RIO e ()
spinnerHeartBeat first rest mvar = do
threadDelay first
loop
where
loop = do
atomically $ putTMVar mvar ()
threadDelay rest
loop
-- Writes data to the terminal. Both the terminal reading, normal logging,
-- and effect handling can all emit bytes which go to the terminal.
writeTerminal :: T.Terminal -> TQueue Term.Ev -> TMVar () -> RIO e ()
writeTerminal t q spinner = do
currentTime <- io $ now
loop (LineState "" 0 Nothing Nothing True 0 currentTime)
where
2019-09-18 07:41:31 +03:00
writeBlank :: LineState -> RIO e LineState
writeBlank ls = do
io $ T.runTermOutput t $ termText "\r\n"
pure ls
2019-09-18 08:06:40 +03:00
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
2019-09-18 07:41:31 +03:00
{-
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
2019-09-18 08:01:44 +03:00
unspin ls@LineState{..} = do
maybe (pure ()) cancel lsSpinTimer
-- We do a final flush of the spinner mvar to ensure we don't
-- have a lingering signal which will redisplay the spinner after
-- we call termRefreshLine below.
atomically $ tryTakeTMVar spinner
-- If we ever actually ran the spinner display callback, we need
-- to force a redisplay of the command prompt.
2019-09-18 08:01:44 +03:00
ls <- if not lsSpinFirstRender
then termRefreshLine t ls
else pure ls
endTime <- io $ now
2019-09-18 07:41:31 +03:00
pure $ ls { lsSpinTimer = Nothing, lsPrevEndTime = endTime }
execEv :: LineState -> Term.Ev -> RIO e LineState
2019-09-18 07:41:31 +03:00
execEv ls = \case
Term.Blits bs -> foldM (writeBlit t) ls bs
2019-09-18 09:58:42 +03:00
Term.Trace p -> writeTrace ls (unCord p)
Term.Blank -> writeBlank ls
2019-09-18 09:58:42 +03:00
Term.Spinr (Just txt) -> doSpin ls (unCord <$> txt)
Term.Spinr Nothing -> unspin ls
2019-09-18 07:41:31 +03:00
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
}
2019-09-18 07:41:31 +03:00
loop :: LineState -> RIO e ()
2019-09-18 08:01:44 +03:00
loop ls = do
2019-09-18 07:41:31 +03:00
join $ atomically $ asum
[ readTQueue q >>= pure . (execEv ls >=> loop)
, takeTMVar spinner >> pure (spin ls >>= loop)
]
-- Writes an individual blit to the screen
2019-09-18 07:41:31 +03:00
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 -> 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
2019-09-18 07:41:31 +03:00
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)
pure ls { lsCurPos = newPos }
else if newPos > lsCurPos then do
replicateM_ (newPos - lsCurPos) (runMaybeTermOutput t vtParmRight)
pure ls { lsCurPos = newPos }
else
pure ls
-- Moves the cursor left without any mutation of the LineState. Used only
-- in cursor spinning.
2019-09-18 07:41:31 +03:00
termSpinnerMoveLeft :: T.Terminal -> Int -> RIO e ()
termSpinnerMoveLeft t count =
replicateM_ count (runMaybeTermOutput t vtParmLeft)
-- Displays and sets the current line
2019-09-18 07:41:31 +03:00
termShowLine :: T.Terminal -> LineState -> Text -> RIO e LineState
termShowLine t ls newStr = do
2019-09-18 07:41:31 +03:00
io $ T.runTermOutput t $ termText newStr
pure ls { lsLine = newStr, lsCurPos = (length newStr) }
2019-09-18 07:41:31 +03:00
termShowClear :: T.Terminal -> LineState -> RIO e LineState
termShowClear t ls = do
2019-09-18 07:41:31 +03:00
io $ T.runTermOutput t $ termText "\r"
runMaybeTermOutput t vtClearToBegin
pure ls { lsLine = "", lsCurPos = 0 }
-- New Current Line
2019-09-18 07:41:31 +03:00
termShowMore :: T.Terminal -> LineState -> RIO e LineState
termShowMore t ls = do
2019-09-18 07:41:31 +03:00
io $ T.runTermOutput t $ termText "\r\n"
pure ls { lsLine = "", lsCurPos = 0 }
-- Redraw the current LineState, maintaining the current curpos
2019-09-18 07:41:31 +03:00
termRefreshLine :: T.Terminal -> LineState -> RIO e LineState
termRefreshLine t ls = do
let line = (lsLine ls)
curPos = (lsCurPos ls)
ls <- termShowClear t ls
ls <- termShowLine t ls line
termShowCursor t ls curPos
-- ring my bell
bell :: TQueue Term.Ev -> RIO e ()
bell q = atomically $ writeTQueue q $ Term.Blits [Bel ()]
-- Reads data from stdInput and emit the proper effect
--
-- This entire path is a divergence from how term.c does things,
-- probably. First, the vtime is 0, not 1 in term.c. So (IIUC), we'll
-- always have a latency of 1/10 of a second.
--
-- 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?
2019-09-03 21:02:54 +03:00
readTerminal :: forall e. HasLogFunc e
=> TQueue Belt -> TQueue Term.Ev -> (RIO e ()) -> RIO e ()
2019-09-03 21:02:54 +03:00
readTerminal rq wq bell =
2019-09-18 07:41:31 +03:00
rioAllocaBytes 1 $ \ buf -> loop (ReadData buf False False mempty 0)
where
2019-09-03 21:02:54 +03:00
loop :: ReadData -> RIO e ()
loop rd@ReadData{..} = do
-- The problem with using fdRead raw is that it will text encode
-- things like \ESC instead of 27. That makes it broken for our
-- purposes.
2019-08-30 00:54:34 +03:00
--
2019-09-03 21:02:54 +03:00
t <- io $ try (fdReadBuf stdInput rdBuf 1)
case t of
2019-08-30 00:54:34 +03:00
Left (e :: IOException) -> do
-- Ignore EAGAINs when doing reads
loop rd
Right 0 -> loop rd
Right _ -> do
2019-09-03 21:02:54 +03:00
w <- io $ peek rdBuf
2019-08-30 00:54:34 +03:00
-- print ("{" ++ (show w) ++ "}")
2019-09-18 07:41:31 +03:00
let c = BS.w2c w
if rdEscape then
if rdBracket then do
case c of
'A' -> sendBelt $ Aro U
'B' -> sendBelt $ Aro D
'C' -> sendBelt $ Aro R
'D' -> sendBelt $ Aro L
2019-08-30 00:54:34 +03:00
_ -> bell
loop rd { rdEscape = False, rdBracket = False}
2019-08-30 00:54:34 +03:00
else if isAsciiLower c then do
sendBelt $ Met $ Cord $ pack [c]
loop rd { rdEscape = False }
2019-08-30 00:54:34 +03:00
else if c == '.' then do
sendBelt $ Met $ Cord "dot"
loop rd { rdEscape = False }
2019-08-30 00:54:34 +03:00
else if w == 8 || w == 127 then do
sendBelt $ Met $ Cord "bac"
loop rd { rdEscape = False }
2019-08-30 00:54:34 +03:00
else if c == '[' || c == '0' then do
loop rd { rdBracket = True }
2019-08-30 00:54:34 +03:00
else do
bell
loop rd { rdEscape = False }
else if rdUTF8width /= 0 then do
-- continue reading into the utf8 accumulation buffer
rd@ReadData{..} <- pure rd { rdUTF8 = snoc rdUTF8 w }
if length rdUTF8 /= rdUTF8width then loop rd
else do
2019-09-18 07:41:31 +03:00
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]
2019-09-18 07:41:31 +03:00
loop rd { rdUTF8 = mempty, rdUTF8width = 0 }
2019-08-30 00:54:34 +03:00
else if w >= 32 && w < 127 then do
sendBelt $ Txt $ Tour $ [c]
2019-08-30 00:54:34 +03:00
loop rd
else if w == 0 then do
bell
2019-08-30 00:54:34 +03:00
loop rd
else if w == 8 || w == 127 then do
sendBelt $ Bac ()
loop rd
else if w == 13 then do
sendBelt $ Ret ()
loop rd
2019-08-30 00:54:34 +03:00
else if w == 3 then do
-- ETX (^C)
2019-09-03 21:02:54 +03:00
logDebug $ displayShow "Ctrl-c interrupt"
2019-08-30 01:05:01 +03:00
atomically $ do
writeTQueue wq $ Term.Trace "interrupt\r\n"
writeTQueue rq $ Ctl $ Cord "c"
2019-08-30 00:54:34 +03:00
loop rd
else if w <= 26 then do
2019-09-18 07:41:31 +03:00
sendBelt $ Ctl $ Cord $ pack [BS.w2c (w + 97 - 1)]
loop rd
else if w == 27 then do
loop rd { rdEscape = True }
2019-08-30 00:54:34 +03:00
else do
-- start the utf8 accumulation buffer
loop rd { rdUTF8 = singleton w,
rdUTF8width = if w < 224 then 2
else if w < 240 then 3
else 4 }
2019-09-03 21:02:54 +03:00
sendBelt :: HasLogFunc e => Belt -> RIO e ()
sendBelt b = do
2019-09-03 21:02:54 +03:00
logDebug $ displayShow ("terminalBelt", b)
atomically $ writeTQueue rq b
--------------------------------------------------------------------------------
term :: forall e. HasLogFunc e
2019-09-18 09:58:42 +03:00
=> (TSize.Window Word, Client)
-> (STM ())
-> FilePath
-> KingId
-> QueueEv
-> ([Ev], RAcquire e (EffCb e TermEf))
2019-09-18 09:58:42 +03:00
term (tsize, Client{..}) shutdownSTM pierPath king enqueueEv =
(initialEvents, runTerm)
where
2019-09-18 09:58:42 +03:00
TSize.Window wi hi = tsize
initialEvents = [(initialBlew hi wi), initialHail]
2019-09-03 21:02:54 +03:00
runTerm :: RAcquire e (EffCb e TermEf)
runTerm = do
2019-09-03 21:02:54 +03:00
tim <- mkRAcquire start stop
pure handleEffect
2019-09-03 21:02:54 +03:00
start :: RIO e (Async ())
start = async readBelt
2019-09-03 21:02:54 +03:00
stop :: Async () -> RIO e ()
stop rb = cancel rb
2019-09-03 21:02:54 +03:00
readBelt :: RIO e ()
readBelt = forever $ do
b <- atomically take
let blip = EvBlip $ BlipEvTerm $ TermEvBelt (UD 1, ()) $ b
atomically $ enqueueEv $ blip
2019-09-03 21:02:54 +03:00
handleEffect :: TermEf -> RIO e ()
handleEffect = \case
TermEfBlit _ blits -> do
let (termBlits, fsWrites) = partition isTerminalBlit blits
atomically $ give (Term.Blits termBlits)
for_ fsWrites handleFsWrite
TermEfInit _ _ -> pure ()
TermEfLogo path _ -> do
atomically $ shutdownSTM
TermEfMass _ _ -> pure ()
2019-09-03 21:02:54 +03:00
handleFsWrite :: Blit -> RIO e ()
2019-08-30 23:25:50 +03:00
handleFsWrite (Sag path noun) = performPut path (jamBS noun)
handleFsWrite (Sav path atom) = performPut path (atom ^. atomBytes)
2019-09-13 21:02:41 +03:00
handleFsWrite _ = pure ()
2019-08-30 23:25:50 +03:00
2019-09-03 21:02:54 +03:00
performPut :: Path -> ByteString -> RIO e ()
2019-08-30 23:25:50 +03:00
performPut path bs = do
let putOutFile = pierPath </> ".urb" </> "put" </> (pathToFilePath path)
createDirectoryIfMissing True (takeDirectory putOutFile)
2019-08-30 23:25:50 +03:00
writeFile putOutFile bs