Merge pull request #1740 from urbit/king-cleanup

Further terminal fixes and cleanups

pkg/king/lib/Vere/Clay.hs

@@ -106,12 +106,8 @@ clay pierPath king enqueueEv =
       ]
 
     runSync :: RAcquire e (EffCb e SyncEf)
-    runSync = do
+    runSync = handleEffect <$> mkRAcquire start stop
-      tim <- mkRAcquire start stop
-      pure (handleEffect tim)
 
-    -- 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.
+    -- Change the structures off of the event into something we can work with
-    calculateActionHash :: FilePath -> (Path, Maybe Mime) -> (FilePath, Maybe (Mime, Int))
+    -- 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 =
+        | skip = logDebug $
-            logDebug $ displayShow ("(clay) skipping unchanged file update " , fp)
+                 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

pkg/king/lib/Vere/Http/Client.hs

@@ -5,8 +5,8 @@
 
 module Vere.Http.Client where
 
-import Arvo            (KingId, Ev(..), BlipEv(..), HttpClientEf(..),
+import Arvo            (BlipEv(..), Ev(..), HttpClientEf(..), HttpClientEv(..),
-                        HttpClientEv(..), HttpClientReq(..), HttpEvent(..),
+                        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
+    runHttpClient = handleEffect <$> mkRAcquire start stop
-      tim <- mkRAcquire start stop
-      pure (handleEffect tim)
 
     start :: RIO e (HttpClientDrv)
-    start = do
+    start = HttpClientDrv <$>
-      manager <- io $ H.newManager H.defaultManagerSettings
+      (io $ H.newManager H.defaultManagerSettings) <*>
-      var <- newTVarIO M.empty
+      newTVarIO M.empty
-      pure $ HttpClientDrv manager var
 
     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) =

pkg/king/lib/Vere/Pier.hs

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

pkg/king/lib/Vere/Serf.hs

@@ -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    :: MVar (Text -> RIO e ())
-  , sStderr    :: 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
+    stderr <- newMVar putStrLn
-    et <- async (readStdErr e)
+    async (readStdErr e stderr)
-    pure (Serf i o et p ss serf)
+    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 :: ∀e. HasLogFunc e => Handle -> MVar (Text -> RIO e ()) -> RIO e ()
-readStdErr h =
+readStdErr h print =
     untilEOFExn $ do
-        ln <- io $ IO.hGetLine h
+        raw <- io $ IO.hGetLine h
-        serf ("[stderr] " <> T.strip (pack ln))
+        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
 
 

pkg/king/lib/Vere/Term.hs

@@ -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
+  { rdBuf       :: Ptr Word8
-  , rdEscape :: Bool
+  , rdEscape    :: Bool
-  , rdBracket :: 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
+  { tsReadQueue  :: TQueue Belt
-  , tsWriteQueue   :: TQueue VereOutput
+  , tsWriteQueue :: TQueue VereOutput
-  , tsStderr       :: Text -> RIO e ()
+  , tsStderr     :: Text -> RIO e ()
   }
 
 -- Private data to the TerminalSystem that we keep around for stop().
 data Private = Private
-  { pReaderThread :: Async ()
+  { pReaderThread          :: Async ()
-  , pWriterThread :: 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
+          -- The problem with using fdRead raw is that it will text encode
-          -- like \ESC instead of 27. That makes it broken for our purposes.
+          -- 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 rdUTF8width /= 0 then do
-              else if False then
+                -- continue reading into the utf8 accumulation buffer
-                -- TODO: Put the unicode accumulation logic here.
+                rd@ReadData{..} <- pure rd { rdUTF8 = snoc rdUTF8 w }
-                loop rd
+                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 (Sav path atom) = performPut path (atom ^. atomBytes)
-    handleFsWrite _ = pure ()
+    handleFsWrite _               = pure ()
 
     performPut :: Path -> ByteString -> RIO e ()
     performPut path bs = do

pkg/king/package.yaml

@@ -90,6 +90,7 @@ dependencies:
   - unliftio
   - unliftio-core
   - unordered-containers
+  - utf8-string
   - vector
   - wai
   - wai-conduit