Improve bild logging

1 files changed, 64 insertions, 33 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