Toggle diff (331 lines)
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
