diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Command.hs | 10 | ||||
| -rw-r--r-- | src/Command/Run.hs | 38 | ||||
| -rw-r--r-- | src/Job.hs | 28 | ||||
| -rw-r--r-- | src/Main.hs | 24 | ||||
| -rw-r--r-- | src/Output.hs | 99 | ||||
| -rw-r--r-- | src/Terminal.hs | 27 |
6 files changed, 183 insertions, 43 deletions
diff --git a/src/Command.hs b/src/Command.hs index 6322818..39ab675 100644 --- a/src/Command.hs +++ b/src/Command.hs @@ -12,7 +12,7 @@ module Command ( getRootPath, getJobRoot, getRepo, getDefaultRepo, tryGetDefaultRepo, getEvalInput, cmdEvalWith, - getTerminalOutput, + getOutput, getStorageDir, ) where @@ -31,8 +31,8 @@ import System.IO import Config import Eval +import Output import Repo -import Terminal data CommonOptions = CommonOptions { optJobs :: Int @@ -102,7 +102,7 @@ data CommandInput = CommandInput , ciJobRoot :: JobRoot , ciContainingRepo :: Maybe Repo , ciOtherRepos :: [ ( RepoName, Repo ) ] - , ciTerminalOutput :: TerminalOutput + , ciOutput :: Output , ciStorageDir :: FilePath } @@ -143,8 +143,8 @@ cmdEvalWith :: (EvalInput -> EvalInput) -> Eval a -> CommandExec a cmdEvalWith f ev = do either (tfail . textEvalError) return =<< liftIO .runEval ev . f =<< getEvalInput -getTerminalOutput :: CommandExec TerminalOutput -getTerminalOutput = CommandExec (asks ciTerminalOutput) +getOutput :: CommandExec Output +getOutput = CommandExec (asks ciOutput) getStorageDir :: CommandExec FilePath getStorageDir = CommandExec (asks ciStorageDir) diff --git a/src/Command/Run.hs b/src/Command/Run.hs index 9370eca..593412c 100644 --- a/src/Command/Run.hs +++ b/src/Command/Run.hs @@ -10,6 +10,7 @@ import Control.Monad.IO.Class import Data.Either import Data.List +import Data.Maybe import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T @@ -23,6 +24,7 @@ import Config import Eval import Job import Job.Types +import Output import Repo import Terminal @@ -231,7 +233,7 @@ watchTagSource pat = do cmdRun :: RunCommand -> CommandExec () cmdRun (RunCommand RunOptions {..} args) = do CommonOptions {..} <- getCommonOptions - tout <- getTerminalOutput + output <- getOutput storageDir <- getStorageDir ( rangeOptions, jobOptions ) <- partitionEithers . concat <$> sequence @@ -277,7 +279,7 @@ cmdRun (RunCommand RunOptions {..} args) = do mngr <- newJobManager storageDir optJobs source <- mergeSources $ concat [ [ defaultSource, argumentJobs ], ranges, branches, tags ] - headerLine <- newLine tout "" + mbHeaderLine <- mapM (flip newLine "") (outputTerminal output) threadCount <- newTVarIO (0 :: Int) let changeCount f = atomically $ do @@ -292,9 +294,10 @@ cmdRun (RunCommand RunOptions {..} args) = do loop pnames (Just ( jobset : rest, next )) = do let names = nub $ (pnames ++) $ map jobName $ jobsetJobs jobset when (names /= pnames) $ do - redrawLine headerLine $ T.concat $ - T.replicate (8 + 50) " " : - map ((" " <>) . fitToLength 7 . textJobName) names + forM_ mbHeaderLine $ \headerLine -> do + redrawLine headerLine $ T.concat $ + T.replicate (8 + 50) " " : + map ((" " <>) . fitToLength 7 . textJobName) names let commit = jobsetCommit jobset shortCid = T.pack $ take 7 $ maybe (repeat ' ') (showCommitId . commitId) commit @@ -302,16 +305,20 @@ cmdRun (RunCommand RunOptions {..} args) = do case jobsetJobsEither jobset of Right jobs -> do - outs <- runJobs mngr tout commit jobs + outs <- runJobs mngr output commit jobs let findJob name = snd <$> find ((name ==) . jobName . fst) outs - line <- newLine tout "" + statuses = map findJob names + forM_ (outputTerminal output) $ \tout -> do + line <- newLine tout "" + void $ forkIO $ do + displayStatusLine tout line shortCid (" " <> shortDesc) statuses mask $ \restore -> do changeCount (+ 1) - void $ forkIO $ (>> changeCount (subtract 1)) $ - try @SomeException $ restore $ do - displayStatusLine tout line shortCid (" " <> shortDesc) $ map findJob names + void $ forkIO $ do + void $ try @SomeException $ restore $ waitForJobStatuses statuses + changeCount (subtract 1) Left err -> do - void $ newLine tout $ + forM_ (outputTerminal output) $ flip newLine $ "\ESC[91m" <> shortCid <> "\ESC[0m" <> " " <> shortDesc <> " \ESC[91m" <> T.pack err <> "\ESC[0m" loop names (Just ( rest, next )) @@ -332,7 +339,7 @@ showStatus blink = \case JobWaiting uses -> "\ESC[94m~" <> fitToLength 6 (T.intercalate "," (map textJobName uses)) <> "\ESC[0m" JobSkipped -> "\ESC[0m-\ESC[0m " JobRunning -> "\ESC[96m" <> (if blink then "*" else "•") <> "\ESC[0m " - JobError fnote -> "\ESC[91m" <> fitToLength 7 ("!! [" <> T.pack (show (footnoteNumber fnote)) <> "]") <> "\ESC[0m" + JobError fnote -> "\ESC[91m" <> fitToLength 7 ("!! [" <> T.pack (maybe "?" (show . tfNumber) (footnoteTerminal fnote)) <> "]") <> "\ESC[0m" JobFailed -> "\ESC[91m✗\ESC[0m " JobCancelled -> "\ESC[0mC\ESC[0m " JobDone _ -> "\ESC[92m✓\ESC[0m " @@ -364,3 +371,10 @@ displayStatusLine tout line prefix1 prefix2 statuses = do if all (maybe True jobStatusFinished) ss then return () else go cur + +waitForJobStatuses :: [ Maybe (TVar (JobStatus a)) ] -> IO () +waitForJobStatuses mbstatuses = do + let statuses = catMaybes mbstatuses + atomically $ do + ss <- mapM readTVar statuses + when (any (not . jobStatusFinished) ss) retry @@ -38,8 +38,8 @@ import System.Posix.Signals import System.Process import Job.Types +import Output import Repo -import Terminal data JobOutput = JobOutput @@ -61,7 +61,7 @@ data JobStatus a = JobQueued | JobWaiting [JobName] | JobRunning | JobSkipped - | JobError TerminalFootnote + | JobError OutputFootnote | JobFailed | JobCancelled | JobDone a @@ -181,7 +181,7 @@ runManagedJob JobManager {..} tid cancel job = bracket acquire release $ \case writeTVar jmRunningTasks . M.delete tid =<< readTVar jmRunningTasks -runJobs :: JobManager -> TerminalOutput -> Maybe Commit -> [ Job ] -> IO [ ( Job, TVar (JobStatus JobOutput) ) ] +runJobs :: JobManager -> Output -> Maybe Commit -> [ Job ] -> IO [ ( Job, TVar (JobStatus JobOutput) ) ] runJobs mngr@JobManager {..} tout commit jobs = do results <- atomically $ do forM jobs $ \job -> do @@ -197,12 +197,14 @@ runJobs mngr@JobManager {..} tout commit jobs = do return statusVar forM_ results $ \( job, tid, outVar ) -> void $ forkIO $ do - let handler e = if - | Just JobCancelledException <- fromException e -> do - atomically $ writeTVar outVar $ JobCancelled - | otherwise -> do - footnote <- newFootnote tout $ T.pack $ displayException e - atomically $ writeTVar outVar $ JobError footnote + let handler e = do + status <- if + | Just JobCancelledException <- fromException e -> do + return JobCancelled + | otherwise -> do + JobError <$> outputFootnote tout (T.pack $ displayException e) + atomically $ writeTVar outVar status + outputEvent tout $ JobFinished (jobId job) (textJobStatus status) handle handler $ do res <- runExceptT $ do duplicate <- liftIO $ atomically $ do @@ -217,6 +219,7 @@ runJobs mngr@JobManager {..} tout commit jobs = do uses <- waitForUsedArtifacts tout job results outVar runManagedJob mngr tid (return JobCancelled) $ do liftIO $ atomically $ writeTVar outVar JobRunning + liftIO $ outputEvent tout $ JobStarted (jobId job) prepareJob jmDataDir commit job $ \checkoutPath jdir -> do updateStatusFile (jdir </> "status") outVar JobDone <$> runJob job uses checkoutPath jdir @@ -237,17 +240,18 @@ runJobs mngr@JobManager {..} tout commit jobs = do liftIO wait atomically $ writeTVar outVar $ either id id res + outputEvent tout $ JobFinished (jobId job) (textJobStatus $ either id id res) return $ map (\( job, _, var ) -> ( job, var )) results waitForUsedArtifacts :: (MonadIO m, MonadError (JobStatus JobOutput) m) => - TerminalOutput -> + Output -> Job -> [ ( Job, TaskId, TVar (JobStatus JobOutput) ) ] -> TVar (JobStatus JobOutput) -> m [ ArtifactOutput ] waitForUsedArtifacts tout job results outVar = do origState <- liftIO $ atomically $ readTVar outVar ujobs <- forM (jobUses job) $ \(ujobName@(JobName tjobName), uartName) -> do case find (\( j, _, _ ) -> jobName j == ujobName) results of Just ( _, _, var ) -> return ( var, ( ujobName, uartName )) - Nothing -> throwError . JobError =<< liftIO (newFootnote tout $ "Job '" <> tjobName <> "' not found") + Nothing -> throwError . JobError =<< liftIO (outputFootnote tout $ "Job '" <> tjobName <> "' not found") let loop prev = do ustatuses <- atomically $ do @@ -266,7 +270,7 @@ waitForUsedArtifacts tout job results outVar = do case ustatus of JobDone out -> case find ((==uartName) . aoutName) $ outArtifacts out of Just art -> return art - Nothing -> throwError . JobError =<< liftIO (newFootnote tout $ "Artifact '" <> tjobName <> "." <> tartName <> "' not found") + Nothing -> throwError . JobError =<< liftIO (outputFootnote tout $ "Artifact '" <> tjobName <> "." <> tartName <> "' not found") _ -> throwError JobSkipped updateStatusFile :: MonadIO m => FilePath -> TVar (JobStatus JobOutput) -> m () diff --git a/src/Main.hs b/src/Main.hs index 1b062e8..49aa290 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -7,9 +7,11 @@ import Control.Monad.Reader import Data.ByteString.Lazy qualified as BL import Data.List import Data.List.NonEmpty qualified as NE +import Data.Maybe import Data.Proxy import Data.Text qualified as T +import System.Console.ANSI import System.Console.GetOpt import System.Directory import System.Environment @@ -22,8 +24,8 @@ import Command.Checkout import Command.JobId import Command.Run import Config +import Output import Repo -import Terminal import Version data CmdlineOptions = CmdlineOptions @@ -31,6 +33,7 @@ data CmdlineOptions = CmdlineOptions , optShowVersion :: Bool , optCommon :: CommonOptions , optStorage :: Maybe FilePath + , optOutput :: Maybe [ OutputType ] } defaultCmdlineOptions :: CmdlineOptions @@ -39,6 +42,7 @@ defaultCmdlineOptions = CmdlineOptions , optShowVersion = False , optCommon = defaultCommonOptions , optStorage = Nothing + , optOutput = Nothing } options :: [ OptDescr (CmdlineOptions -> Except String CmdlineOptions) ] @@ -66,6 +70,15 @@ options = , Option [] [ "storage" ] (ReqArg (\value opts -> return opts { optStorage = Just value }) "<path>") "set storage path" + , Option [] [ "terminal-output" ] + (NoArg $ \opts -> return opts { optOutput = Just $ TerminalOutput : fromMaybe [] (optOutput opts) }) + "use terminal-style output (default if standard output is terminal)" + , Option [] [ "log-output" ] + (OptArg (\value opts -> return opts { optOutput = Just $ LogOutput (fromMaybe "-" value) : fromMaybe [] (optOutput opts) }) "<path>") + "use log-style output to <path> or standard output" + , Option [] [ "test-output" ] + (OptArg (\value opts -> return opts { optOutput = Just $ TestOutput (fromMaybe "-" value) : fromMaybe [] (optOutput opts) }) "<path>") + "use test-style output to <path> or standard output" ] data SomeCommandType = forall c. Command c => SC (Proxy c) @@ -241,5 +254,10 @@ runSomeCommand rootPath gopts (SC tproxy) args = do let ciOtherRepos = configRepos ++ cmdlineRepos - ciTerminalOutput <- initTerminalOutput - flip runReaderT CommandInput {..} exec + outputTypes <- case optOutput gopts of + Just types -> return types + Nothing -> hSupportsANSI stdout >>= return . \case + True -> [ TerminalOutput ] + False -> [ LogOutput "-" ] + withOutput outputTypes $ \ciOutput -> do + flip runReaderT CommandInput {..} exec diff --git a/src/Output.hs b/src/Output.hs new file mode 100644 index 0000000..54b434e --- /dev/null +++ b/src/Output.hs @@ -0,0 +1,99 @@ +module Output ( + Output, + OutputType(..), + OutputEvent(..), + OutputFootnote(..), + + withOutput, + outputTerminal, + outputEvent, + outputFootnote, +) where + +import Control.Monad +import Control.Monad.Catch + +import Data.Text (Text) +import Data.Text.IO qualified as T + +import System.IO + +import Job.Types +import Terminal + + +data Output = Output + { outTerminal :: Maybe TerminalOutput + , outLogs :: [ Handle ] + , outTest :: [ Handle ] + } + +data OutputType + = TerminalOutput + | LogOutput FilePath + | TestOutput FilePath + deriving (Eq, Ord) + +data OutputEvent + = OutputMessage Text + | JobStarted JobId + | JobFinished JobId Text + +data OutputFootnote = OutputFootnote + { footnoteText :: Text + , footnoteTerminal :: Maybe TerminalFootnote + } + deriving (Eq) + + +withOutput :: [ OutputType ] -> (Output -> IO a) -> IO a +withOutput types inner = go types (Output Nothing [] []) + where + go (TerminalOutput : ts) out = do + term <- initTerminalOutput + go ts out { outTerminal = Just term } + go (LogOutput path : ts) out = withOutputFile path $ \h -> do + go ts out { outLogs = h : outLogs out } + go (TestOutput path : ts) out = withOutputFile path $ \h -> do + go ts out { outTest = h : outTest out } + go [] out = inner out + + withOutputFile "-" f = hSetBuffering stdout LineBuffering >> f stdout + withOutputFile path f = bracket (openFile' path) hClose f + openFile' path = do + h <- openFile path WriteMode + hSetBuffering h LineBuffering + return h + + +outputTerminal :: Output -> Maybe TerminalOutput +outputTerminal = outTerminal + +outStrLn :: Output -> Handle -> Text -> IO () +outStrLn Output {..} h text + | Just tout <- outTerminal, terminalHandle tout == h = do + void $ newLine tout text + | otherwise = do + T.hPutStrLn h text + +outputEvent :: Output -> OutputEvent -> IO () +outputEvent out@Output {..} = \case + OutputMessage msg -> do + forM_ outTerminal $ \term -> void $ newLine term msg + forM_ outLogs $ \h -> outStrLn out h msg + forM_ outTest $ \h -> outStrLn out h ("msg " <> msg) + + JobStarted jid -> do + forM_ outLogs $ \h -> outStrLn out h ("Started " <> textJobId jid) + forM_ outTest $ \h -> outStrLn out h ("job-start " <> textJobId jid) + + JobFinished jid status -> do + forM_ outLogs $ \h -> outStrLn out h ("Finished " <> textJobId jid <> " (" <> status <> ")") + forM_ outTest $ \h -> outStrLn out h ("job-finish " <> textJobId jid <> " " <> status) + +outputFootnote :: Output -> Text -> IO OutputFootnote +outputFootnote out@Output {..} footnoteText = do + footnoteTerminal <- forM outTerminal $ \term -> newFootnote term footnoteText + forM_ outLogs $ \h -> outStrLn out h footnoteText + forM_ outTest $ \h -> outStrLn out h ("note " <> footnoteText) + return OutputFootnote {..} diff --git a/src/Terminal.hs b/src/Terminal.hs index aa7335c..1e71559 100644 --- a/src/Terminal.hs +++ b/src/Terminal.hs @@ -6,6 +6,7 @@ module Terminal ( newLine, redrawLine, newFootnote, + terminalHandle, terminalBlinkStatus, ) where @@ -22,7 +23,8 @@ import System.IO data TerminalOutput = TerminalOutput - { outNumLines :: MVar Int + { outHandle :: Handle + , outNumLines :: MVar Int , outNextFootnote :: MVar Int , outBlinkVar :: TVar Bool } @@ -37,14 +39,14 @@ data TerminalLine = TerminalLine deriving (Eq) data TerminalFootnote = TerminalFootnote - { footnoteLine :: TerminalLine - , footnoteNumber :: Int - , footnoteText :: Text + { tfLine :: TerminalLine + , tfNumber :: Int } deriving (Eq) initTerminalOutput :: IO TerminalOutput initTerminalOutput = do + outHandle <- return stdout outNumLines <- newMVar 0 outNextFootnote <- newMVar 1 outBlinkVar <- newTVarIO False @@ -57,7 +59,7 @@ newLine :: TerminalOutput -> Text -> IO TerminalLine newLine lineOutput@TerminalOutput {..} text = do modifyMVar outNumLines $ \lineNum -> do T.putStrLn text - hFlush stdout + hFlush outHandle return ( lineNum + 1, TerminalLine {..} ) redrawLine :: TerminalLine -> Text -> IO () @@ -66,14 +68,17 @@ redrawLine TerminalLine {..} text = do withMVar outNumLines $ \total -> do let moveBy = total - lineNum T.putStr $ "\ESC[s\ESC[" <> T.pack (show moveBy) <> "F" <> text <> "\ESC[u" - hFlush stdout + hFlush outHandle newFootnote :: TerminalOutput -> Text -> IO TerminalFootnote -newFootnote tout@TerminalOutput {..} footnoteText = do - modifyMVar outNextFootnote $ \footnoteNumber -> do - footnoteLine <- newLine tout $ "[" <> T.pack (show footnoteNumber) <> "] " <> footnoteText - hFlush stdout - return ( footnoteNumber + 1, TerminalFootnote {..} ) +newFootnote tout@TerminalOutput {..} text = do + modifyMVar outNextFootnote $ \tfNumber -> do + tfLine <- newLine tout $ "[" <> T.pack (show tfNumber) <> "] " <> text + hFlush outHandle + return ( tfNumber + 1, TerminalFootnote {..} ) + +terminalHandle :: TerminalOutput -> Handle +terminalHandle = outHandle terminalBlinkStatus :: TerminalOutput -> STM Bool terminalBlinkStatus TerminalOutput {..} = readTVar outBlinkVar |