From 0f69c73e0e1b5cb879b3d5e81e9528bc771e28f7 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 15 Jul 2020 15:00:59 +0200 Subject: [PATCH] Rework printing/tee This should be faster to draw, use less syscalls and generally use EOF and pipes correctly. --- lib/GHCup.hs | 2 +- lib/GHCup/Download.hs | 2 +- lib/GHCup/Utils.hs | 2 +- lib/GHCup/Utils/File.hs | 166 ++++++++++++++++++++++--------------- lib/GHCup/Utils/Prelude.hs | 5 ++ 5 files changed, 106 insertions(+), 71 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 7bc9f1b..90bbe99 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -50,7 +50,7 @@ import Data.Versions import Data.Word8 import GHC.IO.Exception import HPath -import HPath.IO +import HPath.IO hiding ( hideError ) import Haskus.Utils.Variant.Excepts import Optics import Prelude hiding ( abs diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 074891d..0d655a8 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -50,7 +50,7 @@ import Data.Versions import Data.Word8 import GHC.IO.Exception import HPath -import HPath.IO as HIO +import HPath.IO as HIO hiding ( hideError ) import Haskus.Utils.Variant.Excepts import Optics import Prelude hiding ( abs diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 8a9f5f3..39e22a2 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -45,7 +45,7 @@ import Data.Versions import Data.Word8 import GHC.IO.Exception import HPath -import HPath.IO +import HPath.IO hiding ( hideError ) import Haskus.Utils.Variant.Excepts import Optics import Prelude hiding ( abs diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Utils/File.hs index 90f2b28..142bd87 100644 --- a/lib/GHCup/Utils/File.hs +++ b/lib/GHCup/Utils/File.hs @@ -14,17 +14,20 @@ import Control.Exception ( evaluate ) import Control.Exception.Safe import Control.Monad import Control.Monad.Reader +import Control.Monad.Trans.State.Strict import Data.ByteString ( ByteString ) import Data.Foldable import Data.Functor import Data.IORef import Data.Maybe +import Data.Sequence ( Seq, (|>) ) import Data.Text ( Text ) import Data.Void +import Data.Word8 import GHC.IO.Exception import HPath -import HPath.IO -import Optics +import HPath.IO hiding ( hideError ) +import Optics hiding ((<|), (|>)) import System.Console.Pretty import System.Console.Regions import System.IO.Error @@ -40,6 +43,7 @@ import Text.Regex.Posix import qualified Control.Exception as EX +import qualified Data.Sequence as Sq import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified System.Posix.Process.ByteString @@ -53,6 +57,7 @@ import qualified "unix-bytestring" System.Posix.IO.ByteString + -- | Bool signals whether the regions should be cleaned. data StopThread = StopThread Bool deriving Show @@ -113,115 +118,140 @@ execLogged :: (MonadReader Settings m, MonadIO m, MonadThrow m) -> Maybe [(ByteString, ByteString)] -- ^ optional environment -> m (Either ProcessError ()) execLogged exe spath args lfile chdir env = do - Settings{..} <- ask - ldir <- liftIO ghcupLogsDir - logfile <- (ldir ) <$> parseRel (toFilePath lfile <> ".log") - liftIO $ bracket (createFile (toFilePath logfile) newFilePerms) closeFd (action verbose) + Settings {..} <- ask + ldir <- liftIO ghcupLogsDir + logfile <- (ldir ) <$> parseRel (toFilePath lfile <> ".log") + liftIO $ bracket (createFile (toFilePath logfile) newFilePerms) + closeFd + (action verbose) where action verbose fd = do actionWithPipes $ \(stdoutRead, stdoutWrite) -> do - -- start the thread that logs to stdout in a region - done <- newEmptyMVar - tid <- - forkIO + -- start the thread that logs to stdout + pState <- newEmptyMVar + done <- newEmptyMVar + void + $ forkOS $ EX.handle (\(_ :: StopThread) -> pure ()) $ EX.handle (\(_ :: IOException) -> pure ()) $ flip finally (putMVar done ()) - $ (if verbose then tee fd stdoutRead else printToRegion fd stdoutRead 6) + $ (if verbose + then tee fd stdoutRead + else printToRegion fd stdoutRead 6 pState + ) - -- fork our subprocess + -- fork the subprocess pid <- SPPB.forkProcess $ do void $ dupTo stdoutWrite stdOutput void $ dupTo stdoutWrite stdError - closeFd stdoutWrite closeFd stdoutRead + closeFd stdoutWrite -- execute the action maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir - SPPB.executeFile exe spath args env + void $ SPPB.executeFile exe spath args env closeFd stdoutWrite -- wait for the subprocess to finish - e <- SPPB.getProcessStatus True True pid >>= \case - i@(Just (SPPB.Exited _)) -> pure $ toProcessError exe args i - i -> pure $ toProcessError exe args i + e <- toProcessError exe args <$!> SPPB.getProcessStatus True True pid + putMVar pState (either (const False) (const True) e) - -- make sure the logging thread stops - case e of - Left _ -> EX.throwTo tid (StopThread False) - Right _ -> EX.throwTo tid (StopThread True) takeMVar done - closeFd stdoutRead + pure e - tee fileFd fdIn = do - flip finally (readTilEOF lineAction fdIn) -- make sure the last few lines don't get cut off - $ do - hideError eofErrorType $ readTilEOF lineAction fdIn - forever (threadDelay 5000) + tee :: Fd -> Fd -> IO () + tee fileFd fdIn = readTilEOF lineAction fdIn where + lineAction :: ByteString -> IO () lineAction bs' = do void $ SPIB.fdWrite fileFd (bs' <> "\n") void $ SPIB.fdWrite stdOutput (bs' <> "\n") -- Reads fdIn and logs the output in a continous scrolling area -- of 'size' terminal lines. Also writes to a log file. - printToRegion fileFd fdIn size = do - ref <- newIORef ([] :: [ByteString]) - displayConsoleRegions $ do - rs <- sequence . replicate size . openConsoleRegion $ Linear - flip finally (readTilEOF (lineAction ref rs) fdIn) -- make sure the last few lines don't get cut off + printToRegion :: Fd -> Fd -> Int -> MVar Bool -> IO () + printToRegion fileFd fdIn size pState = do + void $ displayConsoleRegions $ do + rs <- + liftIO + . fmap Sq.fromList + . sequence + . replicate size + . openConsoleRegion + $ Linear + flip runStateT mempty $ handle - (\(StopThread b) -> do - when b (forM_ rs closeConsoleRegion) - EX.throw (StopThread b) + (\(ex :: SomeException) -> do + ps <- liftIO $ takeMVar pState + when (ps == True) (forM_ rs (liftIO . closeConsoleRegion)) + throw ex ) - $ do - hideError eofErrorType $ readTilEOF (lineAction ref rs) fdIn - -- wait for explicit stop from the parent to signal what cleanup to run - forever (threadDelay 5000) + $ readTilEOF (lineAction rs) fdIn where -- action to perform line by line -- TODO: do this with vty for efficiency - lineAction ref rs bs' = do - modifyIORef' ref (swapRegs bs') - regs <- readIORef ref - void $ SPIB.fdWrite fileFd (bs' <> "\n") - forM (zip regs rs) $ \(bs, r) -> do - setConsoleRegion r $ do - w <- consoleWidth - return - . T.pack - . color Blue - . T.unpack - . decUTF8Safe - . trim w - . (\b -> "[ " <> toFilePath lfile <> " ] " <> b) - $ bs + lineAction :: (MonadMask m, MonadIO m) + => Seq ConsoleRegion + -> ByteString + -> StateT (Seq ByteString) m () + lineAction rs = \bs' -> do + void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n") + modify (swapRegs bs') + regs <- get + liftIO $ forM_ (Sq.zip regs rs) $ \(bs, r) -> setConsoleRegion r $ do + w <- consoleWidth + return + . T.pack + . color Blue + . T.unpack + . decUTF8Safe + . trim w + . (\b -> "[ " <> toFilePath lfile <> " ] " <> b) + $ bs - swapRegs bs regs | length regs < size = regs ++ [bs] - | otherwise = tail regs ++ [bs] + swapRegs :: a -> Seq a -> Seq a + swapRegs bs = \regs -> if + | Sq.length regs < size -> regs |> bs + | otherwise -> Sq.drop 1 regs |> bs -- trim output line to terminal width - trim w bs | BS.length bs > w && w > 5 = BS.take (w - 4) bs <> "..." - | otherwise = bs + trim :: Int -> ByteString -> ByteString + trim w = \bs -> if + | BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..." + | otherwise -> bs -- read an entire line from the file descriptor (removes the newline char) - readLine fd' = do - bs <- SPIB.fdRead fd' 1 - if - | bs == "\n" -> pure "" - | bs == "" -> pure "" - | otherwise -> fmap (bs <>) $ readLine fd' + readLine :: MonadIO m => Fd -> ByteString -> m (ByteString, ByteString) + readLine fd = go + where + go inBs = do + bs <- + liftIO + $ handleIO (\e -> if isEOFError e then pure "" else ioError e) + $ SPIB.fdRead fd 512 + let nbs = BS.append inBs bs + (line, rest) = BS.span (/= _lf) nbs + if + | BS.length rest /= 0 -> pure (line, BS.tail rest) + | BS.length line == 0 -> pure (mempty, mempty) + | otherwise -> (\(l, r) -> (line <> l, r)) <$!> go mempty - readTilEOF action' fd' = do - bs <- readLine fd' - void $ action' bs - readTilEOF action' fd' + readTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m () + readTilEOF ~action' fd' = go mempty + where + go bs' = do + (bs, rest) <- readLine fd' bs' + if + | BS.length bs == 0 -> liftIO + $ ioError (mkIOError eofErrorType "" Nothing Nothing) + | otherwise -> do + void $ action' bs + go rest -- | Capture the stdout and stderr of the given action, which diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs index d10b191..3eea58a 100644 --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Utils/Prelude.hs @@ -165,6 +165,11 @@ liftIOException errType ex = . lift +-- | Uses safe-exceptions. +hideError :: (MonadIO m, MonadCatch m) => IOErrorType -> m () -> m () +hideError err = handleIO (\e -> if err == ioeGetErrorType e then pure () else liftIO . ioError $ e) + + hideErrorDef :: [IOErrorType] -> a -> IO a -> IO a hideErrorDef errs def = handleIO (\e -> if ioeGetErrorType e `elem` errs then pure def else ioError e)