Lala

2020-08-27 23:39:47 +02:00
9 changed files with 269 additions and 166 deletions
--- 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 ())
--- 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)
+
+
--- 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
--- a/ghcup.cabal
+++ b/ghcup.cabal
@ -364,6 +364,7 @@ executable ghcup
    , table-layout
    , template-haskell
    , text
+    , unix-bytestring
    , uri-bytestring
    , utf8-string
    , versions
--- 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|])
--- 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
--- 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

--- 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'
--- 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
+
+