mirror of
https://github.com/ilyakooo0/urbit.git
synced 2024-12-15 18:12:47 +03:00
Merge pull request #1740 from urbit/king-cleanup
Further terminal fixes and cleanups
This commit is contained in:
Elliot Glaysher
GitHub
commit
721945d1ba
@ -106,12 +106,8 @@ clay pierPath king enqueueEv =
|
||||
]
|
||||
|
||||
runSync :: RAcquire e (EffCb e SyncEf)
|
||||
runSync = do
|
||||
tim <- mkRAcquire start stop
|
||||
pure (handleEffect tim)
|
||||
runSync = handleEffect <$> mkRAcquire start stop
|
||||
|
||||
-- TODO: Traditionally, lock file acquisition was handled in the unix
|
||||
-- driver. This should instead be bumped up to main or something.
|
||||
start :: RIO e ClayDrv
|
||||
start = ClayDrv <$> newTVarIO mempty
|
||||
stop c = pure ()
|
||||
@ -162,20 +158,23 @@ clay pierPath king enqueueEv =
|
||||
atomically $ modifyTVar (cdMountPoints cd) (M.delete desk)
|
||||
|
||||
|
||||
-- Change the structures off of the event into something we can work with in Unix.
|
||||
calculateActionHash :: FilePath -> (Path, Maybe Mime) -> (FilePath, Maybe (Mime, Int))
|
||||
-- Change the structures off of the event into something we can work with
|
||||
-- in Unix.
|
||||
calculateActionHash :: FilePath -> (Path, Maybe Mime)
|
||||
-> (FilePath, Maybe (Mime, Int))
|
||||
calculateActionHash base (p, Nothing) = (base </> pathToFilePath p, Nothing)
|
||||
calculateActionHash base (p, Just (Mime t f)) =
|
||||
(base </> pathToFilePath p, Just ((Mime t f), (hash $ unOcts $ unFile f)))
|
||||
|
||||
-- Performs the actions on the actual filesystem
|
||||
performAction :: (Map FilePath Int) -> (FilePath, Maybe (Mime, Int)) -> RIO e ()
|
||||
performAction :: (Map FilePath Int) -> (FilePath, Maybe (Mime, Int))
|
||||
-> RIO e ()
|
||||
performAction m (fp, Nothing) = do
|
||||
logDebug $ displayShow ("(clay) deleting file ", fp)
|
||||
removeFile fp
|
||||
performAction m (fp, Just ((Mime _ (File (Octs bs)), hash)))
|
||||
| skip =
|
||||
logDebug $ displayShow ("(clay) skipping unchanged file update " , fp)
|
||||
| skip = logDebug $
|
||||
displayShow ("(clay) skipping unchanged file update " , fp)
|
||||
| otherwise = do
|
||||
logDebug $ displayShow ("(clay) updating file " , fp)
|
||||
createDirectoryIfMissing True $ takeDirectory fp
|
||||
@ -203,7 +202,8 @@ clay pierPath king enqueueEv =
|
||||
applySyncAction m (fp, (Just (_, h))) = M.insert fp h m
|
||||
|
||||
-- Changes an action list item into a form injectable into Urbit
|
||||
actionsToInto :: FilePath -> (FilePath, Maybe (Mime, Int)) -> (Path, Maybe Mime)
|
||||
actionsToInto :: FilePath -> (FilePath, Maybe (Mime, Int))
|
||||
-> (Path, Maybe Mime)
|
||||
actionsToInto prefix (fp, mybData) = (p, mybOutData)
|
||||
where
|
||||
p = filePathToPath strippedFp
|
||||
|
||||
@ -5,8 +5,8 @@
|
||||
|
||||
module Vere.Http.Client where
|
||||
|
||||
import Arvo (KingId, Ev(..), BlipEv(..), HttpClientEf(..),
|
||||
HttpClientEv(..), HttpClientReq(..), HttpEvent(..),
|
||||
import Arvo (BlipEv(..), Ev(..), HttpClientEf(..), HttpClientEv(..),
|
||||
HttpClientReq(..), HttpEvent(..), KingId,
|
||||
ResponseHeader(..))
|
||||
import UrbitPrelude hiding (Builder)
|
||||
import Vere.Pier.Types
|
||||
@ -52,15 +52,12 @@ client :: forall e. HasLogFunc e
|
||||
client kingId enqueueEv = ([], runHttpClient)
|
||||
where
|
||||
runHttpClient :: RAcquire e (EffCb e HttpClientEf)
|
||||
runHttpClient = do
|
||||
tim <- mkRAcquire start stop
|
||||
pure (handleEffect tim)
|
||||
runHttpClient = handleEffect <$> mkRAcquire start stop
|
||||
|
||||
start :: RIO e (HttpClientDrv)
|
||||
start = do
|
||||
manager <- io $ H.newManager H.defaultManagerSettings
|
||||
var <- newTVarIO M.empty
|
||||
pure $ HttpClientDrv manager var
|
||||
start = HttpClientDrv <$>
|
||||
(io $ H.newManager H.defaultManagerSettings) <*>
|
||||
newTVarIO M.empty
|
||||
|
||||
stop :: HttpClientDrv -> RIO e ()
|
||||
stop HttpClientDrv{..} = do
|
||||
@ -108,7 +105,8 @@ client kingId enqueueEv = ([], runHttpClient)
|
||||
loop = getChunk >>= \case
|
||||
Nothing -> planEvent id (Continue Nothing True)
|
||||
Just bs -> do
|
||||
planEvent id $ Continue (Just $ File $ Octs bs) False
|
||||
planEvent id $
|
||||
Continue (Just $ File $ Octs bs) False
|
||||
loop
|
||||
planEvent id (Start headers Nothing False)
|
||||
loop
|
||||
@ -124,7 +122,8 @@ client kingId enqueueEv = ([], runHttpClient)
|
||||
describe (Start header Nothing final) =
|
||||
"(Start " ++ (show header) ++ " ~ " ++ (show final)
|
||||
describe (Start header (Just (File (Octs bs))) final) =
|
||||
"(Start " ++ (show header) ++ " (" ++ (show $ length bs) ++ " bytes) " ++ (show final)
|
||||
"(Start " ++ (show header) ++ " (" ++ (show $ length bs) ++ " bytes) " ++
|
||||
(show final)
|
||||
describe (Continue Nothing final) =
|
||||
"(Continue ~ " ++ (show final)
|
||||
describe (Continue (Just (File (Octs bs))) final) =
|
||||
|
||||
@ -148,7 +148,7 @@ pier pierPath mPort (serf, log, ss) = do
|
||||
inst <- io (KingId . UV . fromIntegral <$> randomIO @Word16)
|
||||
|
||||
terminalSystem <- initializeLocalTerminal
|
||||
serf <- pure serf { sStderr = (tsStderr terminalSystem) }
|
||||
swapMVar (sStderr serf) (tsStderr terminalSystem)
|
||||
|
||||
let ship = who (Log.identity log)
|
||||
|
||||
|
||||
@ -11,13 +11,10 @@ module Vere.Serf ( Serf, sStderr, SerfState(..), doJob
|
||||
, Config(..), Flags, Flag(..)
|
||||
) where
|
||||
|
||||
import UrbitPrelude hiding (fail)
|
||||
import UrbitPrelude
|
||||
|
||||
import Arvo
|
||||
import Control.Monad.Fail (fail)
|
||||
import Data.Conduit
|
||||
import Data.Void
|
||||
import Noun
|
||||
import System.Process
|
||||
import System.ProgressBar
|
||||
import Vere.Pier.Types
|
||||
@ -28,7 +25,6 @@ import Data.ByteString.Unsafe (unsafeUseAsCString)
|
||||
import Foreign.Marshal.Alloc (alloca)
|
||||
import Foreign.Ptr (castPtr)
|
||||
import Foreign.Storable (peek, poke)
|
||||
import System.Directory (createDirectoryIfMissing)
|
||||
import System.Exit (ExitCode)
|
||||
|
||||
import qualified Data.ByteString.Unsafe as BS
|
||||
@ -79,10 +75,8 @@ ssLastEv = pred . ssNextEv
|
||||
data Serf e = Serf
|
||||
{ sendHandle :: Handle
|
||||
, recvHandle :: Handle
|
||||
, errThread :: Async ()
|
||||
, process :: ProcessHandle
|
||||
, sState :: MVar SerfState
|
||||
, sStderr :: Text -> RIO e ()
|
||||
, sStderr :: MVar (Text -> RIO e ())
|
||||
}
|
||||
|
||||
data ShipId = ShipId Ship Bool
|
||||
@ -127,9 +121,9 @@ deriveNoun ''Plea
|
||||
|
||||
-- Utils -----------------------------------------------------------------------
|
||||
|
||||
printTank :: HasLogFunc e => (Text -> RIO e ()) -> Word32 -> Tank -> RIO e ()
|
||||
printTank :: HasLogFunc e => MVar (Text -> RIO e ()) -> Word32 -> Tank -> RIO e ()
|
||||
printTank log _pri tank =
|
||||
(log . unlines . fmap unTape . wash (WashCfg 0 80)) tank
|
||||
((printErr log) . unlines . fmap unTape . wash (WashCfg 0 80)) tank
|
||||
|
||||
guardExn :: (Exception e, MonadIO m) => Bool -> e -> m ()
|
||||
guardExn ok = io . unless ok . throwIO
|
||||
@ -138,6 +132,10 @@ fromRightExn :: (Exception e, MonadIO m) => Either a b -> (a -> e) -> m b
|
||||
fromRightExn (Left m) exn = throwIO (exn m)
|
||||
fromRightExn (Right x) _ = pure x
|
||||
|
||||
printErr :: MVar (Text -> RIO e ()) -> Text -> RIO e ()
|
||||
printErr m txt = do
|
||||
f <- readMVar m
|
||||
f txt
|
||||
|
||||
-- Process Management ----------------------------------------------------------
|
||||
|
||||
@ -153,9 +151,9 @@ startUp conf@(Config pierPath flags) = do
|
||||
(Just i, Just o, Just e, p) <- createProcess pSpec
|
||||
pure (i, o, e, p)
|
||||
|
||||
ss <- newEmptyMVar
|
||||
et <- async (readStdErr e)
|
||||
pure (Serf i o et p ss serf)
|
||||
stderr <- newMVar putStrLn
|
||||
async (readStdErr e stderr)
|
||||
pure (Serf i o p stderr)
|
||||
where
|
||||
diskKey = ""
|
||||
config = show (compileFlags flags)
|
||||
@ -166,11 +164,13 @@ startUp conf@(Config pierPath flags) = do
|
||||
, std_err = CreatePipe
|
||||
}
|
||||
|
||||
readStdErr :: ∀e. HasLogFunc e => Handle -> RIO e ()
|
||||
readStdErr h =
|
||||
readStdErr :: ∀e. HasLogFunc e => Handle -> MVar (Text -> RIO e ()) -> RIO e ()
|
||||
readStdErr h print =
|
||||
untilEOFExn $ do
|
||||
ln <- io $ IO.hGetLine h
|
||||
serf ("[stderr] " <> T.strip (pack ln))
|
||||
raw <- io $ IO.hGetLine h
|
||||
let ln = T.strip (pack raw)
|
||||
printErr print ln
|
||||
serf ("[stderr] " <> ln)
|
||||
where
|
||||
eofMsg = "[Serf.readStdErr] serf stderr closed"
|
||||
|
||||
@ -296,7 +296,7 @@ recvPlea w = do
|
||||
n <- fromRightExn (cue a) (const $ BadPleaAtom a)
|
||||
p <- fromRightExn (fromNounErr n) (\(p,m) -> BadPleaNoun (traceShowId n) p m)
|
||||
|
||||
case p of PStdr e msg -> do (sStderr w) (cordText msg)
|
||||
case p of PStdr e msg -> do printErr (sStderr w) (cordText msg)
|
||||
recvPlea w
|
||||
PSlog _ pri t -> do printTank (sStderr w) pri t
|
||||
recvPlea w
|
||||
@ -343,7 +343,7 @@ sendWork w job =
|
||||
PPlay p -> throwIO (UnexpectedPlay eId p)
|
||||
PDone i m o -> produce (SerfState (i+1) m, o)
|
||||
PWork work -> replace (DoWork work)
|
||||
PStdr _ cord -> (sStderr w) (cordText cord) >> loop
|
||||
PStdr _ cord -> printErr (sStderr w) (cordText cord) >> loop
|
||||
PSlog _ pri t -> printTank (sStderr w) pri t >> loop
|
||||
|
||||
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
module Vere.Term (initializeLocalTerminal, term, TerminalSystem(..)) where
|
||||
|
||||
import Arvo hiding (Term)
|
||||
import UrbitPrelude
|
||||
import Arvo hiding (Term)
|
||||
import Vere.Pier.Types
|
||||
|
||||
import Data.Char
|
||||
@ -11,12 +11,15 @@ import Foreign.Storable
|
||||
import System.Posix.IO
|
||||
import System.Posix.Terminal
|
||||
|
||||
import System.Console.Terminfo.Base
|
||||
import RIO.Directory (createDirectoryIfMissing)
|
||||
import RIO.Directory (createDirectoryIfMissing)
|
||||
import RIO.FilePath
|
||||
import System.Console.Terminfo.Base
|
||||
|
||||
import Data.ByteString.Internal
|
||||
|
||||
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
|
||||
@ -29,9 +32,11 @@ data LineState = LineState String Int
|
||||
|
||||
-- A record used in reading data from stdInput.
|
||||
data ReadData = ReadData
|
||||
{ rdBuf :: Ptr Word8
|
||||
, rdEscape :: Bool
|
||||
, rdBracket :: Bool
|
||||
{ rdBuf :: Ptr Word8
|
||||
, rdEscape :: Bool
|
||||
, rdBracket :: Bool
|
||||
, rdUTF8 :: ByteString
|
||||
, rdUTF8width :: Int
|
||||
}
|
||||
|
||||
-- Minimal terminal interface.
|
||||
@ -41,15 +46,15 @@ data ReadData = ReadData
|
||||
-- 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 ()
|
||||
{ tsReadQueue :: TQueue Belt
|
||||
, tsWriteQueue :: TQueue VereOutput
|
||||
, tsStderr :: Text -> RIO e ()
|
||||
}
|
||||
|
||||
-- Private data to the TerminalSystem that we keep around for stop().
|
||||
data Private = Private
|
||||
{ pReaderThread :: Async ()
|
||||
, pWriterThread :: Async ()
|
||||
{ pReaderThread :: Async ()
|
||||
, pWriterThread :: Async ()
|
||||
, pPreviousConfiguration :: TerminalAttributes
|
||||
}
|
||||
|
||||
@ -67,7 +72,7 @@ initialHail = EvBlip $ BlipEvTerm $ TermEvHail (UD 1, ()) ()
|
||||
runMaybeTermOutput :: Terminal -> (Terminal -> Maybe TermOutput) -> RIO e ()
|
||||
runMaybeTermOutput t getter = case (getter t) of
|
||||
Nothing -> pure ()
|
||||
Just x -> io $ runTermOutput t x
|
||||
Just x -> io $ runTermOutput t x
|
||||
|
||||
rioAllocaBytes :: (MonadIO m, MonadUnliftIO m)
|
||||
=> Int -> (Ptr a -> m b) -> m b
|
||||
@ -113,7 +118,8 @@ initializeLocalTerminal = do
|
||||
io $ setTerminalAttributes stdInput newTermSettings Immediately
|
||||
|
||||
tsReadQueue <- newTQueueIO
|
||||
pReaderThread <- asyncBound (readTerminal tsReadQueue tsWriteQueue (bell tsWriteQueue))
|
||||
pReaderThread <- asyncBound
|
||||
(readTerminal tsReadQueue tsWriteQueue (bell tsWriteQueue))
|
||||
|
||||
let tsStderr = \txt ->
|
||||
atomically $ writeTQueue tsWriteQueue $ VerePrintOutput $ unpack txt
|
||||
@ -249,12 +255,13 @@ initializeLocalTerminal = do
|
||||
readTerminal :: forall e. HasLogFunc e
|
||||
=> TQueue Belt -> TQueue VereOutput -> (RIO e ()) -> RIO e ()
|
||||
readTerminal rq wq bell =
|
||||
rioAllocaBytes 1 $ \ buf -> loop (ReadData buf False False)
|
||||
rioAllocaBytes 1 $ \ buf -> loop (ReadData buf False False B.empty 0)
|
||||
where
|
||||
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.
|
||||
-- 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.
|
||||
--
|
||||
t <- io $ try (fdReadBuf stdInput rdBuf 1)
|
||||
case t of
|
||||
@ -289,10 +296,18 @@ initializeLocalTerminal = do
|
||||
else do
|
||||
bell
|
||||
loop rd { rdEscape = False }
|
||||
-- if not escape
|
||||
else if False then
|
||||
-- TODO: Put the unicode accumulation logic here.
|
||||
loop rd
|
||||
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
|
||||
case UTF8.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 }
|
||||
else if w >= 32 && w < 127 then do
|
||||
sendBelt $ Txt $ Tour $ [c]
|
||||
loop rd
|
||||
@ -319,7 +334,10 @@ initializeLocalTerminal = do
|
||||
loop rd { rdEscape = True }
|
||||
else do
|
||||
-- start the utf8 accumulation buffer
|
||||
loop rd
|
||||
loop rd { rdUTF8 = singleton w,
|
||||
rdUTF8width = if w < 224 then 2
|
||||
else if w < 240 then 3
|
||||
else 4 }
|
||||
|
||||
sendBelt :: HasLogFunc e => Belt -> RIO e ()
|
||||
sendBelt b = do
|
||||
@ -366,8 +384,8 @@ term TerminalSystem{..} shutdownSTM pierPath king enqueueEv =
|
||||
|
||||
handleFsWrite :: Blit -> RIO e ()
|
||||
handleFsWrite (Sag path noun) = performPut path (jamBS noun)
|
||||
handleFsWrite (Sav path atom) = pure () --performPut path atom
|
||||
handleFsWrite _ = pure ()
|
||||
handleFsWrite (Sav path atom) = performPut path (atom ^. atomBytes)
|
||||
handleFsWrite _ = pure ()
|
||||
|
||||
performPut :: Path -> ByteString -> RIO e ()
|
||||
performPut path bs = do
|
||||
|
||||
@ -90,6 +90,7 @@ dependencies:
|
||||
- unliftio
|
||||
- unliftio-core
|
||||
- unordered-containers
|
||||
- utf8-string
|
||||
- vector
|
||||
- wai
|
||||
- wai-conduit
|
||||
|
||||
Loading…
Reference in New Issue
Block a user