diff options
| -rw-r--r-- | Biz/Bild.hs | 97 | ||||
| -rw-r--r-- | Biz/Log.hs | 7 |
2 files changed, 70 insertions, 34 deletions
diff --git a/Biz/Bild.hs b/Biz/Bild.hs index 8e64e43..ed59598 100644 --- a/Biz/Bild.hs +++ b/Biz/Bild.hs @@ -111,7 +111,9 @@ import qualified Biz.Namespace as Namespace import qualified Biz.Test as Test import qualified Control.Concurrent.Async as Async import qualified Data.Aeson as Aeson +import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as Char8 +import qualified Data.ByteString.Internal as BSI import qualified Data.ByteString.Lazy as ByteString import qualified Data.Char as Char import Data.Conduit ((.|)) @@ -256,13 +258,29 @@ data Target = Target sysdeps :: Set Dep, -- | Which compiler should we use? compiler :: Compiler, - -- | Where is this machine being built? Schema: user@location - builder :: Text, + -- | Where is this machine being built? + builder :: Builder, -- | Flags and arguments passed to 'Compiler' when building compilerFlags :: [Text] } deriving (Show, Generic, Aeson.ToJSON) +data Builder + = -- | Local <user> + Local Text + | -- | Remote <user> <host> + Remote Text Text + deriving (Show, Generic) + +instance Aeson.ToJSON Builder where + toJSON (Local u) = Aeson.String u + toJSON (Remote u host) = Aeson.String <| u <> "@" <> host + +toNixFlag :: Builder -> String +toNixFlag = \case + Local _ -> "" + Remote u h -> Text.unpack <| Text.concat ["ssh://", u, "@", h, "?ssh-key=/home/", u, "/.ssh/id_rsa"] + -- | We can't build everything yet... isBuildableNs :: Namespace -> Bool isBuildableNs = \case @@ -378,7 +396,7 @@ analyze hmap ns = case Map.lookup ns hmap of Target { langdeps = Set.empty, -- c has no lang deps...? compiler = Gcc, - builder = user <> "@localhost", + builder = Local <| user, compilerFlags = concat [ [o, dir, Text.pack absPath] ++ guileFlags @@ -401,7 +419,7 @@ analyze hmap ns = case Map.lookup ns hmap of Just </ pure Target - { builder = user <> "@localhost", + { builder = Local <| user, compiler = detectGhcCompiler out, compilerFlags = map @@ -458,21 +476,15 @@ analyze hmap ns = case Map.lookup ns hmap of "--eval", "(sb-ext:save-lisp-and-die #p\"" <> (root </> outToPath out) <> "\" :toplevel #'main :executable t)" ], - builder = user <> "@localhost", + builder = Local <| user, outPath = outToPath out, .. } Namespace.Nix -> do let builder = (host == "lithium") - ?: ( "local", - Text.concat - [ "ssh://", - user, - "@dev.simatime.com?ssh-key=/home/", - user, - "/.ssh/id_rsa" - ] + ?: ( Local user, + Remote user "dev.simatime.com" ) Just </ pure @@ -487,7 +499,7 @@ analyze hmap ns = case Map.lookup ns hmap of "--out-link", root </> nixdir </> Namespace.toPath namespace, "--builders", - Text.unpack builder + toNixFlag builder ], out = None, outPath = outToPath None, @@ -516,7 +528,7 @@ analyze hmap ns = case Map.lookup ns hmap of "--output=" ++ root </> intdir </> replaceExtension path ".scm.go", path ], - builder = user <> "@localhost", + builder = Local user, outPath = outToPath out, .. } @@ -535,7 +547,7 @@ analyze hmap ns = case Map.lookup ns hmap of sysdeps = Set.empty, compiler = Rustc, compilerFlags = map Text.pack [path, "-o", root </> outToPath out], - builder = user <> "@localhost", + builder = Local user, outPath = outToPath out, .. } @@ -660,8 +672,11 @@ build andTest loud analysis = do Dir.setPermissions (root </> outToPath out) (Dir.setOwnerExecutable True p) pure Exit.ExitSuccess NixBuild -> do - Log.info ["bild", "nix", builder, nschunk namespace] + Log.info ["bild", "nix", toLog builder, nschunk namespace] proc loud namespace "nix-build" compilerFlags + where + toLog (Local u) = u + toLog (Remote u h) = u <> "@" <> h Copy -> do Log.warn ["bild", "copy", "TODO", nschunk namespace] pure Exit.ExitSuccess @@ -683,21 +698,24 @@ data Proc = Proc -- | Run a subprocess, streaming output if --loud is set. run :: Proc -> IO Exit.ExitCode -run Proc {..} = do - (Conduit.Inherited, stdout_, stderr_, cph) <- Conduit.streamingProcess <| Conduit.proc cmd args - exitcode <- - if loud - then - Async.runConcurrently - <| Async.Concurrently (puts stdout_) - *> (Async.Concurrently <| Conduit.waitForStreamingProcess cph) - else - Async.runConcurrently - <| Async.Concurrently - <| Conduit.waitForStreamingProcess cph - if isFailure exitcode - then puts stderr_ >> onFailure >> pure exitcode - else onSuccess >> pure exitcode +run Proc {..} = + Conduit.proc cmd args |> Conduit.streamingProcess + +> \(Conduit.UseProvidedHandle, stdin_, stderr_, hdl) -> + loud ?: (verboseLog stdin_ stderr_ hdl, shortLog stdin_ stderr_ hdl) + +> \case + Exit.ExitFailure n -> puts stderr_ >> onFailure >> pure (Exit.ExitFailure n) + Exit.ExitSuccess -> onSuccess >> pure Exit.ExitSuccess + where + verboseLog stdin_ stderr_ hdl = + Async.runConcurrently + <| Async.Concurrently (puts stdin_) + *> Async.Concurrently (puts stderr_) + *> Async.Concurrently (Conduit.waitForStreamingProcess hdl) + shortLog stdin_ stderr_ hdl = + Async.runConcurrently + <| Async.Concurrently (logs ns stdin_) + *> Async.Concurrently (logs ns stderr_) + *> Async.Concurrently (Conduit.waitForStreamingProcess hdl) -- | Helper for running a standard bild subprocess. proc :: Bool -> Namespace -> String -> [Text] -> IO Exit.ExitCode @@ -714,7 +732,20 @@ proc loud namespace cmd args = -- | Helper for printing during a subprocess puts :: Conduit.ConduitM () ByteString IO () -> IO () -puts thing = Conduit.runConduit <| thing .| Conduit.mapM_ putStr +puts src = Conduit.runConduit <| src .| Conduit.mapM_ putStr + +-- | Like 'puts' but logs the output via 'Biz.Log'. +logs :: Namespace -> Conduit.ConduitM () ByteString IO () -> IO () +logs ns src = + Conduit.runConduit + <| src + .| Conduit.mapM_ + ( BS.filter (/= BSI.c2w '\n') + .> (\t -> Log.fmt ["info", "bild", nschunk ns, decodeUtf8 t]) + .> Text.take 77 + .> (<> "...\r") + .> putStr + ) nschunk :: Namespace -> Text nschunk = Namespace.toPath .> Text.pack @@ -23,6 +23,7 @@ module Biz.Log -- * Low-level msg, + fmt, br, ) where @@ -57,7 +58,7 @@ msg lvl labels = where -- For systemd-journal, emacs *compilation* buffers, etc. putDumb = putStr <| txt <> "\n" - txt = Text.intercalate gap (label : labels) + txt = fmt (label : labels) (color, label) = case lvl of Good -> (green, "good") Pass -> (green, "pass") @@ -67,6 +68,10 @@ msg lvl labels = Mark -> (magenta, "mark") clear = "\ESC[2K" +-- | Helper function for formatting outputs of labels. +fmt :: [Text] -> Text +fmt = Text.intercalate gap + gap :: Text gap = ": " |