add loggingmain

2 files changed, 99 insertions, 40 deletions

diff --git a/abuilder.cabal b/abuilder.cabal
index fae0635..8bfc6ad 100644
--- a/abuilder.cabal
+++ b/abuilder.cabal
@@ -23,6 +23,9 @@ executable abuilder
         gitlib-libgit2,
         hinotify,
         mtl,
+        prettyprinter,
+        prettyprinter-ansi-terminal,
+        process,
         split,
         stm,
         string-interpolate,
diff --git a/app/Main.hs b/app/Main.hs
index 07767a6..4f4a35d 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -8,14 +8,15 @@
 
 module Main where
 
+import Control.Arrow ((***))
 import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Exception
 import Control.Monad
 import Data.ByteString.Char8 qualified as B
 import Data.ByteString.Lazy qualified as LB
-import Data.ByteString.Lazy.UTF8 qualified as LB
-import Data.ByteString.UTF8 qualified as B
+import Data.ByteString.UTF8 qualified as B (fromString, toString)
+import Data.List
 import Data.List.Split
 import Data.Map.Merge.Strict qualified as M
 import Data.Map.Strict qualified as M
@@ -24,8 +25,11 @@ import Data.String
 import Data.String.Interpolate (i)
 import Data.Tagged
 import Data.Text qualified as T
+import Debug.Trace
 import Git
 import Git.Libgit2
+import Prettyprinter
+import Prettyprinter.Render.Terminal
 import System.Directory
 import System.Environment
 import System.FilePath
@@ -33,7 +37,9 @@ import System.INotify
 import System.IO
 import System.IO.Temp
 import System.IO.Unsafe
+import System.Process (CmdSpec (..))
 import System.Process.Typed
+import System.Process.Typed.Internal
 import Text.Printf
 
 stateDirectory :: FilePath
@@ -54,6 +60,11 @@ urls =
 concurrentBuilders :: Int
 concurrentBuilders = 2
 
+logLevel :: Importance
+logLevel =
+  maybe Info (toEnum . read) $
+    unsafePerformIO (lookupEnv "ABUILDER_LOG_LEVEL")
+
 type DesiredOutputs = M.Map JobName CommitHash
 
 type CommitHash = String
@@ -133,13 +144,20 @@ completeBuildJob (BuildJob {jobName, commitHash}) buildJobs =
 data Builder = Builder Int
   deriving (Show)
 
-data LogEntry = BuildEntry
-  { builder :: Builder,
-    buildJob :: BuildJob,
-    payload :: LB.ByteString
+data LogEntry = LogEntry
+  { component :: String,
+    importance :: Importance,
+    message :: Doc AnsiStyle
   }
   deriving (Show)
 
+data Importance
+  = Error
+  | Info
+  | Warning
+  | Debug
+  deriving (Show, Eq, Ord, Enum)
+
 main :: IO ()
 main = do
   hSetBuffering stderr LineBuffering
@@ -152,15 +170,23 @@ main = do
   createDirectoryIfMissing True stateDirectory
   setCurrentDirectory stateDirectory
   mapM_
-    (forkIO . builder logs buildJobsT)
+    (\_ -> forkIO (builder logs buildJobsT))
     (map Builder [1 .. concurrentBuilders])
-  mapM_ (uncurry (watch inotify desiredOutputsT)) (M.toList urls)
+  mapM_ (uncurry (watch inotify logs desiredOutputsT)) (M.toList urls)
   _ <- forkIO (scheduler desiredOutputsT actualOutputsT buildJobsT)
   forever do
     log <- atomically $ readTQueue logs
     case log of
-      BuildEntry _ (BuildJob {jobName}) (LB.toString -> payload) ->
-        printf "[%s] %s\n" jobName payload
+      LogEntry {component, message, importance} ->
+        when (importance <= logLevel) do
+          let c = case importance of
+                Error -> Red
+                Info -> White
+                Warning -> Yellow
+                Debug -> Black
+          putDoc . annotate (color c) $
+            annotate bold (brackets (pretty component))
+              <+> message <> hardline
 
 scheduler ::
   TVar DesiredOutputs ->
@@ -179,8 +205,8 @@ scheduler desiredOutputsT actualOutputsT buildJobsT = do
     writeTVar buildJobsT (replaceBuildJobs buildJobs buildJobs')
     writeTVar lastDesiredOutputsT (Just desiredOutputs)
 
-builder :: TQueue LogEntry -> TVar BuildJobs -> Builder -> IO ()
-builder logs buildJobsT builder =
+builder :: TQueue LogEntry -> TVar BuildJobs -> IO ()
+builder logs buildJobsT =
   forever
     ( do
         buildJob <- atomically do
@@ -190,18 +216,19 @@ builder logs buildJobsT builder =
           writeTVar buildJobsT buildJobs'
           pure (fromJust maybeBuildJob)
 
-        build logs builder buildJob
+        build logs buildJob
           `catch` ( \(e :: SomeException) -> do
                       print e
                   )
     )
 
-build :: TQueue LogEntry -> Builder -> BuildJob -> IO ()
-build logs builder buildJob@(BuildJob {jobName, commitHash}) = do
+build :: TQueue LogEntry -> BuildJob -> IO ()
+build logs (BuildJob {jobName, commitHash}) = do
   let url = urls M.! jobName
       rev = commitHash
       refDir = jobName </> ref
       tmpDir = jobName <> "-" <> rev
+  log_ logs jobName Info [printf "building commit %s" rev]
   exitCodeT <- newEmptyTMVarIO
   _ <-
     flip forkFinally (atomically . putTMVar exitCodeT) do
@@ -215,37 +242,29 @@ build logs builder buildJob@(BuildJob {jobName, commitHash}) = do
               rev = "#{rev}";
             })
           |]
-        ((B.toString . B.strip . LB.toStrict) -> drv, LB.lines -> err) <-
-          readProcess_
-            (setWorkingDir tmpDir "nix-instantiate")
-        mapM_
-          ( atomically
-              . writeTQueue logs
-              . BuildEntry builder buildJob
-          )
-          err
-        ((B.toString . B.strip . LB.toStrict) -> res, LB.lines -> err) <-
-          readProcess_
-            ( setWorkingDir
-                tmpDir
-                (fromString (printf "nix-store --realise '%s'" drv))
-            )
-        mapM_
-          ( atomically
-              . writeTQueue logs
-              . BuildEntry builder buildJob
-          )
-          err
+        drv <- sh logs jobName (setWorkingDir tmpDir "nix-instantiate")
+        res <-
+          sh logs jobName . setWorkingDir tmpDir $
+            fromString (printf "nix-store --realise '%s'" drv)
         pure res
   exitCode <- atomically $ takeTMVar exitCodeT
   case exitCode of
-    Left e -> throw e
+    Left e -> do
+      log_ logs jobName Error [printf "failed to build commit %s" rev]
+      throw e
     Right nixDir -> do
+      log_ logs jobName Info [printf "built commit %s" rev]
       createDirectoryIfMissing True jobName
-      runProcess_ (fromString (printf "nix-store --add-root '%s' --realise '%s'" refDir nixDir))
+      runProcess_ (fromString (printf ">/dev/null nix-store --add-root '%s' --realise '%s'" refDir nixDir))
 
-watch :: INotify -> TVar DesiredOutputs -> JobName -> Url -> IO ()
-watch inotify desiredOutputsT jobName url = do
+watch ::
+  INotify ->
+  TQueue LogEntry ->
+  TVar DesiredOutputs ->
+  JobName ->
+  Url ->
+  IO ()
+watch inotify logs desiredOutputsT jobName url = do
   let bareFp = url </> "refs/heads"
       nonBareFp = url </> ".git/refs/heads"
   isBare <- doesDirectoryExist bareFp
@@ -263,6 +282,7 @@ watch inotify desiredOutputsT jobName url = do
               _ -> False
       when isChange do
         updateDesiredOutputs
+  log_ logs jobName Info [printf "watching %s" url]
   updateDesiredOutputs
   where
     updateDesiredOutputs = do
@@ -272,3 +292,39 @@ watch inotify desiredOutputsT jobName url = do
       atomically do
         desiredOutputs <- readTVar desiredOutputsT
         writeTVar desiredOutputsT (M.insert jobName rev desiredOutputs)
+      log_ logs jobName Info [printf "queueing commit %s" rev]
+
+log_ :: TQueue LogEntry -> String -> Importance -> [String] -> IO ()
+log_ logs component importance messages = atomically do
+  mapM_
+    ( writeTQueue logs
+        . LogEntry component importance
+        . pretty
+    )
+    messages
+
+sh ::
+  TQueue LogEntry ->
+  String ->
+  ProcessConfig stdin stdoutIgnored stderrIgnored ->
+  IO String
+sh logs component proc = do
+  log_ logs component Debug $
+    [ printf
+        "+ %s"
+        ( case proc.pcCmdSpec of
+            RawCommand bin args -> intercalate " " (bin : args)
+            ShellCommand s -> s
+        )
+    ]
+  (out, err) <-
+    ( B.toString . B.strip . LB.toStrict
+        *** map (B.toString . B.strip) . B.lines . LB.toStrict
+      )
+      <$> readProcess_ proc
+  log_ logs component Warning err
+  pure out
+
+debug :: Show a => String -> a -> a
+debug s x =
+  trace (printf "%s: %s\n" s (show x)) x