[PATCH 2/2] gwl/ui: Protect format to currnt-error-port with mutex

[Olivier Dion]

When executing processes in parallel, outputs from threads can be mangled
together if the access is not exclusive.
---
 gwl/ui.scm | 59 +++++++++++++++++++++++++++++-------------------------
 1 file changed, 32 insertions(+), 27 deletions(-)

diff --git a/gwl/ui.scm b/gwl/ui.scm
index 35bd127..339649c 100644
--- a/gwl/ui.scm
+++ b/gwl/ui.scm
@@ -19,6 +19,7 @@
   #:use-module (guix colors)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 format)
+  #:use-module (ice-9 threads)
   #:export (G_
             log-event
 
@@ -39,6 +40,8 @@
 (define %debug-color (color BOLD MAGENTA))
 (define %execute-color (color BOLD YELLOW))
 
+(define log-mutex (make-recursive-mutex))
+
 (define* (print-diagnostic-prefix prefix #:optional location
                                   #:key (colors (color)))
   "Print PREFIX as a diagnostic line prefix."
@@ -56,36 +59,38 @@
           (colorize-string prefix colors))
         identity))
 
-  (if (location? location)
-      (format (current-error-port) "~a: ~a"
-              (location-color (location->string location))
-              (prefix-color prefix))
-      (format (current-error-port) "~a"
-              (prefix-color prefix))))
+  (with-mutex log-mutex
+    (if (location? location)
+        (format (current-error-port) "~a: ~a"
+                (location-color (location->string location))
+                (prefix-color prefix))
+        (format (current-error-port) "~a"
+                (prefix-color prefix)))))
 
 (define (log-event type . message)
   (define print?
     (or (member 'all (%config 'log-events))
         (member type (%config 'log-events))))
   (when print?
-    (case type
-      ((error)
-       (print-diagnostic-prefix (G_ "error: ") #:colors %error-color))
-      ((info)
-       (print-diagnostic-prefix (G_ "info: ") #:colors %info-color))
-      ((execute)
-       (print-diagnostic-prefix (G_ "run: ") #:colors %execute-color))
-      ((cache)
-       (print-diagnostic-prefix (G_ "cache: ") #:colors %debug-color))
-      ((debug)
-       (print-diagnostic-prefix (G_ "debug: ") #:colors %debug-color))
-      ((process)
-       (print-diagnostic-prefix (G_ "process: ") #:colors %execute-color))
-      ((guix)
-       (print-diagnostic-prefix (G_ "guix: ") #:colors %execute-color))
-      (else #true))
-    (force-output (current-error-port))
-    (format (current-error-port) "~2,2f "
-            (/ (get-internal-real-time)
-               internal-time-units-per-second))
-    (apply format (current-error-port) message)))
+    (with-mutex log-mutex
+      (case type
+        ((error)
+         (print-diagnostic-prefix (G_ "error: ") #:colors %error-color))
+        ((info)
+         (print-diagnostic-prefix (G_ "info: ") #:colors %info-color))
+        ((execute)
+         (print-diagnostic-prefix (G_ "run: ") #:colors %execute-color))
+        ((cache)
+         (print-diagnostic-prefix (G_ "cache: ") #:colors %debug-color))
+        ((debug)
+         (print-diagnostic-prefix (G_ "debug: ") #:colors %debug-color))
+        ((process)
+         (print-diagnostic-prefix (G_ "process: ") #:colors %execute-color))
+        ((guix)
+         (print-diagnostic-prefix (G_ "guix: ") #:colors %execute-color))
+        (else #true))
+      (force-output (current-error-port))
+      (format (current-error-port) "~2,2f "
+              (/ (get-internal-real-time)
+                 internal-time-units-per-second))
+      (apply format (current-error-port) message))))
-- 
2.36.1