From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:33053) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1etWtb-0001EO-2X for guix-patches@gnu.org; Wed, 07 Mar 2018 06:06:09 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1etWtZ-0000h2-31 for guix-patches@gnu.org; Wed, 07 Mar 2018 06:06:07 -0500 Received: from debbugs.gnu.org ([208.118.235.43]:40582) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1etWtY-0000gt-VV for guix-patches@gnu.org; Wed, 07 Mar 2018 06:06:05 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1etWtY-0004Va-NF for guix-patches@gnu.org; Wed, 07 Mar 2018 06:06:04 -0500 Subject: [bug#30498] [PATCH 1/3] Turn 'log-output-port' into a parameter. Resent-Message-ID: From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Wed, 7 Mar 2018 12:04:52 +0100 Message-Id: <20180307110454.17110-2-ludo@gnu.org> In-Reply-To: <20180307110454.17110-1-ludo@gnu.org> References: <87371ea2jj.fsf@gnu.org> <20180307110454.17110-1-ludo@gnu.org> List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 30498@debbugs.gnu.org * 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 - ;; . - (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 + ;; . + (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