From 14168a41fe16c160e7c6c0a3fb63266e35bcbd55 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 19 Aug 2020 19:24:05 +0200 Subject: [PATCH] Lala --- app/ghcup-gen/Validate.hs | 3 +- app/ghcup/BrickMain.hs | 157 +++++++++++++++------ app/ghcup/Main.hs | 2 +- ghcup.cabal | 1 + lib/GHCup.hs | 4 - lib/GHCup/Download/IOStreams.hs | 1 + lib/GHCup/Types.hs | 29 ++++ lib/GHCup/Utils.hs | 2 +- lib/GHCup/Utils/File.hs | 236 +++++++++++++++++--------------- 9 files changed, 269 insertions(+), 166 deletions(-) diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index 9c4b7d0..5794896 100644 --- a/app/ghcup-gen/Validate.hs +++ b/app/ghcup-gen/Validate.hs @@ -8,6 +8,7 @@ import GHCup import GHCup.Download import GHCup.Types import GHCup.Utils.Dirs +import GHCup.Utils.File import GHCup.Utils.Logger import GHCup.Utils.Version.QQ @@ -192,7 +193,7 @@ validateTarballs dls = do where downloadAll dli = do dirs <- liftIO getDirs - let settings = Settings True False Never Curl False dirs + let settings = Settings True False Never Curl False dirs defExecCb let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True , colorOutter = B.hPut stderr , rawOutter = (\_ -> pure ()) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index b843976..0c47408 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -14,8 +14,10 @@ import GHCup.Types import GHCup.Utils import GHCup.Utils.File import GHCup.Utils.Logger +import GHCup.Utils.Prelude import Brick +import Brick.BChan import Brick.Widgets.Border import Brick.Widgets.Border.Style import Brick.Widgets.Center @@ -23,11 +25,14 @@ import Brick.Widgets.List #if !defined(TAR) import Codec.Archive #endif +import Control.Concurrent +import Control.Concurrent.MVar import Control.Exception.Safe import Control.Monad.Logger import Control.Monad.Reader import Control.Monad.Trans.Resource import Data.Bool +import Data.ByteString ( ByteString ) import Data.Functor import Data.List import Data.Maybe @@ -37,22 +42,40 @@ import Data.String.Interpolate import Data.Vector ( Vector ) import Data.Versions hiding ( str ) import Haskus.Utils.Variant.Excepts -import Prelude hiding ( appendFile ) +import HPath +import HPath.IO hiding ( hideError ) +import Prelude hiding ( abs, appendFile, writeFile ) import System.Exit import System.IO.Unsafe +import System.Posix.Types import URI.ByteString import qualified Data.Text as T import qualified Graphics.Vty as Vty import qualified Data.Vector as V +import qualified "unix-bytestring" System.Posix.IO.ByteString + as SPIB +data SubProcess = SubProcess { + procName :: String + , exited :: Maybe (Either ProcessError ()) + , procId :: Maybe ProcessID + , logLine :: Maybe ByteString +} data AppState = AppState { - lr :: LR - , dls :: GHCupDownloads + lr :: LR + , dls :: GHCupDownloads , pfreq :: PlatformRequest + + , mproc :: Maybe SubProcess } +data MyAppEvent = LogLine ByteString + | StartProc String + | GotProcId ProcessID + | EndProc (Either ProcessError ()) + type LR = GenericList String Vector ListResult @@ -68,21 +91,28 @@ keyHandlers = ui :: AppState -> Widget String ui AppState {..} = - ( padBottom Max - $ ( withBorderStyle unicode - $ borderWithLabel (str "GHCup") - $ (center $ renderList renderItem True lr) - ) - ) - <=> ( withAttr "help" - . txtWrap - . T.pack - . foldr1 (\x y -> x <> " " <> y) - . (++ ["↑↓:Navigation"]) - $ (fmap (\(c, s, _) -> (c : ':' : s)) keyHandlers) - ) + case mproc of + Just _ -> logDialog + Nothing -> + ( padBottom Max + $ ( withBorderStyle unicode + $ borderWithLabel (str "GHCup") + $ (center $ renderList renderItem True lr) + ) + ) + <=> ( withAttr "help" + . txtWrap + . T.pack + . foldr1 (\x y -> x <> " " <> y) + . (++ ["↑↓:Navigation"]) + $ (fmap (\(c, s, _) -> (c : ':' : s)) keyHandlers) + ) where + logDialog = case mproc of + Nothing -> emptyWidget + Just (SubProcess name Nothing _ (Just logLine)) -> centerLayer . txtWrap . decUTF8Safe $ logLine + Just (SubProcess name Nothing _ (Just logLine)) -> centerLayer . txtWrap $ "" renderItem b ListResult {..} = let marks = if | lSet -> (withAttr "set" $ str "✔✔") @@ -121,7 +151,7 @@ minHSize :: Int -> Widget n -> Widget n minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ') -app :: App AppState e String +app :: App AppState MyAppEvent String app = App { appDraw = \st -> [ui st] , appHandleEvent = eventHandler , appStartEvent = return @@ -152,19 +182,33 @@ dimAttributes = attrMap -eventHandler :: AppState -> BrickEvent n e -> EventM n (Next AppState) +eventHandler :: AppState -> BrickEvent n MyAppEvent -> EventM n (Next AppState) eventHandler st (VtyEvent (Vty.EvResize _ _)) = continue st eventHandler st (VtyEvent (Vty.EvKey (Vty.KChar 'q') _)) = halt st eventHandler st (VtyEvent (Vty.EvKey Vty.KEsc _)) = halt st eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) = - continue (AppState (listMoveUp lr) dls pfreq) + continue (AppState (listMoveUp lr) dls pfreq mproc) eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) = - continue (AppState (listMoveDown lr) dls pfreq) + continue (AppState (listMoveDown lr) dls pfreq mproc) eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) = case find (\(c', _, _) -> c' == c) keyHandlers of Nothing -> continue as Just (_, _, handler) -> handler as -eventHandler st _ = continue st +eventHandler st (AppEvent (StartProc str')) = continue st + { mproc = Just SubProcess { procName = str' + , exited = Nothing + , procId = Nothing + , logLine = Nothing + } + } +eventHandler st@AppState { mproc = Just sp } (AppEvent (GotProcId pid)) = + continue st { mproc = Just sp { procId = Just pid } } +eventHandler st@AppState { mproc = Just sp } (AppEvent (EndProc exited)) = + continue st { mproc = Just sp { exited = Just exited, procId = Nothing } } +eventHandler st@AppState { mproc = Just sp } (AppEvent (LogLine bs)) = + continue st { mproc = Just sp { logLine = Just bs } } +eventHandler st (AppEvent _) = error "noes" -- TODO +eventHandler st _ = continue st -- | Suspend the current UI and run an IO action in terminal. If the @@ -174,19 +218,18 @@ withIOAction :: (AppState -> (Int, ListResult) -> IO (Either String a)) -> EventM n (Next AppState) withIOAction action as = case listSelectedElement (lr as) of Nothing -> continue as - Just (ix, e) -> suspendAndResume $ do - action as (ix, e) >>= \case - Left err -> putStrLn $ ("Error: " <> err) - Right _ -> putStrLn "Success" - apps <- (fmap . fmap) - (\AppState {..} -> AppState { lr = listMoveTo ix lr, .. }) - $ getAppState Nothing (pfreq as) - case apps of - Right nas -> do - putStrLn "Press enter to continue" - _ <- getLine - pure nas - Left err -> throwIO $ userError err + Just (ix, e) -> do + liftIO $ forkIO $ void $ action as (ix, e) + continue as + -- apps <- (fmap . fmap) + -- (\AppState {..} -> AppState { lr = listMoveTo ix lr, .. }) + -- $ getAppState Nothing (pfreq as) + -- case apps of + -- Right nas -> do + -- putStrLn "Press enter to continue" + -- _ <- getLine + -- pure nas + -- Left err -> throwIO $ userError err install' :: AppState -> (Int, ListResult) -> IO (Either String ()) @@ -302,12 +345,13 @@ settings' :: IORef Settings settings' = unsafePerformIO $ do dirs <- getDirs newIORef Settings { cache = True - , noVerify = False - , keepDirs = Never - , downloader = Curl - , verbose = False - , .. - } + , noVerify = False + , keepDirs = Never + , downloader = Curl + , verbose = False + , execCb = (\_ _ _ _ _ -> liftIO $ writeFile [abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "settings'") + , .. + } logger' :: IORef LoggerConfig @@ -321,16 +365,22 @@ logger' = unsafePerformIO brickMain :: Settings -> Maybe URI -> LoggerConfig -> GHCupDownloads -> PlatformRequest -> IO () -brickMain s muri l av pfreq' = do +brickMain _ muri _ av pfreq' = do writeIORef uri' muri - writeIORef settings' s + s <- readIORef settings' -- logger interpreter - writeIORef logger' l + -- writeIORef logger' l + l <- readIORef logger' let runLogger = myLoggerT l eApps <- getAppState (Just av) pfreq' case eApps of - Right as -> defaultMain app (selectLatest as) $> () + Right as -> do + eventChan <- newBChan 1000 + let builder = Vty.mkVty Vty.defaultConfig + initialVty <- builder + writeIORef settings' s{ execCb = brickExecCb eventChan } + customMain initialVty builder (Just eventChan) app (selectLatest as) $> () Left e -> do runLogger ($(logError) [i|Error building app state: #{show e}|]) exitWith $ ExitFailure 2 @@ -359,8 +409,25 @@ getAppState mg pfreq' = do dls <- maybe (fmap _ghcupDownloads $ liftE $ getDownloadsF (maybe GHCupURL OwnSource muri)) pure mg lV <- lift $ listVersions dls Nothing Nothing pfreq' - pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls pfreq') + pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls pfreq' Nothing) case r of VRight a -> pure $ Right a VLeft e -> pure $ Left [i|#{e}|] + + +brickExecCb :: BChan MyAppEvent -> ExecCb +brickExecCb chan _ fileFd stdoutRead pState lfile = do + liftIO $ writeFile [abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "brickExecCb" + writeBChan chan (StartProc . T.unpack . decUTF8Safe $ lfile) + readLineTilEOF lineAction stdoutRead + takeMVar pState >>= \case + PExited e@(Left _) -> writeBChan chan (EndProc e) + _ -> error "no" + where + lineAction bs = do + void $ SPIB.fdWrite fileFd (bs <> "\n") + error "blah" + writeBChan chan (LogLine bs) + + diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 9116ae8..8126735 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -831,7 +831,7 @@ toSettings Options {..} = do downloader = optsDownloader verbose = optVerbose dirs <- getDirs - pure $ Settings { .. } + pure $ Settings { execCb = (\_ _ _ _ _ -> liftIO $ HPath.IO.writeFile [HPath.abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "toSettings"), ..} upgradeOptsP :: Parser UpgradeOpts diff --git a/ghcup.cabal b/ghcup.cabal index 120723e..19c4521 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -364,6 +364,7 @@ executable ghcup , table-layout , template-haskell , text + , unix-bytestring , uri-bytestring , utf8-string , versions diff --git a/lib/GHCup.hs b/lib/GHCup.hs index c78b22c..93cd295 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -154,7 +154,6 @@ installGHCBindist dlinfo ver (PlatformRequest {..}) = do lEM $ execLogged "./configure" False (["--prefix=" <> toFilePath inst] ++ alpineArgs) - [rel|ghc-configure|] (Just path) Nothing lEM $ make ["install"] (Just path) @@ -857,7 +856,6 @@ Stage1Only = YES|] ) ++ fmap E.encodeUtf8 aargs ) - [rel|ghc-conf|] (Just workdir) (Just (("GHC", toFilePath bghcPath) : cEnv)) | otherwise -> do @@ -873,7 +871,6 @@ Stage1Only = YES|] ) ++ fmap E.encodeUtf8 aargs ) - [rel|ghc-conf|] (Just workdir) (Just cEnv) @@ -1031,7 +1028,6 @@ compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do lEM $ execLogged "./bootstrap.sh" False (maybe [] (\j -> ["-j", fS (show j)]) jobs) - [rel|cabal-bootstrap|] (Just workdir) (Just newEnv) pure $ (tmp [rel|bin/cabal|]) diff --git a/lib/GHCup/Download/IOStreams.hs b/lib/GHCup/Download/IOStreams.hs index 272bb0e..74c1adc 100644 --- a/lib/GHCup/Download/IOStreams.hs +++ b/lib/GHCup/Download/IOStreams.hs @@ -13,6 +13,7 @@ module GHCup.Download.IOStreams where import GHCup.Download.Utils import GHCup.Errors +import GHCup.Types import GHCup.Types.Optics import GHCup.Types.JSON ( ) import GHCup.Utils.File diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index acdd482..2260388 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -1,6 +1,10 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-| Module : GHCup.Types @@ -13,11 +17,14 @@ Portability : POSIX -} module GHCup.Types where +import Control.Concurrent.MVar +import Data.ByteString ( ByteString ) import Data.Map.Strict ( Map ) import Data.Text ( Text ) import Data.Versions import HPath import URI.ByteString +import System.Posix.Types import qualified GHC.Generics as GHC @@ -163,6 +170,27 @@ data URLSource = GHCupURL deriving Show +data ProcessError = NonZeroExit Int ByteString [ByteString] + | PTerminated ByteString [ByteString] + | PStopped ByteString [ByteString] + | NoSuchPid ByteString [ByteString] + deriving (Eq, Show) + +data ProcState = PRunning ProcessID + | PExited (Either ProcessError ()) + deriving Eq + +type ExecCb = Bool -- verbose + -> Fd -- log file fd + -> Fd -- input fd to read from + -> MVar ProcState -- state of the producing process + -> ByteString -- log filename + -> IO () + +instance Show ExecCb where + show _ = "**ExecCb**" + + data Settings = Settings { -- set by user cache :: Bool @@ -173,6 +201,7 @@ data Settings = Settings -- set on app start , dirs :: Dirs + , execCb :: ExecCb } deriving Show diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index e06e876..ce9968c 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -550,7 +550,7 @@ make args workdir = do spaths <- catMaybes . fmap parseAbs <$> (liftIO getSearchPath) has_gmake <- isJust <$> (liftIO $ searchPath spaths [rel|gmake|]) let mymake = if has_gmake then "gmake" else "make" - execLogged mymake True args [rel|ghc-make|] workdir Nothing + execLogged mymake True args workdir Nothing -- | Try to apply patches in order. Fails with 'PatchFailed' diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Utils/File.hs index 928390b..bcc3a97 100644 --- a/lib/GHCup/Utils/File.hs +++ b/lib/GHCup/Utils/File.hs @@ -72,14 +72,6 @@ import qualified "unix-bytestring" System.Posix.IO.ByteString as SPIB - -data ProcessError = NonZeroExit Int ByteString [ByteString] - | PTerminated ByteString [ByteString] - | PStopped ByteString [ByteString] - | NoSuchPid ByteString [ByteString] - deriving Show - - data CapturedProcess = CapturedProcess { _exitCode :: ExitCode , _stdOut :: ByteString @@ -121,30 +113,31 @@ execLogged :: (MonadReader Settings m, MonadIO m, MonadThrow m) => ByteString -- ^ thing to execute -> Bool -- ^ whether to search PATH for the thing -> [ByteString] -- ^ args for the thing - -> Path Rel -- ^ log filename -> Maybe (Path Abs) -- ^ optionally chdir into this -> Maybe [(ByteString, ByteString)] -- ^ optional environment -> m (Either ProcessError ()) -execLogged exe spath args lfile chdir env = do +execLogged exe spath args chdir env = do Settings {dirs = Dirs {..}, ..} <- ask - logfile <- (logsDir ) <$> parseRel (toFilePath lfile <> ".log") + logfile <- (logsDir ) <$> parseRel (lfile <> ".log") liftIO $ bracket (createFile (toFilePath logfile) newFilePerms) closeFd - (action verbose) + (action verbose execCb) where - action verbose fd = do + lfile = fromMaybe exe $ BS.stripPrefix "./" exe + + action verbose cb fd = do actionWithPipes $ \(stdoutRead, stdoutWrite) -> do -- start the thread that logs to stdout - pState <- newEmptyMVar - done <- newEmptyMVar + pState <- newEmptyMVar + done <- newEmptyMVar + liftIO $ HPath.IO.writeFile [HPath.abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "execLogged1" void $ forkIO $ EX.handle (\(_ :: IOException) -> pure ()) $ flip EX.finally (putMVar done ()) - $ (if verbose - then tee fd stdoutRead - else printToRegion fd stdoutRead 6 pState - ) + $ (do + liftIO $ HPath.IO.writeFile [HPath.abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "execLogged" + cb verbose fd stdoutRead pState lfile) -- fork the subprocess pid <- SPPB.forkProcess $ do @@ -157,115 +150,57 @@ execLogged exe spath args lfile chdir env = do maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir void $ SPPB.executeFile exe spath args env + putMVar pState (PRunning pid) + closeFd stdoutWrite -- wait for the subprocess to finish e <- toProcessError exe args <$!> SPPB.getProcessStatus True True pid - putMVar pState (either (const False) (const True) e) + void $ swapMVar pState (PExited e) void $ race (takeMVar done) (threadDelay (1000000 * 3)) closeFd stdoutRead pure e - 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") +readLineTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m () +readLineTilEOF ~action' fd' = go mempty + where + go bs' = do + (bs, rest, eof) <- readLine fd' bs' + if eof + then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing) + else (void $ action' bs) >> go rest - -- Reads fdIn and logs the output in a continous scrolling area - -- of 'size' terminal lines. Also writes to a log file. - 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 - (\(ex :: SomeException) -> do - ps <- liftIO $ takeMVar pState - when (ps == True) (forM_ rs (liftIO . closeConsoleRegion)) - throw ex - ) - $ readTilEOF (lineAction rs) fdIn - where - -- action to perform line by line - -- TODO: do this with vty for efficiency - 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 +-- Consecutively read from Fd in 512 chunks until we hit +-- newline or EOF. +readLine :: MonadIO m + => Fd -- ^ input file descriptor + -> ByteString -- ^ rest buffer (read across newline) + -> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof) +readLine fd = \inBs -> go inBs + where + go inBs = do + -- if buffer is not empty, process it first + mbs <- if BS.length inBs == 0 + -- otherwise attempt read + then liftIO + $ handleIO (\e -> if isEOFError e then pure Nothing else ioError e) + $ fmap Just + $ SPIB.fdRead fd 512 + else pure $ Just inBs + case mbs of + Nothing -> pure ("", "", True) + Just bs -> do + -- split on newline + let (line, rest) = BS.span (/= _lf) bs + if + | BS.length rest /= 0 -> pure (line, BS.tail rest, False) + -- if rest is empty, then there was no newline, process further + | otherwise -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty - 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 :: Int -> ByteString -> ByteString - trim w = \bs -> if - | BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..." - | otherwise -> bs - - -- Consecutively read from Fd in 512 chunks until we hit - -- newline or EOF. - readLine :: MonadIO m - => Fd -- ^ input file descriptor - -> ByteString -- ^ rest buffer (read across newline) - -> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof) - readLine fd = \inBs -> go inBs - where - go inBs = do - -- if buffer is not empty, process it first - mbs <- if BS.length inBs == 0 - -- otherwise attempt read - then liftIO - $ handleIO (\e -> if isEOFError e then pure Nothing else ioError e) - $ fmap Just - $ SPIB.fdRead fd 512 - else pure $ Just inBs - case mbs of - Nothing -> pure ("", "", True) - Just bs -> do - -- split on newline - let (line, rest) = BS.span (/= _lf) bs - if - | BS.length rest /= 0 -> pure (line, BS.tail rest, False) - -- if rest is empty, then there was no newline, process further - | otherwise -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty - - readTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m () - readTilEOF ~action' fd' = go mempty - where - go bs' = do - (bs, rest, eof) <- readLine fd' bs' - if eof - then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing) - else (void $ action' bs) >> go rest -- | Capture the stdout and stderr of the given action, which @@ -450,3 +385,76 @@ chmod_777 (toFilePath -> fp) = do $(logDebug) [i|chmod 777 #{fp}|] liftIO $ setFileMode fp exe_mode + +-- | The default callback for logging/printing on 'execLogged'. +defExecCb :: ExecCb +defExecCb verbose fd stdoutRead pState lfile = if verbose + then tee fd stdoutRead + else printToRegion fd stdoutRead 6 + where + tee :: Fd -> Fd -> IO () + tee fileFd fdIn = readLineTilEOF 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 :: Fd -> Fd -> Int -> IO () + printToRegion fileFd fdIn size = do + void $ displayConsoleRegions $ do + rs <- + liftIO + . fmap Sq.fromList + . sequence + . replicate size + . openConsoleRegion + $ Linear + flip runStateT mempty + $ handle + (\(ex :: SomeException) -> do + let closeEventually = readMVar pState >>= \case + PExited (Right _) -> forM_ rs (liftIO . closeConsoleRegion) + _ -> threadDelay 500 >> closeEventually + void $ liftIO $ race closeEventually (threadDelay (1000000 * 3)) + throw ex + ) + $ readLineTilEOF (lineAction rs) fdIn + + where + -- action to perform line by line + -- TODO: do this with vty for efficiency + 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 -> "[ " <> lfile <> " ] " <> b) + $ 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 :: Int -> ByteString -> ByteString + trim w = \bs -> if + | BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..." + | otherwise -> bs + +