diff options
Diffstat (limited to 'Biz/Bild.hs')
| -rw-r--r-- | Biz/Bild.hs | 102 |
1 files changed, 57 insertions, 45 deletions
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 (Conduit.waitForStreamingProcess hdl) + <*> 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 |