Subject: [PATCH 1/3] Turn 'log-output-port' into a parameter.

From: Ludovic Courtès <[email-masked]>
Date: Wed, 7 Mar 2018 12:04:52 +0100

* modules/shepherd/comm.scm (log-output-port): Turn into a parameter and
publish it.
(start-logging, stop-logging): Adjust accordingly and mark as deprecated.
(make-shepherd-output-port): Adjust accordingly.
* modules/shepherd/support.scm (default-logfile): Remove.
(user-default-log-file): New procedure.
(default-logfile-date-format): Remove 'if'.
* modules/shepherd.scm (main): Have LOGFILE default to #f.  Parameterize
'log-output-port' and 'current-output-port'.
---
 modules/shepherd.scm         | 209 +++++++++++++++++++++++--------------------
 modules/shepherd/comm.scm    |  19 ++--
 modules/shepherd/support.scm |  19 ++--
 3 files changed, 129 insertions(+), 118 deletions(-)

diff --git a/modules/shepherd.scm b/modules/shepherd.scm
index c869464..39fbe14 100644
--- a/modules/shepherd.scm
+++ b/modules/shepherd.scm
@@ -21,6 +21,7 @@
 
 (define-module (shepherd)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
   #:use-module (ice-9 rdelim)   ;; Line-based I/O.
   #:autoload   (ice-9 readline) (activate-readline) ;for interactive use
   #:use-module (oop goops)      ;; Defining classes and methods.
@@ -77,7 +78,7 @@
 	(socket-file default-socket-file)
         (pid-file    #f)
         (secure      #t)
-        (logfile     default-logfile))
+        (logfile     #f))
     ;; Process command line arguments.
     (process-args (program-name) args
 		  ""
@@ -161,104 +162,116 @@
     ;; We do this early so that we can abort early if necessary.
     (and socket-file
          (verify-dir (dirname socket-file) #:secure? secure))
-    ;; Enable logging as first action.
-    (start-logging logfile)
-
-    (when (string=? logfile "/dev/kmsg")
-      ;; By default we'd write both to /dev/kmsg and to stdout.  Redirect
-      ;; stdout to the bitbucket so we don't log twice.
-      (set-current-output-port (%make-void-port "w")))
-
-    ;; Send output to log and clients.
-    (set-current-output-port (make-shepherd-output-port))
-
-    ;; Start the 'root' service.
-    (start root-service)
-
-    ;; This _must_ succeed.  (We could also put the `catch' around
-    ;; `main', but it is often useful to get the backtrace, and
-    ;; `caught-error' does not do this yet.)
-    (catch #t
-      (lambda ()
-        (load-in-user-module (or config-file (default-config-file))))
-      (lambda (key . args)
-	(caught-error key args)
-	(quit 1)))
-    ;; Start what was started last time.
-    (and persistency
-	 (catch 'system-error
-	   (lambda ()
-	     (start-in-order (read (open-input-file
-				    persistency-state-file))))
-	   (lambda (key . args)
-	     (apply format #f (gettext (cadr args)) (caddr args))
-	     (quit 1))))
-
-    (when (provided? 'threads)
-      ;; XXX: This terrible hack allows us to make sure that signal handlers
-      ;; get a chance to run in a timely fashion.  Without it, after an EINTR,
-      ;; we could restart the accept(2) call below before the corresponding
-      ;; async has been queued.  See the thread at
-      ;; <https://lists.gnu.org/archive/html/guile-devel/2013-07/msg00004.html>.
-      (sigaction SIGALRM (lambda _ (alarm 1)))
-      (alarm 1))
-
-    ;; Stop everything when we get SIGINT.  When running as PID 1, that means
-    ;; rebooting; this is what happens when pressing ctrl-alt-del, see
-    ;; ctrlaltdel(8).
-    (sigaction SIGINT
-      (lambda _
-        (stop root-service)))
 
-    ;; Stop everything when we get SIGTERM.
-    (sigaction SIGTERM
-      (lambda _
-        (stop root-service)))
-
-    ;; Stop everything when we get SIGHUP.
-    (sigaction SIGHUP
-      (lambda _
-        (stop root-service)))
-
-    ;; Ignore SIGPIPE so that we don't die if a client closes the connection
-    ;; prematurely.
-    (sigaction SIGPIPE SIG_IGN)
-
-    (if (not socket-file)
-	;; Get commands from the standard input port.
-        (process-textual-commands (current-input-port))
-        ;; Process the data arriving at a socket.
-        (let ((sock   (open-server-socket socket-file))
-
-              ;; With Guile <= 2.0.9, we can get a system-error exception for
-              ;; EINTR, which happens anytime we receive a signal, such as
-              ;; SIGCHLD.  Thus, wrap the 'accept' call.
-              (accept (EINTR-safe accept)))
-
-          ;; Possibly write out our PID, which means we're ready to accept
-          ;; connections.  XXX: What if we daemonized already?
-          (match pid-file
-            ((? string? file)
-             (with-atomic-file-output pid-file
-               (cute display (getpid) <>)))
-            (#t (display (getpid)))
-            (_  #t))
-
-          (let next-command ()
-            (define (read-from sock)
-              (match (accept sock)
-                ((command-source . client-address)
-                 (setvbuf command-source _IOFBF 1024)
-                 (process-connection command-source))
-                (_ #f)))
-            (match (select (list sock) (list) (list) (if poll-services? 0.5 #f))
-              (((sock) _ _)
-               (read-from sock))
-              (_
-               #f))
-            (when poll-services?
-              (check-for-dead-services))
-            (next-command))))))
+    ;; Enable logging as first action.
+    (parameterize ((log-output-port
+                    (cond (logfile
+                           (open-file logfile "al"))
+                          ((zero? (getuid))
+                           (open-file "/dev/kmsg" "wl"))
+                          (else
+                           (open-file (user-default-log-file) "al"))))
+                   (%current-logfile-date-format
+                    (if (and (not logfile) (zero? (getuid)))
+                        (format #f "shepherd[~d]: " (getpid))
+                        default-logfile-date-format))
+                   (current-output-port
+                    ;; Send output to log and clients.
+                    (make-shepherd-output-port
+                     (if (and (zero? (getuid)) (not logfile))
+                         ;; By default we'd write both to /dev/kmsg and to
+                         ;; stdout.  Redirect stdout to the bitbucket so we
+                         ;; don't log twice.
+                         (%make-void-port "w")
+                         (current-output-port)))))
+
+      ;; Start the 'root' service.
+      (start root-service)
+
+      ;; This _must_ succeed.  (We could also put the `catch' around
+      ;; `main', but it is often useful to get the backtrace, and
+      ;; `caught-error' does not do this yet.)
+      (catch #t
+        (lambda ()
+          (load-in-user-module (or config-file (default-config-file))))
+        (lambda (key . args)
+          (caught-error key args)
+          (quit 1)))
+      ;; Start what was started last time.
+      (and persistency
+           (catch 'system-error
+             (lambda ()
+               (start-in-order (read (open-input-file
+                                      persistency-state-file))))
+             (lambda (key . args)
+               (apply format #f (gettext (cadr args)) (caddr args))
+               (quit 1))))
+
+      (when (provided? 'threads)
+        ;; XXX: This terrible hack allows us to make sure that signal handlers
+        ;; get a chance to run in a timely fashion.  Without it, after an EINTR,
+        ;; we could restart the accept(2) call below before the corresponding
+        ;; async has been queued.  See the thread at
+        ;; <https://lists.gnu.org/archive/html/guile-devel/2013-07/msg00004.html>.
+        (sigaction SIGALRM (lambda _ (alarm 1)))
+        (alarm 1))
+
+      ;; Stop everything when we get SIGINT.  When running as PID 1, that means
+      ;; rebooting; this is what happens when pressing ctrl-alt-del, see
+      ;; ctrlaltdel(8).
+      (sigaction SIGINT
+        (lambda _
+          (stop root-service)))
+
+      ;; Stop everything when we get SIGTERM.
+      (sigaction SIGTERM
+        (lambda _
+          (stop root-service)))
+
+      ;; Stop everything when we get SIGHUP.
+      (sigaction SIGHUP
+        (lambda _
+          (stop root-service)))
+
+      ;; Ignore SIGPIPE so that we don't die if a client closes the connection
+      ;; prematurely.
+      (sigaction SIGPIPE SIG_IGN)
+
+      (if (not socket-file)
+          ;; Get commands from the standard input port.
+          (process-textual-commands (current-input-port))
+          ;; Process the data arriving at a socket.
+          (let ((sock   (open-server-socket socket-file))
+
+                ;; With Guile <= 2.0.9, we can get a system-error exception for
+                ;; EINTR, which happens anytime we receive a signal, such as
+                ;; SIGCHLD.  Thus, wrap the 'accept' call.
+                (accept (EINTR-safe accept)))
+
+            ;; Possibly write out our PID, which means we're ready to accept
+            ;; connections.  XXX: What if we daemonized already?
+            (match pid-file
+              ((? string? file)
+               (with-atomic-file-output pid-file
+                 (cute display (getpid) <>)))
+              (#t (display (getpid)))
+              (_  #t))
+
+            (let next-command ()
+              (define (read-from sock)
+                (match (accept sock)
+                  ((command-source . client-address)
+                   (setvbuf command-source _IOFBF 1024)
+                   (process-connection command-source))
+                  (_ #f)))
+              (match (select (list sock) (list) (list) (if poll-services? 0.5 #f))
+                (((sock) _ _)
+                 (read-from sock))
+                (_
+                 #f))
+              (when poll-services?
+                (check-for-dead-services))
+              (next-command)))))))
 
 (define (process-connection sock)
   "Process client connection SOCK, reading and processing commands."
diff --git a/modules/shepherd/comm.scm b/modules/shepherd/comm.scm
index aeb138e..596a258 100644
--- a/modules/shepherd/comm.scm
+++ b/modules/shepherd/comm.scm
@@ -49,6 +49,7 @@
             result->sexp
             report-command-error
 
+            log-output-port
             start-logging
             stop-logging
             make-shepherd-output-port
@@ -194,16 +195,18 @@ on service '~a':")
 
 
 
-;; Port for logging.  This must always be a valid port, never `#f'.
-(define log-output-port (%make-void-port "w"))
-(define (start-logging file)
+(define log-output-port
+  ;; Port for logging.  This must always be a valid port, never `#f'.
+  (make-parameter (%make-void-port "w")))
+
+(define (start-logging file)                      ;deprecated
   (let ((directory (dirname file)))
     (unless (file-exists? directory)
       (mkdir directory)))
-  (set! log-output-port (open-file file "al")))   ; line-buffered port
-(define (stop-logging)
-  (close-port log-output-port)
-  (set! log-output-port (%make-void-port "w")))
+  (log-output-port (open-file file "al")))
+(define (stop-logging)                            ;deprecated
+  (close-port (log-output-port))
+  (log-output-port (%make-void-port "w")))
 
 (define %current-client-socket
   ;; Socket of the client currently talking to the daemon.
@@ -240,7 +243,7 @@ on service '~a':")
         (if (not (string-index str #\newline))
             (set! buffer (cons str buffer))
             (let* ((log (lambda (x)
-                          (display x log-output-port)))
+                          (display x (log-output-port))))
                    (init-line (lambda ()
                                 (log (strftime (%current-logfile-date-format)
                                                (localtime (current-time)))))))
diff --git a/modules/shepherd/support.scm b/modules/shepherd/support.scm
index 45a2030..380866e 100644
--- a/modules/shepherd/support.scm
+++ b/modules/shepherd/support.scm
@@ -23,7 +23,6 @@
 (define-module (shepherd support)
   #:use-module (shepherd config)
   #:use-module (ice-9 match)
-  #:use-module (ice-9 format)
   #:export (call/ec
             caught-error
             assert
@@ -47,7 +46,7 @@
             display-line
 
             user-homedir
-            default-logfile
+            user-default-log-file
             default-logfile-date-format
             default-config-file
             default-socket-dir
@@ -308,19 +307,15 @@ TARGET should be a string representing a filepath + name."
 ""(for-each start '())
 ")))))
 
-;; Logfile.
-(define default-logfile
-  (if (zero? (getuid))
-      (if (access? "/dev/kmsg" W_OK)
-          "/dev/kmsg"
-          (string-append %localstatedir "/log/shepherd.log"))
-      (string-append %user-config-dir "/shepherd.log")))
+;; Logging.
+(define (user-default-log-file)
+  "Return the file name of the user's default log file."
+  (mkdir-p %user-config-dir #o700)
+  (string-append %user-config-dir "/shepherd.log"))
 
 (define default-logfile-date-format
   ;; 'strftime' format string to prefix each entry in the log.
-  (if (string=? default-logfile "/dev/kmsg")
-      (format #f "shepherd[~d]: " (getpid))
-      "%Y-%m-%d %H:%M:%S "))
+  "%Y-%m-%d %H:%M:%S ")
 
 ;; Configuration file.
 (define (default-config-file)
-- 
2.16.2