Strictify

This commit is contained in:
maralorn 2022-11-21 00:19:58 +01:00
parent eab81666d8
commit 611161fa47
28 changed files with 708 additions and 670 deletions

View File

@ -4,6 +4,7 @@ import Control.Exception qualified as Exception
import Control.Monad.Writer.Strict (WriterT (runWriterT))
import Data.ByteString qualified as ByteString
import Data.Hermes qualified as JSON
import Data.Strict qualified as Strict
import Data.Text.IO (hPutStrLn)
import Data.Time (ZonedTime)
import Data.Version (showVersion)
@ -22,77 +23,77 @@ import NOM.State (NOMV1State (..), ProgressState (..), failedBuilds, fullSummary
import NOM.State.CacheId.Map qualified as CMap
import NOM.Update (detectLocalFinishedBuilds, maintainState, updateStateNixJSONMessage, updateStateNixOldStyleMessage)
import NOM.Update.Monad (UpdateMonad)
import Optics (Lens', gfield, (%), (%~), (.~), (^.), _2)
import Optics (Lens', gfield, (%), (%~), (.~), (^.))
import Optics qualified
import Paths_nix_output_monitor (version)
import Relude
import Streamly.Internal.Data.Time.Units (AbsTime)
import System.Console.ANSI qualified as Terminal
import System.Console.Terminal.Size (Window)
import System.Environment qualified as Environment
import System.IO.Error qualified as IOError
import System.Process.Typed qualified as Process
import Type.Strict qualified as StrictType
outputHandle Handle
outputHandle :: Handle
outputHandle = stderr
defaultConfig Config
defaultConfig :: Config
defaultConfig =
MkConfig
{ piping = False
, silent = False
}
main IO Void
main :: IO Void
main = do
args Environment.getArgs
prog_name Environment.getProgName
args <- Environment.getArgs
prog_name <- Environment.getProgName
case (args, prog_name) of
(["--version"], _) do
(["--version"], _) -> do
hPutStrLn stderr ("nix-output-monitor " <> fromString (showVersion version))
exitWith =<< Process.runProcess (Process.proc "nix" ["--version"])
(nix_args, "nom-build") do
(nix_args, "nom-build") -> do
exitWith =<< runMonitoredCommand defaultConfig (Process.proc "nix-build" ("-v" : "--log-format" : "internal-json" : nix_args))
(nix_args, "nom-shell") do
(nix_args, "nom-shell") -> do
exitOnFailure =<< runMonitoredCommand defaultConfig{silent = True} (Process.proc "nix-shell" (("-v" : "--log-format" : "internal-json" : nix_args) <> ["--run", "exit"]))
exitWith =<< Process.runProcess (Process.proc "nix-shell" nix_args)
("build" : nix_args, _) do
("build" : nix_args, _) -> do
exitWith =<< runMonitoredCommand defaultConfig (Process.proc "nix" ("build" : "-v" : "--log-format" : "internal-json" : nix_args))
("shell" : nix_args, _) do
("shell" : nix_args, _) -> do
exitOnFailure =<< runMonitoredCommand defaultConfig{silent = True} (Process.proc "nix" (("shell" : "-v" : "--log-format" : "internal-json" : nix_args) <> ["--command", "sh", "-c", "exit"]))
exitWith =<< Process.runProcess (Process.proc "nix" ("shell" : nix_args))
("develop" : nix_args, _) do
("develop" : nix_args, _) -> do
exitOnFailure =<< runMonitoredCommand defaultConfig{silent = True} (Process.proc "nix" (("develop" : "-v" : "--log-format" : "internal-json" : nix_args) <> ["--command", "sh", "-c", "exit"]))
exitWith =<< Process.runProcess (Process.proc "nix" ("develop" : nix_args))
([], _) do
finalState monitorHandle (Proxy @(Maybe NixOldStyleMessage, ByteString)) defaultConfig{piping = True} stdin
([], _) -> do
finalState <- monitorHandle (Proxy @(Maybe NixOldStyleMessage, ByteString)) defaultConfig{piping = True} stdin
if CMap.size finalState.fullSummary.failedBuilds + length finalState.nixErrors == 0
then exitSuccess
else exitFailure
(["--json"], _) do
finalState monitorHandle (Proxy @(Either NOMError NixJSONMessage)) defaultConfig{piping = True} stdin
(["--json"], _) -> do
finalState <- monitorHandle (Proxy @(Either NOMError NixJSONMessage)) defaultConfig{piping = True} stdin
if CMap.size finalState.fullSummary.failedBuilds + length finalState.nixErrors == 0
then exitSuccess
else exitFailure
xs do
xs -> do
hPutStrLn stderr helpText
-- It's not a mistake if the user requests the help text, otherwise tell
-- them off with a non-zero exit code.
if any (liftA2 (||) (== "-h") (== "--help")) xs then exitSuccess else exitFailure
exitOnFailure Process.ExitCode IO ()
exitOnFailure :: Process.ExitCode -> IO ()
exitOnFailure = \case
code@Process.ExitFailure{} exitWith code
_ pass
code@Process.ExitFailure{} -> exitWith code
_ -> pass
printIOException IOError.IOError IO ()
printIOException :: IOError.IOError -> IO ()
printIOException io_exception = do
let error_msg = case (IOError.isDoesNotExistError io_exception, IOError.ioeGetFileName io_exception) of
(True, Just cmd) "Command '" <> toText cmd <> "' not available from $PATH."
_ show io_exception
(True, Just cmd) -> "Command '" <> toText cmd <> "' not available from $PATH."
_ -> show io_exception
hPutStrLn stderr $ markup red ("nix-output-monitor: " <> error_msg)
runMonitoredCommand Config Process.ProcessConfig () () () IO Process.ExitCode
runMonitoredCommand :: Config -> Process.ProcessConfig () () () -> IO Process.ExitCode
runMonitoredCommand config process_config = do
let process_config_with_handles =
Process.setStdout Process.createPipe $
@ -100,34 +101,34 @@ runMonitoredCommand config process_config = do
Process.createPipe
process_config
Exception.handle ((ExitFailure 1 <$) . printIOException) $
Process.withProcessWait process_config_with_handles \process do
Process.withProcessWait process_config_with_handles \process -> do
void $ monitorHandle (Proxy @(Either NOMError NixJSONMessage)) config (Process.getStderr process)
exitCode Process.waitExitCode process
output ByteString.hGetContents (Process.getStdout process)
exitCode <- Process.waitExitCode process
output <- ByteString.hGetContents (Process.getStdout process)
unless (ByteString.null output) $ ByteString.hPut stdout output
pure exitCode
data UpdateResult a = MkUpdateResult
{ errors [NOMError]
, output ByteString
, newStateToPrint Maybe NOMV1State
, newState UpdaterState a
{ errors :: [NOMError]
, output :: ByteString
, newStateToPrint :: Maybe NOMV1State
, newState :: UpdaterState a
}
deriving stock (Generic)
data ProcessState a = MkProcessState
{ updaterState UpdaterState a
, printFunction Maybe (Window Int) (ZonedTime, AbsTime) Text
{ updaterState :: UpdaterState a
, printFunction :: Maybe (Window Int) -> (ZonedTime, Double) -> Text
}
deriving stock (Generic)
class NOMInput a where
type UpdaterState a
firstState NOMV1State UpdaterState a
updateState UpdateMonad m a UpdaterState a m (UpdateResult a)
nomState Lens' (UpdaterState a) NOMV1State
inputStream Handle Stream (Either NOMError ByteString)
withParser (StreamParser a IO t) IO t
firstState :: NOMV1State -> UpdaterState a
updateState :: (StrictType.Strict (UpdaterState a), UpdateMonad m) => a -> UpdaterState a -> m (UpdateResult a)
nomState :: Lens' (UpdaterState a) NOMV1State
inputStream :: Handle -> Stream (Either NOMError ByteString)
withParser :: (StreamParser a -> IO t) -> IO t
instance NOMInput (Either NOMError NixJSONMessage) where
withParser body = JSON.withHermesEnv (body . parseStreamSimple . parseJSON)
@ -146,32 +147,38 @@ instance NOMInput (Either NOMError NixJSONMessage) where
, newState = fromMaybe old_state new_state
}
data OldStyleState = MkOldStyleState
{ state :: NOMV1State
, lastRead :: Strict.Maybe Double
}
deriving stock (Generic)
instance NOMInput (Maybe NixOldStyleMessage, ByteString) where
withParser body = body (parseStreamAttoparsec parser)
type UpdaterState (Maybe NixOldStyleMessage, ByteString) = (Maybe AbsTime, NOMV1State)
type UpdaterState (Maybe NixOldStyleMessage, ByteString) = OldStyleState
inputStream = readTextChunks
nomState = _2
firstState = (Nothing,)
nomState = gfield @"state"
firstState state' = MkOldStyleState{state = state', lastRead = Strict.Nothing}
{-# INLINE updateState #-}
updateState input old_state = mkUpdateResult <$> updateStateNixOldStyleMessage input old_state
updateState input old_state = mkUpdateResult <$> updateStateNixOldStyleMessage input (Strict.toLazy old_state.lastRead, old_state.state)
where
mkUpdateResult ((errors, output), (new_timestamp, new_state)) =
MkUpdateResult
{ errors
, output
, newStateToPrint = new_state
, newState = (new_timestamp, fromMaybe (snd old_state) new_state)
, newState = MkOldStyleState (fromMaybe (old_state.state) new_state) (Strict.toStrict new_timestamp)
}
monitorHandle a. NOMInput a Proxy a Config Handle IO NOMV1State
monitorHandle _ config input_handle = withParser @a \streamParser do
finalState
monitorHandle :: forall a. (StrictType.Strict (UpdaterState a), NOMInput a) => Proxy a -> Config -> Handle -> IO NOMV1State
monitorHandle _ config input_handle = withParser @a \streamParser -> do
finalState <-
do
Terminal.hHideCursor outputHandle
hSetBuffering stdout (BlockBuffering (Just 1_000_000))
current_system Exception.handle ((Nothing <$) . printIOException) $ Just . decodeUtf8 <$> Process.readProcessStdout_ (Process.proc "nix" ["eval", "--extra-experimental-features", "nix-command", "--impure", "--raw", "--expr", "builtins.currentSystem"])
first_state initalStateFromBuildPlatform current_system
current_system <- Exception.handle ((Nothing <$) . printIOException) $ Just . decodeUtf8 <$> Process.readProcessStdout_ (Process.proc "nix" ["eval", "--extra-experimental-features", "nix-command", "--impure", "--raw", "--expr", "builtins.currentSystem"])
first_state <- initalStateFromBuildPlatform current_system
let first_process_state = MkProcessState (firstState @a first_state) (stateToText config first_state)
interact config streamParser (processStateUpdater @a config) (gfield @"updaterState" % nomState @a %~ maintainState) (.printFunction) (finalizer config) (inputStream @a input_handle) outputHandle first_process_state
`Exception.finally` do
@ -180,15 +187,15 @@ monitorHandle _ config input_handle = withParser @a \streamParser → do
pure (finalState.updaterState ^. nomState @a)
{-# INLINE processStateUpdater #-}
processStateUpdater
a m.
(NOMInput a, UpdateMonad m)
Config
a
processStateUpdater ::
forall a m.
(NOMInput a, UpdateMonad m, StrictType.Strict (UpdaterState a)) =>
Config ->
a ->
StateT (ProcessState a) m ([NOMError], ByteString)
processStateUpdater config input = do
old_state get
updater_result updateState input (old_state.updaterState)
old_state <- get
updater_result <- updateState input (old_state.updaterState)
put
MkProcessState
{ updaterState = updater_result.newState
@ -196,21 +203,21 @@ processStateUpdater config input = do
}
pure (updater_result.errors, updater_result.output)
finalizer
a m.
(NOMInput a, UpdateMonad m)
Config
finalizer ::
forall a m.
(NOMInput a, UpdateMonad m) =>
Config ->
StateT (ProcessState a) m ()
finalizer config = do
old_state get
newState (gfield @"progressState" .~ Finished) <$> execStateT (runWriterT detectLocalFinishedBuilds) (old_state.updaterState ^. nomState @a)
old_state <- get
newState <- (gfield @"progressState" .~ Finished) <$> execStateT (runWriterT detectLocalFinishedBuilds) (old_state.updaterState ^. nomState @a)
put
MkProcessState
{ updaterState = nomState @a .~ newState $ old_state.updaterState
, printFunction = stateToText config newState
}
helpText Text
helpText :: Text
helpText =
unlines
[ "nix-output-monitor usages:"

View File

@ -1,3 +1,3 @@
indentation: 2
unicode: always
unicode: never
respectful: false

View File

@ -0,0 +1,17 @@
module Data.Sequence.Strict (
Seq.sortOn,
Seq.filter,
(<|),
Data.Sequence.Strict.fromList,
Seq.null,
Seq ((Seq.:<|)),
) where
import Data.Sequence qualified as Seq
import Relude
(<|) :: a -> Seq a -> Seq a
!item <| rest = item Seq.<| rest
fromList :: [a] -> Seq.Seq a
fromList = foldr (<|) mempty

View File

@ -1,11 +1,10 @@
module NOM.Builds (parseHost, Derivation (..), StorePath (..), Host (..), FailType (..), parseStorePath, parseDerivation, storePathByteStringParser, derivationByteStringParser, parseIndentedStoreObject) where
import Relude
import Data.Attoparsec.ByteString qualified as Parser
import Data.Attoparsec.ByteString.Char8 qualified as Parser.Char
import Data.Attoparsec.Text qualified as TextParser
import Data.Text qualified as Text
import Relude
data StorePath = StorePath
{ hash :: Text
@ -85,7 +84,7 @@ instance ToText StorePath where
instance ToString StorePath where
toString = toString . toText
data Host = Localhost | Host !Text
data Host = Localhost | Host Text
deriving stock (Ord, Eq, Show, Generic)
instance ToText Host where

View File

@ -1,8 +1,7 @@
module NOM.Error (NOMError (..)) where
import Relude
import Control.Exception (IOException)
import Relude
data NOMError
= InputError IOException

View File

@ -15,7 +15,6 @@ import NOM.Print.Table as Table (bold, displayWidth, displayWidthBS, markup, red
import NOM.Update.Monad (UpdateMonad, getNow)
import Relude
import Streamly.Data.Fold qualified as Fold
import Streamly.Internal.Data.Time.Units (AbsTime)
import Streamly.Prelude ((.:), (|&), (|&.))
import Streamly.Prelude qualified as Stream
import System.Console.ANSI (SGR (Reset), setSGRCode)
@ -25,68 +24,68 @@ import System.IO qualified
type Stream = Stream.SerialT IO
type StreamParser update = Stream ByteString Stream update
type StreamParser update = Stream ByteString -> Stream update
type Output = Text
type UpdateFunc update state = m. UpdateMonad m update StateT state m ([NOMError], ByteString)
type UpdateFunc update state = forall m. UpdateMonad m => update -> StateT state m ([NOMError], ByteString)
type OutputFunc state = state Maybe Window (ZonedTime, AbsTime) Output
type OutputFunc state = state -> Maybe Window -> (ZonedTime, Double) -> Output
type Finalizer state = m. UpdateMonad m StateT state m ()
type Finalizer state = forall m. UpdateMonad m => StateT state m ()
type Window = Terminal.Size.Window Int
readTextChunks Handle Stream (Either NOMError ByteString)
readTextChunks :: Handle -> Stream (Either NOMError ByteString)
readTextChunks handle = loop
where
-- We read up-to 4kb of input at once. We will rarely need more than that for one successful parse (i.e. a line).
-- I dont know much about computers, but 4k seems like something which would be cached efficiently.
bufferSize Int
bufferSize :: Int
bufferSize = 4096
tryRead Stream (Either IOException ByteString)
tryRead :: Stream (Either IOException ByteString)
tryRead = liftIO $ try $ ByteString.hGetSome handle bufferSize
loop Stream (Either NOMError ByteString)
loop :: Stream (Either NOMError ByteString)
loop =
tryRead >>= \case
Left err Left (InputError err) .: loop -- Forward Exceptions, when we encounter them
Right "" mempty -- EOF
Right input Right input .: loop
Left err -> Left (InputError err) .: loop -- Forward Exceptions, when we encounter them
Right "" -> mempty -- EOF
Right input -> Right input .: loop
runUpdate
update state.
TVar ByteString
TVar state
UpdateFunc update state
update
runUpdate ::
forall update state.
TVar ByteString ->
TVar state ->
UpdateFunc update state ->
update ->
IO ByteString
runUpdate bufferVar stateVar updater input = do
oldState readTVarIO stateVar
((!errors, !output), !newState) runStateT (updater input) oldState
oldState <- readTVarIO stateVar
((!errors, !output), !newState) <- runStateT (updater input) oldState
atomically $ do
forM_ errors (\error' modifyTVar bufferVar (appendError error'))
forM_ errors (\error' -> modifyTVar bufferVar (appendError error'))
writeTVar stateVar newState
pure output
writeStateToScreen state. Bool TVar Int TVar state TVar ByteString (state state) OutputFunc state Handle IO ()
writeStateToScreen :: forall state. Bool -> TVar Int -> TVar state -> TVar ByteString -> (state -> state) -> OutputFunc state -> Handle -> IO ()
writeStateToScreen pad printed_lines_var nom_state_var nix_output_buffer_var maintenance printer output_handle = do
nowClock getZonedTime
now getNow
terminalSize
nowClock <- getZonedTime
now <- getNow
terminalSize <-
Terminal.Size.hSize output_handle <&> \case
-- We throw away non positive window sizes, which some terminals apparently report
-- to avoid divisions by zero later on.
val@(Just window) | window.width > 0, window.height > 0 val
_ Nothing
val@(Just window) | window.width > 0, window.height > 0 -> val
_ -> Nothing
(nom_state, nix_output_raw) atomically do
(nom_state, nix_output_raw) <- atomically do
-- ==== Time Critical Segment - calculating to much in atomically can lead
-- to recalculations. In this section we are racing with the input parsing
-- thread to update the state.
modifyTVar nom_state_var maintenance
-- we bind those lazily to not calculate them during STM
~nom_state readTVar nom_state_var
~nix_output_raw swapTVar nix_output_buffer_var mempty
~nom_state <- readTVar nom_state_var
~nix_output_raw <- swapTVar nix_output_buffer_var mempty
pure (nom_state, nix_output_raw)
-- ====
@ -105,18 +104,18 @@ writeStateToScreen pad printed_lines_var nom_state_var nix_output_buffer_var mai
-- might be slightly to high in corner cases but that will only trigger
-- sligthly more redraws which is totally acceptable.
reflow_line_count_correction =
terminalSize <&> \size
terminalSize <&> \size ->
-- This division is fine, because we dont accept non positiv window sizes.
getSum $ foldMap (\line Sum (displayWidthBS line `div` size.width)) nix_output
getSum $ foldMap (\line -> Sum (displayWidthBS line `div` size.width)) nix_output
(last_printed_line_count, lines_to_pad) atomically do
last_printed_line_count readTVar printed_lines_var
(last_printed_line_count, lines_to_pad) <- atomically do
last_printed_line_count <- readTVar printed_lines_var
-- When the nom output suddenly gets smaller, it might jump up from the bottom of the screen.
-- To prevent this we insert a few newlines before it.
-- We only do this if we know the size of the terminal.
let lines_to_pad = case reflow_line_count_correction of
Just reflow_correction | pad max 0 (last_printed_line_count - reflow_correction - nix_output_length - nom_output_length)
_ 0
Just reflow_correction | pad -> max 0 (last_printed_line_count - reflow_correction - nix_output_length - nom_output_length)
_ -> 0
line_count_to_print = nom_output_length + lines_to_pad
writeTVar printed_lines_var line_count_to_print
pure (last_printed_line_count, lines_to_pad)
@ -145,11 +144,11 @@ writeStateToScreen pad printed_lines_var nom_state_var nix_output_buffer_var mai
)
<>
-- Insert the output to write to the screen.
( output_to_print_with_newline_annotations & foldMap \(newline, line)
( output_to_print_with_newline_annotations & foldMap \(newline, line) ->
( case newline of
StayInLine mempty
MoveToNextLine Builder.stringUtf8 (Terminal.cursorDownLineCode 1)
PrintNewLine Builder.byteString "\n"
StayInLine -> mempty
MoveToNextLine -> Builder.stringUtf8 (Terminal.cursorDownLineCode 1)
PrintNewLine -> Builder.byteString "\n"
)
<> Builder.byteString line
)
@ -166,81 +165,81 @@ data ToNextLine = StayInLine | MoveToNextLine | PrintNewLine
-- Depending on the current line of the output we are printing we need to decide
-- how to move to a new line before printing.
howToGoToNextLine Int Maybe Int Int ToNextLine
howToGoToNextLine :: Int -> Maybe Int -> Int -> ToNextLine
howToGoToNextLine _ Nothing = \case
-- When we have no info about terminal size, better be careful and always print
-- newlines if necessary.
0 StayInLine
_ PrintNewLine
0 -> StayInLine
_ -> PrintNewLine
howToGoToNextLine previousPrintedLines (Just correction) = \case
-- When starting to print we are always in an empty line with the cursor at the start.
-- So we dont need to go to a new line
0 StayInLine
0 -> StayInLine
-- When the current offset is smaller than the number of previously printed lines.
-- e.g. we have printed 1 line, but before we had printed 2
-- then we can probably move the cursor a row down without needing to print a newline.
x
| x + correction < previousPrintedLines
| x + correction < previousPrintedLines ->
MoveToNextLine
-- When we are at the bottom of the terminal we have no choice but need to
-- print a newline and thus (sadly) flush the terminal
_ PrintNewLine
_ -> PrintNewLine
interact
update state.
Config
StreamParser update
UpdateFunc update state
(state state)
OutputFunc state
Finalizer state
Stream (Either NOMError ByteString)
Handle
state
interact ::
forall update state.
Config ->
StreamParser update ->
UpdateFunc update state ->
(state -> state) ->
OutputFunc state ->
Finalizer state ->
Stream (Either NOMError ByteString) ->
Handle ->
state ->
IO state
interact config parser updater maintenance printer finalize input_stream output_handle initialState =
processTextStream config parser updater maintenance (Just (printer, output_handle)) finalize initialState input_stream
-- frame durations are passed to threadDelay and thus are given in microseconds
maxFrameDuration Int
maxFrameDuration :: Int
maxFrameDuration = 1_000_000 -- once per second to update timestamps
minFrameDuration Int
minFrameDuration :: Int
minFrameDuration =
-- this seems to be a nice compromise to reduce excessive
-- flickering, since the movement is not continuous this low frequency doesnt
-- feel to sluggish for the eye, for me.
100_000 -- 10 times per second
processTextStream
update state.
Config
StreamParser update
UpdateFunc update state
(state state)
Maybe (OutputFunc state, Handle)
Finalizer state
state
Stream (Either NOMError ByteString)
processTextStream ::
forall update state.
Config ->
StreamParser update ->
UpdateFunc update state ->
(state -> state) ->
Maybe (OutputFunc state, Handle) ->
Finalizer state ->
state ->
Stream (Either NOMError ByteString) ->
IO state
processTextStream config parser updater maintenance printerMay finalize initialState inputStream = do
stateVar newTVarIO initialState
bufferVar newTVarIO mempty
let keepProcessing IO ()
stateVar <- newTVarIO initialState
bufferVar <- newTVarIO mempty
let keepProcessing :: IO ()
keepProcessing =
inputStream
|& Stream.tap (writeErrorsToBuffer bufferVar)
|& Stream.mapMaybe rightToMaybe
|& parser
|&. Stream.mapM_ (runUpdate bufferVar stateVar updater >=> atomically . modifyTVar bufferVar . flip (<>))
waitForInput IO ()
waitForInput :: IO ()
waitForInput = atomically $ check . not . ByteString.null =<< readTVar bufferVar
printerMay & maybe keepProcessing \(printer, output_handle) do
linesVar newTVarIO 0
let writeToScreen IO ()
printerMay & maybe keepProcessing \(printer, output_handle) -> do
linesVar <- newTVarIO 0
let writeToScreen :: IO ()
writeToScreen = writeStateToScreen (not config.silent) linesVar stateVar bufferVar maintenance printer output_handle
keepPrinting IO ()
keepPrinting :: IO ()
keepPrinting = forever do
race_ (concurrently_ (threadDelay minFrameDuration) waitForInput) (threadDelay maxFrameDuration)
writeToScreen
@ -249,36 +248,36 @@ processTextStream config parser updater maintenance printerMay finalize initialS
writeToScreen
(if isNothing printerMay then (>>= execStateT finalize) else id) $ readTVarIO stateVar
writeErrorsToBuffer TVar ByteString Fold.Fold IO (Either NOMError ByteString) ()
writeErrorsToBuffer :: TVar ByteString -> Fold.Fold IO (Either NOMError ByteString) ()
writeErrorsToBuffer bufferVar = Fold.drainBy saveInput
where
saveInput Either NOMError ByteString IO ()
saveInput :: Either NOMError ByteString -> IO ()
saveInput = \case
Left error' atomically $ modifyTVar bufferVar (appendError error')
_ pass
Left error' -> atomically $ modifyTVar bufferVar (appendError error')
_ -> pass
appendError NOMError ByteString ByteString
appendError :: NOMError -> ByteString -> ByteString
appendError err prev = (if ByteString.null prev || ByteString.isSuffixOf "\n" prev then "" else "\n") <> nomError <> show err <> "\n"
nomError ByteString
nomError :: ByteString
nomError = encodeUtf8 (markup (red . bold) "nix-output-monitor error: ")
truncateOutput Maybe Window Text Text
truncateOutput :: Maybe Window -> Text -> Text
truncateOutput win output = maybe output go win
where
go Window Text
go :: Window -> Text
go window = Text.intercalate "\n" $ truncateColumns window.width <$> truncateRows window.height
truncateColumns Int Text Text
truncateColumns :: Int -> Text -> Text
truncateColumns columns line = if displayWidth line > columns then Table.truncate (columns - 1) line <> "" <> toText (setSGRCode [Reset]) else line
truncateRows Int [Text]
truncateRows :: Int -> [Text]
truncateRows rows
| length outputLines >= rows - outputLinesToAlwaysShow = take 1 outputLines <> [""] <> drop (length outputLines + outputLinesToAlwaysShow + 2 - rows) outputLines
| otherwise = outputLines
outputLines [Text]
outputLines :: [Text]
outputLines = Text.lines output
outputLinesToAlwaysShow Int
outputLinesToAlwaysShow :: Int
outputLinesToAlwaysShow = 5

View File

@ -1,10 +1,9 @@
module NOM.IO.ParseStream.Attoparsec (parseStreamAttoparsec, parseOneText, stripANSICodes) where
import Relude
import Data.Attoparsec.ByteString (IResult (..), Parser, Result, parse)
import Data.ByteString qualified as ByteString
import Data.Word8 qualified as Word8
import Relude
import Streamly.Prelude ((.:))
import Streamly.Prelude qualified as Stream
@ -22,8 +21,10 @@ parseChunk initState (strippedInput, rawInput) = join $ state \(currentParser, c
csi :: ByteString
csi = "\27["
breakOnANSIStartCode :: ByteString -> (ByteString, ByteString)
breakOnANSIStartCode = ByteString.breakSubstring csi
streamANSIChunks :: ByteString -> Stream.SerialT m (ByteString, ByteString)
streamANSIChunks input =
let (!filtered, !unfiltered) = breakOnANSIStartCode input

View File

@ -1,8 +1,7 @@
module NOM.IO.ParseStream.Simple (parseStreamSimple) where
import Relude
import Data.ByteString qualified as ByteString
import Relude
import Streamly.Prelude ((.:), (|$))
import Streamly.Prelude qualified as Stream

View File

@ -5,6 +5,7 @@ import Relude
newtype ActivityId = MkId {value :: Int}
deriving newtype (Show, Eq, Ord)
deriving stock (Generic)
newtype StopAction = MkStopAction {id :: ActivityId}
deriving newtype (Eq)

View File

@ -1,16 +1,15 @@
module NOM.NixMessage.OldStyle (NixOldStyleMessage (..)) where
import NOM.Builds (Derivation (..), FailType, Host (..), StorePath (..))
import Relude
import NOM.Builds (Derivation (..), FailType, Host (..), StorePath (..))
data NixOldStyleMessage
= Uploading !StorePath !Host
| Downloading !StorePath !Host
| PlanCopies !Int
| Build Derivation !Host
| PlanBuilds (Set Derivation) !Derivation
| PlanDownloads !Double !Double (Set StorePath)
| Checking !Derivation
| Failed !Derivation !FailType
= Uploading StorePath Host
| Downloading StorePath Host
| PlanCopies Int
| Build Derivation Host
| PlanBuilds (Set Derivation) Derivation
| PlanDownloads Double Double (Set StorePath)
| Checking Derivation
| Failed Derivation FailType
deriving stock (Show, Eq)

View File

@ -1,7 +1,5 @@
module NOM.Parser (parser, oldStyleParser, planBuildLine, planDownloadLine, inTicks) where
import Relude hiding (take, takeWhile)
import Data.Attoparsec.ByteString (
Parser,
choice,
@ -18,7 +16,6 @@ import Data.Attoparsec.ByteString.Char8 (
isEndOfLine,
takeTill,
)
import NOM.Builds (
Derivation (..),
FailType (ExitCode, HashMismatch),
@ -28,6 +25,7 @@ import NOM.Builds (
storePathByteStringParser,
)
import NOM.NixMessage.OldStyle (NixOldStyleMessage (..))
import Relude hiding (take, takeWhile)
parser :: Parser (Maybe NixOldStyleMessage)
parser = Just <$> oldStyleParser <|> Nothing <$ noMatch

View File

@ -1,16 +1,14 @@
module NOM.Parser.JSON.Hermes (parseJSON) where
import Relude hiding (one)
import Control.Exception (try)
import Data.ByteString qualified as ByteString
import Data.Hermes qualified as JSON
import Data.Hermes.Decoder (listOfInt)
import System.IO.Unsafe qualified as Unsafe
import Data.ByteString qualified as ByteString
import NOM.Builds (parseDerivation, parseHost, parseStorePath)
import NOM.Error (NOMError (..))
import NOM.NixMessage.JSON (Activity (..), ActivityId (..), ActivityProgress (..), ActivityResult (..), ActivityType (..), MessageAction (..), NixJSONMessage (..), ResultAction (..), StartAction (..), StopAction (..), Verbosity (..))
import Relude hiding (one)
import System.IO.Unsafe qualified as Unsafe
parseJSON :: JSON.HermesEnv -> ByteString -> Either NOMError NixJSONMessage
parseJSON env input = first translate_hermes_error_to_nom_error json_parse_result
@ -74,8 +72,10 @@ parseMessageAction object = do
textFields :: JSON.Object -> JSON.Decoder [Text]
textFields = JSON.atKey "fields" (JSON.list JSON.text)
textOrNumFields :: JSON.Object -> JSON.Decoder [Either Text Int]
textOrNumFields = JSON.atKey "fields" (JSON.list \val -> (Left <$> JSON.text val) <|> (Right <$> JSON.int val))
intFields :: JSON.Object -> JSON.Decoder [Int]
intFields = JSON.atKey "fields" listOfInt

View File

@ -1,15 +1,14 @@
module NOM.Print (stateToText, showCode, Config (..)) where
-- terminal-size
import Data.Foldable qualified as Unsafe
import Data.IntMap qualified as IntMap
import Data.List qualified as List
import Data.List.NonEmpty.Extra (appendr)
import Data.Map.Strict qualified as Map
import Data.MemoTrie (memo)
import Data.Sequence qualified as Seq
import Data.Sequence.Strict qualified as Seq
import Data.Set qualified as Set
import Data.Strict qualified as Strict
import Data.Text qualified as Text
import Data.Time (NominalDiffTime, ZonedTime, defaultTimeLocale, formatTime)
import Data.Tree (Forest, Tree (Node))
@ -18,25 +17,23 @@ import NOM.Builds (Derivation (..), FailType (..), Host (..), StorePath (..))
import NOM.NixMessage.JSON (ActivityId (..))
import NOM.Print.Table (Entry, blue, bold, cells, dummy, green, grey, header, label, magenta, markup, markups, prependLines, printAlignedSep, red, text, yellow)
import NOM.Print.Tree (showForest)
import NOM.State (BuildInfo (..), BuildStatus (..), DependencySummary (..), DerivationId, DerivationInfo (..), DerivationSet, NOMState, NOMV1State (..), ProgressState (..), StorePathId, StorePathInfo (..), StorePathMap, StorePathSet, TransferInfo (..), getDerivationInfos, getStorePathInfos, inputStorePaths)
import NOM.State (ActivityStatus (..), BuildFail (..), BuildInfo (..), BuildStatus (..), DependencySummary (..), DerivationId, DerivationInfo (..), DerivationSet, InputDerivation (..), NOMState, NOMV1State (..), ProgressState (..), StorePathId, StorePathInfo (..), StorePathMap, StorePathSet, TransferInfo (..), getDerivationInfos, getStorePathInfos, inputStorePaths)
import NOM.State.CacheId.Map qualified as CMap
import NOM.State.CacheId.Set qualified as CSet
import NOM.State.Sorting (SortKey, sortKey, summaryIncludingRoot)
import NOM.State.Tree (mapRootsTwigsAndLeafs)
import NOM.Update (appendDifferingPlatform)
import NOM.Util (diffTime, relTimeToSeconds)
import Optics (itoList, view, _2)
import Relude
import Streamly.Internal.Data.Time.Units (AbsTime, diffAbsTime)
import System.Console.ANSI (SGR (Reset), setSGRCode)
import System.Console.Terminal.Size (Window)
import System.Console.Terminal.Size qualified as Window
import Text.Printf (printf)
showCode Text [String]
showCode :: Text -> [String]
showCode = map (printf "%02X" . fromEnum) . toString
textRep, vertical, lowerleft, upperleft, horizontal, down, up, clock, running, done, bigsum, warning, todo, leftT, average Text
textRep, vertical, lowerleft, upperleft, horizontal, down, up, clock, running, done, bigsum, warning, todo, leftT, average :: Text
textRep = fromString [toEnum 0xFE0E]
vertical = ""
lowerleft = ""
@ -71,34 +68,34 @@ average = "∅" <> textRep
-- ["2211","FE0E"]
bigsum = "" <> textRep
showCond Monoid m Bool m m
showCond :: Monoid m => Bool -> m -> m
showCond = memptyIfFalse
targetRatio, defaultTreeMax Int
targetRatio, defaultTreeMax :: Int
targetRatio = 3 -- We divide by this, dont set this to zero.
defaultTreeMax = 20
data Config = MkConfig
{ silent Bool
, piping Bool
{ silent :: Bool
, piping :: Bool
}
stateToText Config NOMV1State Maybe (Window Int) (ZonedTime, AbsTime) Text
stateToText :: Config -> NOMV1State -> Maybe (Window Int) -> (ZonedTime, Double) -> Text
stateToText config buildState@MkNOMV1State{..} = memo printWithSize . fmap Window.height
where
printWithSize Maybe Int (ZonedTime, AbsTime) Text
printWithSize :: Maybe Int -> (ZonedTime, Double) -> Text
printWithSize maybeWindow = printWithTime
where
printWithTime (ZonedTime, AbsTime) Text
printWithTime :: (ZonedTime, Double) -> Text
printWithTime
| progressState == JustStarted && config.piping = \nows@(_, now) time nows <> showCond (diffTime now startTime > 15) (markup grey " nom hasnt detected any input. Have you redirected nix-build stderr into nom? (See -h and the README for details.)")
| progressState == JustStarted && config.piping = \nows@(_, now) -> time nows <> showCond (now - startTime > 15) (markup grey " nom hasnt detected any input. Have you redirected nix-build stderr into nom? (See -h and the README for details.)")
| progressState == Finished && config.silent = const ""
| showBuildGraph = \nows@(_, now) buildsDisplay now <> table (time nows)
| showBuildGraph = \nows@(_, now) -> buildsDisplay now <> table (time nows)
| not anythingGoingOn = if config.silent then const "" else time
| otherwise = table . time
maxHeight = case maybeWindow of
Just limit limit `div` targetRatio -- targetRatio is hardcoded to be bigger than zero.
Nothing defaultTreeMax
Just limit -> limit `div` targetRatio -- targetRatio is hardcoded to be bigger than zero.
Nothing -> defaultTreeMax
buildsDisplay now =
prependLines
(toText (setSGRCode [Reset]) <> upperleft <> horizontal)
@ -108,8 +105,8 @@ stateToText config buildState@MkNOMV1State{..} = memo printWithSize . fmap Windo
<> "\n"
runTime now = timeDiff now startTime
time
| progressState == Finished = \(nowClock, now) finishMarkup (" at " <> toText (formatTime defaultTimeLocale "%H:%M:%S" nowClock) <> " after " <> runTime now)
| otherwise = \(_, now) clock <> " " <> runTime now
| progressState == Finished = \(nowClock, now) -> finishMarkup (" at " <> toText (formatTime defaultTimeLocale "%H:%M:%S" nowClock) <> " after " <> runTime now)
| otherwise = \(_, now) -> clock <> " " <> runTime now
MkDependencySummary{..} = fullSummary
runningBuilds' = (.host) <$> runningBuilds
completedBuilds' = (.host) <$> completedBuilds
@ -119,18 +116,18 @@ stateToText config buildState@MkNOMV1State{..} = memo printWithSize . fmap Windo
showBuildGraph = not (Seq.null forestRoots)
table time' =
prependLines
((if showBuildGraph then leftT else upperleft) <> stimes (3 Int) horizontal <> " ")
((if showBuildGraph then leftT else upperleft) <> stimes (3 :: Int) horizontal <> " ")
(vertical <> " ")
(lowerleft <> horizontal <> " " <> bigsum <> " ")
$ printAlignedSep (innerTable `appendr` one (lastRow time'))
innerTable [NonEmpty Entry]
innerTable :: [NonEmpty Entry]
innerTable = fromMaybe (one (text "")) (nonEmpty headers) : showCond showHosts printHosts
headers =
(cells 3 <$> optHeader showBuilds "Builds")
<> (cells 3 <$> optHeader showDownloads "Downloads")
<> (cells 2 <$> optHeader showUploads "Uploads")
<> optHeader showHosts "Host"
optHeader cond = showCond cond . one . bold . header Text [Entry]
optHeader cond = showCond cond . one . bold . header :: Text -> [Entry]
partial_last_row =
showCond
showBuilds
@ -172,11 +169,11 @@ stateToText config buildState@MkNOMV1State{..} = memo printWithSize . fmap Windo
| numFailedBuilds > 0 = markup red . ((warning <> " Exited after " <> show numFailedBuilds <> " build failures") <>)
| not (null nixErrors) = markup red . ((warning <> " Exited with " <> show (length nixErrors) <> " errors reported by nix") <>)
| otherwise = markup green . ("Finished" <>)
printHosts [NonEmpty Entry]
printHosts :: [NonEmpty Entry]
printHosts =
mapMaybe (nonEmpty . labelForHost) hostNums
where
labelForHost (Host, Int) [Entry]
labelForHost :: (Host, Int) -> [Entry]
labelForHost (host, index) =
showCond
showBuilds
@ -203,28 +200,28 @@ stateToText config buildState@MkNOMV1State{..} = memo printWithSize . fmap Windo
downloadsRunning' = action_count_for_host host runningDownloads
numRunningBuildsOnHost = action_count_for_host host runningBuilds
doneBuilds = action_count_for_host host completedBuilds
action_count_for_host HasField "host" a Host Host CMap.CacheIdMap b a Int
action_count_for_host host = CMap.size . CMap.filter (\x host == x.host)
action_count_for_host :: HasField "host" a Host => Host -> CMap.CacheIdMap b a -> Int
action_count_for_host host = CMap.size . CMap.filter (\x -> host == x.host)
nonZeroShowBold Text Int Entry
nonZeroShowBold :: Text -> Int -> Entry
nonZeroShowBold label' num = if num > 0 then label label' $ text (markup bold (show num)) else dummy
nonZeroBold Text Int Entry
nonZeroBold :: Text -> Int -> Entry
nonZeroBold label' num = label label' $ text (markup (if num > 0 then bold else id) (show num))
data TreeLocation = Root | Twig | Leaf deriving stock (Eq)
printBuilds
NOMV1State
[(Host, Int)]
Int
AbsTime
printBuilds ::
NOMV1State ->
[(Host, Int)] ->
Int ->
Double ->
NonEmpty Text
printBuilds nomState@MkNOMV1State{..} hostNums maxHeight = printBuildsWithTime
where
hostLabel Bool Host Text
hostLabel :: Bool -> Host -> Text
hostLabel color host = (if color then markup magenta else id) $ maybe (toText host) (("[" <>) . (<> "]") . show) (List.lookup host hostNums)
printBuildsWithTime AbsTime NonEmpty Text
printBuildsWithTime :: Double -> NonEmpty Text
printBuildsWithTime now = (graphHeader :|) $ showForest $ fmap (fmap ($ now)) preparedPrintForest
num_raw_roots = length forestRoots
num_roots = length preparedPrintForest
@ -234,48 +231,48 @@ printBuilds nomState@MkNOMV1State{..} hostNums maxHeight = printBuildsWithTime
| num_raw_roots <= 1 = graphTitle
| num_raw_roots == num_roots = unwords [graphTitle, "with", show num_roots, "roots"]
| otherwise = unwords [graphTitle, "showing", show num_roots, "of", show num_raw_roots, "roots"]
preparedPrintForest Forest (AbsTime Text)
preparedPrintForest :: Forest (Double -> Text)
preparedPrintForest = mapRootsTwigsAndLeafs (printTreeNode Root) (printTreeNode Twig) (printTreeNode Leaf) <$> buildForest
printTreeNode TreeLocation DerivationInfo AbsTime Text
printTreeNode :: TreeLocation -> DerivationInfo -> Double -> Text
printTreeNode location drvInfo =
let ~summary = showSummary drvInfo.dependencySummary
(planned, display_drv) = printDerivation drvInfo (get' (inputStorePaths drvInfo))
displayed_summary = showCond (location == Leaf && planned && not (Text.null summary)) (markup grey " waiting for " <> summary)
in \now display_drv now <> displayed_summary
in \now -> display_drv now <> displayed_summary
buildForest Forest DerivationInfo
buildForest :: Forest DerivationInfo
buildForest = evalState (goBuildForest forestRoots) mempty
goBuildForest Seq DerivationId State DerivationSet (Forest DerivationInfo)
goBuildForest :: Seq DerivationId -> State DerivationSet (Forest DerivationInfo)
goBuildForest = \case
(thisDrv Seq.:<| restDrvs) do
seen_ids get
(thisDrv Seq.:<| restDrvs) -> do
seen_ids <- get
let mkNode
| not (CSet.member thisDrv seen_ids) && CSet.member thisDrv derivationsToShow = do
let drvInfo = get' (getDerivationInfos thisDrv)
childs = children thisDrv
modify (CSet.insert thisDrv)
subforest goBuildForest childs
subforest <- goBuildForest childs
pure (Node drvInfo subforest :)
| otherwise = pure id
prepend_node mkNode
prepend_node <- mkNode
prepend_node <$> goBuildForest restDrvs
_ pure []
derivationsToShow DerivationSet
_ -> pure []
derivationsToShow :: DerivationSet
derivationsToShow =
let should_be_shown (index, (can_be_hidden, _, _)) = not can_be_hidden || index < maxHeight
(_, sorted_set) = execState (goDerivationsToShow forestRoots) mempty
in CSet.fromFoldable $
fmap (\(_, (_, _, drvId)) drvId) $
fmap (\(_, (_, _, drvId)) -> drvId) $
takeWhile should_be_shown $
itoList $
Set.toAscList sorted_set
children DerivationId Seq DerivationId
children drv_id = fmap fst $ (.inputDerivations) $ get' $ getDerivationInfos drv_id
children :: DerivationId -> Seq DerivationId
children drv_id = fmap (.derivation) $ (.inputDerivations) $ get' $ getDerivationInfos drv_id
goDerivationsToShow
Seq DerivationId
goDerivationsToShow ::
Seq DerivationId ->
State
( DerivationSet -- seenIds
, Set
@ -286,12 +283,12 @@ printBuilds nomState@MkNOMV1State{..} hostNums maxHeight = printBuildsWithTime
)
()
goDerivationsToShow = \case
(thisDrv Seq.:<| restDrvs) do
(seen_ids, sorted_set) get
(thisDrv Seq.:<| restDrvs) -> do
(seen_ids, sorted_set) <- get
let ~sort_key = sortKey nomState thisDrv
summary@MkDependencySummary{..} = get' (summaryIncludingRoot thisDrv)
~runningTransfers = CMap.keysSet runningDownloads <> CMap.keysSet runningUploads
~nodesOfRunningTransfers = flip foldMap (CSet.toList runningTransfers) \path
~nodesOfRunningTransfers = flip foldMap (CSet.toList runningTransfers) \path ->
let infos = get' (getStorePathInfos path)
in infos.inputFor <> CSet.fromFoldable infos.producer
~may_hide = CSet.isSubsetOf (nodesOfRunningTransfers <> CMap.keysSet failedBuilds <> CMap.keysSet runningBuilds) seen_ids
@ -307,12 +304,12 @@ printBuilds nomState@MkNOMV1State{..} hostNums maxHeight = printBuildsWithTime
~new_sorted_set = Set.insert (may_hide, sort_key, thisDrv) sorted_set
when show_this_node $ put (new_seen_ids, new_sorted_set) >> goDerivationsToShow (children thisDrv)
goDerivationsToShow restDrvs
_ pass
_ -> pass
get' NOMState b b
get' :: NOMState b -> b
get' procedure = evalState procedure nomState
showSummary DependencySummary Text
showSummary :: DependencySummary -> Text
showSummary MkDependencySummary{..} =
unwords $
join
@ -336,37 +333,37 @@ printBuilds nomState@MkNOMV1State{..} hostNums maxHeight = printBuildsWithTime
[markup blue $ show (CSet.size plannedDownloads) <> " " <> down <> " " <> todo]
]
hostMarkup Bool Host [Text]
hostMarkup :: Bool -> Host -> [Text]
hostMarkup _ Localhost = mempty
hostMarkup color host = ["on", hostLabel color host]
print_hosts Bool Text [Host] [Text]
print_hosts :: Bool -> Text -> [Host] -> [Text]
print_hosts color direction_label hosts
| null hosts || length hostNums <= 2 = []
| otherwise = direction_label : (hostLabel color <$> hosts)
print_hosts_down color = print_hosts color "from"
print_hosts_up color = print_hosts color "to"
printDerivation DerivationInfo Map Text StorePathId (Bool, AbsTime Text)
printDerivation :: DerivationInfo -> Map Text StorePathId -> (Bool, Double -> Text)
printDerivation drvInfo _input_store_paths = do
let store_paths_in StorePathSet Bool
let store_paths_in :: StorePathSet -> Bool
store_paths_in some_set = not $ Map.null $ Map.filter (`CSet.member` some_set) drvInfo.outputs
store_paths_in_map StorePathMap (TransferInfo a) [TransferInfo a]
store_paths_in_map :: StorePathMap (TransferInfo a) -> [TransferInfo a]
store_paths_in_map info_map = toList $ Map.mapMaybe (`CMap.lookup` info_map) drvInfo.outputs
hosts [TransferInfo a] [Host]
hosts :: [TransferInfo a] -> [Host]
hosts = toList . Set.fromList . fmap (.host)
earliest_start [TransferInfo a] AbsTime
earliest_start :: [TransferInfo a] -> Double
earliest_start = Unsafe.minimum . fmap (.start)
build_sum [TransferInfo (Maybe AbsTime)] NominalDiffTime
build_sum = relTimeToSeconds . sum . fmap (\transfer_info maybe 0 (diffAbsTime transfer_info.start) transfer_info.end)
if_time_diff_relevant AbsTime AbsTime ([Text] [Text]) [Text]
if_time_diff_relevant to from = if_time_dur_relevant (relTimeToSeconds $ diffAbsTime to from)
if_time_dur_relevant NominalDiffTime ([Text] [Text]) [Text]
build_sum :: [TransferInfo (Strict.Maybe Double)] -> NominalDiffTime
build_sum = sum . fmap (\transfer_info -> realToFrac $ Strict.maybe 0 (transfer_info.start -) transfer_info.end)
if_time_diff_relevant :: Double -> Double -> ([Text] -> [Text]) -> [Text]
if_time_diff_relevant to from = if_time_dur_relevant $ realToFrac (to - from)
if_time_dur_relevant :: NominalDiffTime -> ([Text] -> [Text]) -> [Text]
if_time_dur_relevant dur mod' = memptyIfFalse (dur > 1) (mod' [clock, printDuration dur])
phaseMay activityId' = do
activityId activityId'
(_, phase, _) IntMap.lookup activityId.value nomState.activities
phase
activityId <- Strict.toLazy activityId'
activity_status <- IntMap.lookup activityId.value nomState.activities
Strict.toLazy $ activity_status.phase
drvName = appendDifferingPlatform nomState drvInfo drvInfo.name.storePath.name
downloadingOutputs = store_paths_in_map drvInfo.dependencySummary.runningDownloads
uploadingOutputs = store_paths_in_map drvInfo.dependencySummary.runningUploads
@ -384,18 +381,18 @@ printBuilds nomState@MkNOMV1State{..} hostNums maxHeight = printBuildsWithTime
case drvInfo.buildStatus of
_
| not $ null downloadingOutputs
| not $ null downloadingOutputs ->
( False
, \now
, \now ->
unwords $
markups [bold, yellow] (down <> " " <> running <> " " <> drvName)
: ( print_hosts_down True (hosts downloadingOutputs)
<> if_time_diff_relevant now (earliest_start downloadingOutputs) id
)
)
| not $ null uploadingOutputs
| not $ null uploadingOutputs ->
( False
, \now
, \now ->
unwords $
markups [bold, yellow] (up <> " " <> running <> " " <> drvName)
: ( print_hosts_up True (hosts uploadingOutputs)
@ -403,8 +400,8 @@ printBuilds nomState@MkNOMV1State{..} hostNums maxHeight = printBuildsWithTime
)
)
Unknown
| plannedDownloads (True, const $ markup blue (down <> " " <> todo <> " " <> drvName))
| not $ null downloadedOutputs
| plannedDownloads -> (True, const $ markup blue (down <> " " <> todo <> " " <> drvName))
| not $ null downloadedOutputs ->
( False
, const $
unwords $
@ -415,7 +412,7 @@ printBuilds nomState@MkNOMV1State{..} hostNums maxHeight = printBuildsWithTime
<> if_time_dur_relevant (build_sum downloadedOutputs) id
)
)
| not $ null uploadedOutputs
| not $ null uploadedOutputs ->
( False
, const $
unwords $
@ -426,30 +423,30 @@ printBuilds nomState@MkNOMV1State{..} hostNums maxHeight = printBuildsWithTime
<> if_time_dur_relevant (build_sum uploadedOutputs) id
)
)
| otherwise (False, const drvName)
Planned (True, const $ markup blue (todo <> " " <> drvName))
Building buildInfo
| otherwise -> (False, const drvName)
Planned -> (True, const $ markup blue (todo <> " " <> drvName))
Building buildInfo ->
let phaseList = case phaseMay buildInfo.activityId of
Nothing []
Just phase [markup bold ("(" <> phase <> ")")]
Nothing -> []
Just phase -> [markup bold ("(" <> phase <> ")")]
before_time =
[markups [yellow, bold] (running <> " " <> drvName)]
<> hostMarkup True buildInfo.host
<> phaseList
after_time = maybe [] (\x ["(" <> average <> " " <> timeDiffSeconds x <> ")"]) buildInfo.estimate
in (False, \now unwords $ before_time <> if_time_diff_relevant now buildInfo.start (<> after_time))
Failed buildInfo
let (endTime, failType) = buildInfo.end
after_time = Strict.maybe [] (\x -> ["(" <> average <> " " <> timeDiffSeconds x <> ")"]) buildInfo.estimate
in (False, \now -> unwords $ before_time <> if_time_diff_relevant now buildInfo.start (<> after_time))
Failed buildInfo ->
let MkBuildFail endTime failType = buildInfo.end
phaseInfo = case phaseMay buildInfo.activityId of
Nothing []
Just phase ["in", phase]
Nothing -> []
Just phase -> ["in", phase]
in ( False
, const
. markups [red, bold]
. unwords
$ [warning, drvName] <> hostMarkup False buildInfo.host <> ["failed with", printFailType failType, "after", clock, timeDiff endTime buildInfo.start] <> phaseInfo
)
Built buildInfo
Built buildInfo ->
( False
, const $
markup green (done <> " " <> drvName)
@ -461,16 +458,16 @@ printBuilds nomState@MkNOMV1State{..} hostNums maxHeight = printBuildsWithTime
)
)
printFailType FailType Text
printFailType :: FailType -> Text
printFailType = \case
ExitCode i "exit code " <> show i
HashMismatch "hash mismatch"
ExitCode i -> "exit code " <> show i
HashMismatch -> "hash mismatch"
timeDiff AbsTime AbsTime Text
timeDiff :: Double -> Double -> Text
timeDiff x =
printDuration . relTimeToSeconds . diffAbsTime x
printDuration . realToFrac . (x -)
printDuration NominalDiffTime Text
printDuration :: NominalDiffTime -> Text
printDuration diff
| diff < 60 = p "%Ss"
| diff < 60 * 60 = p "%Mm%Ss"
@ -478,5 +475,5 @@ printDuration diff
where
p x = toText $ formatTime defaultTimeLocale x diff
timeDiffSeconds Int Text
timeDiffSeconds :: Int -> Text
timeDiffSeconds = printDuration . fromIntegral

View File

@ -21,15 +21,15 @@ module NOM.Print.Table (
displayWidthBS,
) where
import Relude hiding (truncate)
import Control.Exception (assert)
import Data.Text qualified as Text
-- wcwidth
import Data.Char.WCWidth (wcwidth)
-- ansi-terminal
import Data.ByteString.Char8 qualified as ByteString
import Data.Char.WCWidth (wcwidth)
import Data.Text qualified as Text
import Relude hiding (truncate)
import System.Console.ANSI (
Color (Black, Blue, Green, Magenta, Red, Yellow),
ColorIntensity (Dull, Vivid),
@ -39,8 +39,6 @@ import System.Console.ANSI (
setSGRCode,
)
import Data.ByteString.Char8 qualified as ByteString
data Entry = Entry
{ codes :: [SGR]
, lcontent :: Text