From 30d03210f7ac5b12235760f625bac5ff3aa3f85a Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Wed, 16 Aug 2023 13:45:40 -0400 Subject: Log and return output to caller The main change here is 'puts' now returns a value, this enables me to collect the value from the conduit source while also doing stuff with it, like printing or logging it as I want. Previously I was running conduit over the source, *and then* kicking off the concurrent processes to wait for the process and collect the output. This would (I think) drain the source before it got to the 'puts' conduit run, and so I wouldn't be able to get the output streamed in real time. It took a lot of refactoring and exploratory programming to get to this relatively-small diff, but now puts works correctly. At least I think it does... it seems to work more reliably from ghci than from the shell. Maybe the shell or TERM is causing nix-store to do some buffering? Maybe I need to use the threaded runtime in GHC? Not sure, but I will look out for this issue and try to identify and fix. Update: yep it was the threaded runtime. I enabled that and now it works in the shell. I squashed that commit into this one. --- Biz/Bild.hs | 102 ++++++++++++++++++++++++++-------------------- Biz/Bild.nix | 6 +-- Biz/Bild/Deps/Haskell.nix | 1 + Biz/Lint.hs | 3 +- Biz/Log.hs | 4 ++ 5 files changed, 66 insertions(+), 50 deletions(-) (limited to 'Biz') diff --git a/Biz/Bild.hs b/Biz/Bild.hs index 2dc1e64..a9988d5 100644 --- a/Biz/Bild.hs +++ b/Biz/Bild.hs @@ -125,19 +125,20 @@ import qualified Biz.Test as Test import qualified Conduit import qualified Control.Concurrent.Async as Async import qualified Data.Aeson as Aeson -import qualified Data.ByteString as BS +import qualified Data.ByteString as ByteString import qualified Data.ByteString.Char8 as Char8 import qualified Data.ByteString.Internal as BSI -import qualified Data.ByteString.Lazy as ByteString +import qualified Data.ByteString.Lazy as ByteString.Lazy import qualified Data.Char as Char import Data.Conduit ((.|)) -import qualified Data.Conduit.List as Conduit +import qualified Data.Conduit.Combinators as Conduit import qualified Data.Conduit.Process as Conduit import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.String as String import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO +import qualified Network.HostName as HostName import qualified System.Directory as Dir import qualified System.Environment as Env import qualified System.Exit as Exit @@ -148,7 +149,7 @@ import qualified System.Process as Process import qualified Text.Regex.Applicative as Regex main :: IO () -main = Cli.main <| Cli.Plan help move test_ pure +main = Cli.Plan help move test_ pure |> Cli.main where test_ = Test.group @@ -189,19 +190,19 @@ test_bildExamples = xs -> all (== Exit.ExitSuccess) xs @=? True move :: Cli.Arguments -> IO () -move args = do - root <- Env.getEnv "BIZ_ROOT" +move args = IO.hSetBuffering stdout IO.NoBuffering - >> pure (Cli.getAllArgs args (Cli.argument "target")) - /> filter (not <. Namespace.isCab) - +> filterM Dir.doesFileExist - +> traverse Dir.makeAbsolute - /> map (Namespace.fromPath root) - /> catMaybes - +> foldM analyze mempty - /> Map.filter (namespace .> isBuildableNs) - +> printOrBuild - +> exitSummary + >> Env.getEnv "BIZ_ROOT" +> \root -> + Cli.getAllArgs args (Cli.argument "target") + |> filter (not <. Namespace.isCab) + |> filterM Dir.doesFileExist + +> traverse Dir.makeAbsolute + /> map (Namespace.fromPath root) + /> catMaybes + +> foldM analyze mempty + /> Map.filter (namespace .> isBuildableNs) + +> printOrBuild + +> exitSummary where printOrBuild :: Analysis -> IO [ExitCode] printOrBuild targets @@ -213,7 +214,7 @@ move args = do build isTest isLoud targets isTest = args `Cli.has` Cli.longOption "test" isLoud = args `Cli.has` Cli.longOption "loud" - putJSON = Aeson.encode .> ByteString.toStrict .> Char8.putStrLn + putJSON = Aeson.encode .> ByteString.Lazy.toStrict .> Char8.putStrLn nixStore :: String nixStore = "/nix/store/00000000000000000000000000000000-" @@ -420,7 +421,7 @@ analyze hmap ns = case Map.lookup ns hmap of root <- Env.getEnv "BIZ_ROOT" let absPath = root path user <- Env.getEnv "USER" /> Text.pack - host <- Env.lookupEnv "HOSTNAME" /> fromMaybe "interactive" /> Text.pack + host <- HostName.getHostName /> Text.pack Log.info ["bild", "analyze", str path] let runw cmd args = Process.readProcess cmd args "" /> Text.pack /> Text.words contentLines <- @@ -516,6 +517,7 @@ analyze hmap ns = case Map.lookup ns hmap of packageSet = "ghcWith", compilerFlags = [ "-Werror", + "-threaded", "-i$BIZ_ROOT", "-odir", ".", @@ -798,27 +800,30 @@ data Proc = Proc -- | Run a subprocess, streaming output if --loud is set. run :: Proc -> IO (Exit.ExitCode, ByteString) run Proc {..} = do - loud ?| Log.info ["proc", unwords <| map str <| cmd : args] >> Log.br + IO.hSetBuffering stdout IO.NoBuffering + loud ?| Log.info ["proc", unwords <| map str <| cmd : args] Conduit.proc cmd args |> Conduit.streamingProcess +> \(Conduit.UseProvidedHandle, stdout_, stderr_, hdl) -> - Conduit.runConduitRes (stdout_ .| Conduit.foldC) - +> \output -> - Async.Concurrently (loud ?: (puts stdout_, logs ns stdout_)) - *> Async.Concurrently (loud ?: (puts stderr_, logs ns stderr_)) - *> Async.Concurrently (Conduit.waitForStreamingProcess hdl) - |> Async.runConcurrently - +> \case - Exit.ExitFailure n -> - puts stderr_ - >> onFailure - >> pure (Exit.ExitFailure n, output) - Exit.ExitSuccess -> - onSuccess - >> pure (Exit.ExitSuccess, output) + (,,) Async.Concurrently (loud ?: (puts stdout_, logs ns stdout_)) + <*> Async.Concurrently (loud ?: (puts stderr_, logs ns stderr_)) + |> Async.runConcurrently + +> \case + (Exit.ExitFailure n, output, outerr) -> + putStr outerr + >> onFailure + >> pure (Exit.ExitFailure n, output) + (Exit.ExitSuccess, output, _) -> + onSuccess >> pure (Exit.ExitSuccess, output) -- | Helper for running a standard bild subprocess. -proc :: Bool -> Namespace -> String -> [Text] -> IO (Exit.ExitCode, ByteString) +proc :: + Bool -> + Namespace -> + String -> + [Text] -> + IO (Exit.ExitCode, ByteString) proc loud namespace cmd args = Proc { loud = loud, @@ -831,25 +836,31 @@ proc loud namespace cmd args = |> run -- | Helper for printing during a subprocess -puts :: Conduit.ConduitT () ByteString (Conduit.ResourceT IO) () -> IO () -puts src = Conduit.runConduitRes <| src .| Conduit.mapM_ putStr - --- | Like 'puts' but the output goes to a file. Maybe this should use /tmp by default though? -putsToTmp :: Conduit.ConduitT () ByteString (Conduit.ResourceT IO) () -> FilePath -> IO () -putsToTmp src filepath = Conduit.runConduitRes <| src .| Conduit.sinkFile filepath +puts :: + Conduit.ConduitT () ByteString (Conduit.ResourceT IO) () -> + IO ByteString +puts src = + Conduit.runConduitRes + <| src + .| Conduit.iterM (liftIO <. putStr) + .| Conduit.foldC -- | Like 'puts' but logs the output via 'Biz.Log'. -logs :: Namespace -> Conduit.ConduitT () ByteString (Conduit.ResourceT IO) () -> IO () +logs :: + Namespace -> + Conduit.ConduitT () ByteString (Conduit.ResourceT IO) () -> + IO ByteString logs ns src = Conduit.runConduitRes <| src - .| Conduit.mapM_ - ( BS.filter (/= BSI.c2w '\n') + .| Conduit.iterM + ( ByteString.filter (/= BSI.c2w '\n') .> (\t -> Log.fmt ["info", "bild", nschunk ns, decodeUtf8 t]) - .> Text.take 77 - .> (<> "...\r") + .> Text.take 79 + .> (<> "…\r") .> putStr ) + .| Conduit.foldC nschunk :: Namespace -> Text nschunk = Namespace.toPath .> Text.pack @@ -886,6 +897,7 @@ nixBuild :: Bool -> Target -> IO (Exit.ExitCode, ByteString) nixBuild loud Target {..} = Env.getEnv "BIZ_ROOT" +> \root -> instantiate root |> run +> \case + (_, "") -> panic "instantiate did not produce a drv" (Exit.ExitSuccess, drv) -> drv |> str diff --git a/Biz/Bild.nix b/Biz/Bild.nix index 0391d84..dca1b3b 100644 --- a/Biz/Bild.nix +++ b/Biz/Bild.nix @@ -32,7 +32,7 @@ rec { ghcPackageSetBild = private.ghcWith (hpkgs: with hpkgs; [ aeson async base bytestring conduit conduit-extra containers directory docopt filepath process protolude rainbow regex-applicative split tasty - tasty-hunit tasty-quickcheck text neat-interpolation + tasty-hunit tasty-quickcheck text hostname wai # can remove when removed from Biz.Log ]); @@ -50,14 +50,13 @@ rec { # this is just to get access to ghc-pkg in bild (private.ghcWith (hpkgs: with hpkgs; [])) - /* disable until nixified builds are complete + /* disable until nixified builds are complete */ rustc # c deps gcc gdb valgrind argp-standalone SDL # lisp deps guile (private.sbclWith (p: with p; [asdf alexandria])) # just enough to build Example.lisp - */ ]; # a standard nix build for `bild` - this should be the only hand-written @@ -75,6 +74,7 @@ rec { ${private.ghcPackageSetFull}/lib/ghc-${private.ghcPackageSetFull.version}/package.conf.d \ $out/lib/ghc-${private.ghcPackageSetFull.version} ghc \ + -threaded \ -Werror \ -i. \ --make Biz/Bild.hs \ diff --git a/Biz/Bild/Deps/Haskell.nix b/Biz/Bild/Deps/Haskell.nix index d8108d7..066fd86 100644 --- a/Biz/Bild/Deps/Haskell.nix +++ b/Biz/Bild/Deps/Haskell.nix @@ -27,6 +27,7 @@ with hpkgs; hashids haskeline hmacaroons + hostname http-types ixset katip diff --git a/Biz/Lint.hs b/Biz/Lint.hs index b1cc0d4..f9b16d0 100644 --- a/Biz/Lint.hs +++ b/Biz/Lint.hs @@ -14,7 +14,6 @@ import Biz.Namespace (Ext (..), Namespace (..)) import qualified Biz.Namespace as Namespace import Biz.Test ((@=?)) import qualified Biz.Test as Test -import qualified Control.Concurrent.Async as Async import qualified Data.String as String import qualified Data.Text as Text import qualified System.Directory as Directory @@ -153,7 +152,7 @@ run :: Mode -> [FilePath] -> IO [Result] run mode paths = do cwd <- Directory.getCurrentDirectory root <- Environment.getEnv "BIZ_ROOT" - concat FilePath -> FilePath -> FilePath -> IO [Result] runOne mode root cwd path_ = results +> traverse_ printResult >> results diff --git a/Biz/Log.hs b/Biz/Log.hs index a1afd1d..8dba657 100644 --- a/Biz/Log.hs +++ b/Biz/Log.hs @@ -10,6 +10,10 @@ -- -- * don't use `br` after `info`, unless verbose mode is requested (--loud flag in bild) -- +-- * always use `br` after `good`, `fail`, and `pass` +-- +-- * often use `br` after `warn`, unless its really unimportant +-- -- * labels should be roughly hierarchical from general->specific module Biz.Log ( Lvl (..), -- cgit v1.2.3