;; herd.scm -- The program to herd the Shepherd.
;; Copyright (C) 2013-2014, 2016, 2018-2019, 2021-2025 Ludovic Courtès <ludo@gnu.org>
;; Copyright (C) 2002, 2003 Wolfgang Jährling <wolfgang@pro-linux.de>
;;
;; This file is part of the GNU Shepherd.
;;
;; The GNU Shepherd is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3 of the License, or (at
;; your option) any later version.
;;
;; The GNU Shepherd is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with the GNU Shepherd.  If not, see <http://www.gnu.org/licenses/>.

(define-module (shepherd scripts herd)
  #:use-module (shepherd config)
  #:use-module (shepherd support)
  #:use-module (shepherd args)
  #:use-module (shepherd comm)
  #:use-module (shepherd colors)
  #:autoload   (shepherd service timer) (sexp->command
                                         command?
                                         command-arguments
                                         command-user
                                         next-calendar-event
                                         sexp->calendar-event)
  #:use-module (ice-9 format)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 match)
  #:autoload   (ice-9 vlist) (vlist-null vhash-consq vhash-assq)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-71)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:export (main))


;; Information about live services.
(define-record-type <live-service>
  (live-service provision requirement one-shot? transient? respawn? actions
                enabled? status running
                status-changes last-respawns startup-failures
                exit-statuses
                recent-messages log-files
                pending-replacement?)
  live-service?
  (provision        live-service-provision)       ;list of symbols
  (requirement      live-service-requirement)     ;list of symbols
  (one-shot?        live-service-one-shot?)       ;Boolean
  (transient?       live-service-transient?)      ;Boolean
  (respawn?         live-service-respawn?)        ;Boolean
  (actions          live-service-actions)         ;list of symbols

  (enabled?         live-service-enabled?)         ;Boolean
  (status           live-service-status)           ;symbol
  (running          live-service-running-value)    ;#f | object
  (status-changes   live-service-status-changes)   ;symbol/integer pairs
  (last-respawns    live-service-last-respawns)    ;list of integers
  (startup-failures live-service-startup-failures) ;list of integers
  (exit-statuses    live-service-process-exit-statuses) ;integers/timestamps
  (recent-messages  live-service-recent-messages)  ;list of strings
  (log-files        live-service-log-files)        ;list of strings
  (pending-replacement? live-service-pending-replacement?))     ;Boolean

(define (live-service-canonical-name service)
  "Return the 'canonical name' of @var{service}."
  (first (live-service-provision service)))

(define (live-service-timer? service)
  "Return true if @var{service}'s value is a timer."
  (match (live-service-running-value service)
    (('timer . _) #t)
    (_ #f)))

(define (live-service-failing? service)
  "Return true if @var{service} failed to start."
  (and (eq? 'stopped (live-service-status service))
       (pair? (live-service-startup-failures service))))

(define (live-service-last-status-change-time service)
  "Return the time @var{service} last changed statuses."
  (match (live-service-status-changes service)
    (((_ . time) . _) time)
    (() #f)))

(define (live-service-status-duration service)
  "Return the duration @var{service} has been in its current status."
  (match (live-service-last-status-change-time service)
    (#f 0)
    (time
     (- (time-second (current-time time-utc)) time))))

(define (live-service-status-predicate status)
  "Return a predicate that returns true when passed a service with the given
@var{status}."
  (lambda (service)
    (eq? status (live-service-status service))))

(define-syntax alist-let*
  (syntax-rules ()
    "Bind the given KEYs in EXP to the corresponding items in ALIST.  ALIST
is assumed to be a list of two-element tuples rather than a traditional list
of pairs."
    ((_ alist (key ...) exp ...)
     (let ((key (and=> (assoc-ref alist 'key) car)) ...)
       exp ...))))

(define (sexp->live-service sexp)
  "Turn @var{sexp}, the wire representation of a service returned by shepherd,
into a @code{live-service} record."
  (match sexp
    (('service ('version 0 _ ...) properties ...)
     (alist-let* properties (provides requires status running respawn?
                             actions enabled?
                             status-changes last-respawns startup-failures
                             exit-statuses
                             recent-messages log-files
                             one-shot? transient? pending-replacement?)
       (live-service provides requires one-shot?
                     transient? respawn? (or actions '())

                     enabled?
                     (or status (if running 'running 'stopped))
                     running
                     (or status-changes '())
                     (or last-respawns '())
                     (or startup-failures '())
                     (or exit-statuses '())
                     (or recent-messages '())
                     (or log-files '())
                     pending-replacement?)))))

(define (highlight-if-long-transient-status service)
  "Return a procedure to highlight @var{service} if it's been stuck in a
transient status for too long."
  (if (memq (live-service-status service) '(starting stopping))
      (let ((duration (live-service-status-duration service)))
        (cond ((>= duration 30) highlight/warn)
              ((>= duration 60) highlight/error)
              (else identity)))
      identity))

(define (display-status-summary services)
  "Display a summary of the status of all of SERVICES."
  (define (service<? service1 service2)
    (string<? (symbol->string (live-service-canonical-name service1))
              (symbol->string (live-service-canonical-name service2))))

  (define (display-services header bullet services)
    (unless (null? services)
      (display header)
      (for-each (lambda (service)
                  (define maybe-highlight
                    (cond ((live-service-pending-replacement? service)
                           highlight)
                          ((live-service-transient? service)
                           dim)
                          (else
                           (highlight-if-long-transient-status service))))

                  (format #t " ~a ~a~%" bullet
                          (maybe-highlight
                           (symbol->string
                            (live-service-canonical-name service)))))
                (sort services service<?))))      ;get deterministic output

  (let* ((started  (filter (live-service-status-predicate 'running) services))
         (stopped  (filter (live-service-status-predicate 'stopped) services))
         (starting (filter (live-service-status-predicate 'starting) services))
         (stopping (filter (live-service-status-predicate 'stopping) services))
         (timers started   (partition live-service-timer? started))
         (one-shot stopped (partition live-service-one-shot? stopped))
         (failing stopped  (partition live-service-failing? stopped)))
    (display-services (highlight (l10n "Started:\n")) "+"
                      started)
    (display-services (highlight (l10n "Running timers:\n")) "+"
                      timers)
    (display-services (highlight (l10n "Starting:\n")) "^"
                      starting)

    (display-services (highlight (l10n "Stopped:\n")) "-"
                      stopped)
    (display-services (highlight (l10n "Stopping:\n")) "v"
                      stopping)

    ;; TRANSLATORS: Here "one-shot" refers to "one-shot services".  These are
    ;; services that are immediately marked as stopped once their 'start'
    ;; method has completed.
    (display-services (highlight (l10n "One-shot:\n")) "*"
                      one-shot)

    (display-services (highlight/error (l10n "Failed to start:\n")) "!"
                      failing)))

(define (display-detailed-status services)
  "Display the detailed status of SERVICES."
  (for-each (lambda (service)
              (display-service-status service
                                      #:show-recent-messages? #f))
            services))

(define* (time->string time #:optional (now* (current-time time-utc)))
  "Return a string representing TIME in a concise, human-readable way."
  (define now
    (time-second now*))

  (define elapsed
    (- now time))

  (define relative
    (cond ((< elapsed (* -48 3600))
           (let ((days (inexact->exact
                        (round (/ elapsed (* -3600 24))))))
             (format #f (l10n "in ~a day" "in ~a days" days)
                     days)))
          ((< elapsed -7200)
           (let ((hours (inexact->exact
                         (round (/ elapsed -3600)))))
             (format #f (l10n "in ~a hour" "in ~a hours" hours)
                     hours)))
          ((< elapsed -120)
           (let ((minutes (inexact->exact
                           (round (/ elapsed -60)))))
             (format #f (l10n "in ~a minute" "in ~a minutes" minutes)
                     minutes)))
          ((< elapsed 0)
           (format #f (l10n "in ~a second" "in ~a seconds" (abs elapsed))
                   (abs elapsed)))
          ((< elapsed 120)
           (format #f (l10n "~a second ago" "~a seconds ago" elapsed)
                   elapsed))
          ((< elapsed 7200)
           (let ((minutes (inexact->exact
                           (round (/ elapsed 60)))))
             (format #f (l10n "~a minute ago" "~a minutes ago" minutes)
                     minutes)))
          ((< elapsed (* 48 3600))
           (let ((hours (inexact->exact
                         (round (/ elapsed 3600)))))
             (format #f (l10n "~a hour ago" "~a hours ago" hours)
                     hours)))
          (else
           (let ((days (inexact->exact
                        (round (/ elapsed (* 3600 24))))))
             (format #f (l10n "~a day ago" "~a days ago" days)
                     days)))))

  (define absolute
    (let* ((time*   (make-time time-utc 0 time))
           (date    (time-utc->date time*))
           (year    (date-year date))
           (now*    (time-utc->date now*))
           ;; Note: Use 'strftime' rather than 'date->string' to better
           ;; account for locale preferences.
           (format  (if (= year (date-year now*))
                        (if (= (date-day date) (date-day now*))
                            "%X"
                            "%c")
                        "%c")))
      (strftime format (localtime time))))

  ;; TRANSLATORS: The first placeholder is for a date string such as "April 22
  ;; 19:07:46" and the parenthesized placeholder is for the corresponding
  ;; relative date string like "2 hours ago".
  (format #f (l10n "~a (~a)") absolute relative))

(define (seconds->string seconds)
  "Return a string representing @var{seconds} as a duration in a
human-friendly way."
  (cond ((< seconds 180)
         ;; TRANSLATORS: This string and the following ones denote a duration.
         ;; It ends up being inserted in a sentence like "Process terminated
         ;; after 10 seconds".  (Arguably not ideal.)
         (format #f (l10n "~h second" "~h seconds" seconds)
                 seconds))
        ((< seconds (* 180 60))
         (let ((minutes (quotient seconds 60)))
           (format #f (l10n "~h minute" "~h minutes" minutes)
                   minutes)))
        (else
         (let ((hours (quotient seconds 3600)))
           (format #f (l10n "~h hour" "~h hours" hours)
                   hours)))))

(define %default-log-history-size
  ;; Number of log lines displayed by default.  This default value should be
  ;; chosen such that the output of 'herd status SERVICE' isn't overwhelming
  ;; and that messages don't become more prominent than other pieces of status
  ;; info.
  5)

(define %default-timer-history-size
  ;; Number of timer exit statuses showed by default.
  5)

(define (shell-quoted-command command)
  "Return a string corresponding to @var{command}, a list of strings, with the
relevant bits quoted according to POSIX shell rules."
  (define to-quote
    (char-set-union (char-set #\\ #\" #\' #\( #\) #\? #\!)
                    char-set:whitespace))

  (define (needs-quotation? str)
    (string-any to-quote str))

  (string-join
   (map (lambda (str)
          (if (needs-quotation? str)
              (object->string str)
              str))
        command)))

(define* (display-process-exit-status status #:optional duration)
  "Display @var{status}, a process status as returned by @code{waitpid}, in a
human-friendly way.  When @var{duration} is provided, it is the number of
seconds during which the process ran."
  (cond ((zero? status)
         (if duration
             (format #t (l10n "Process exited successfully after ~a.~%")
                     (seconds->string duration))
             (format #t (l10n "Process exited successfully.~%"))))
        ((status:exit-val status)
         =>
         (lambda (code)
           (if duration
               (format #t
                       (highlight/error
                        (l10n "Process exited with code ~a after ~a.~%"))
                       code (seconds->string duration))
               (format #t (highlight/error
                           (l10n "Process exited with code ~a.~%"))
                       code))))
        ((status:term-sig status)
         =>
         (lambda (signal)
           (if duration
               (format #t
                       (highlight/error
                        (l10n "Process terminated with signal ~a after ~a.~%"))
                       signal (seconds->string duration))
               (format #t (highlight/error
                           (l10n "Process terminated with signal ~a.~%"))
                       signal))))
        ((status:stop-sig status)
         =>
         (lambda (signal)
           (if duration
               (format #t
                       (highlight/error
                        (l10n "Process stopped with signal ~a after ~a.~%"))
                       signal (seconds->string duration))
               (format #t (highlight/error
                           (l10n "Process stopped with signal ~a.~%"))
                       signal))))))

(define* (display-timer-events event #:optional (count 5))
  "Display the @var{count} upcoming timer alarms that match @var{event}, a
calendar event."
  (let loop ((n 0)
             (date (current-date)))
    (when (< n count)
      (let ((next (next-calendar-event event date))
            (now  (current-time time-utc)))
        (format #t "  ~a~%"
                (time->string (time-second (date->time-utc next))
                              now))
        (loop (+ n 1) next)))))

(define* (display-service-status service
                                 #:key
                                 (show-recent-messages? #t)
                                 (log-history-size %default-log-history-size)
                                 (timer-history-size
                                  %default-timer-history-size))
  "Display the status of @var{service}, an sexp.  When
@var{show-recent-messages?} is true, display messages recently logged by
@var{service}."
  (when (string=? (port-encoding (current-output-port)) "UTF-8")
    ;; Show a colored bullet that gives an idea of the overall status.
    (display ((if (eq? (live-service-status service) 'running)
                  highlight/success
                  (if (live-service-enabled? service)
                      highlight/warn
                      highlight/error))
              "● ")))

  (format #t (highlight (l10n "Status of ~a:~%"))
          (live-service-canonical-name service))

  (match (live-service-status service)
    ('running
     (match (live-service-status-changes service)
       ((('running . time) . _)
        (cond ((live-service-timer? service)
               (format #t (l10n "  Timed service.~%"))
               (match (live-service-running-value service)
                 (('timer ('version 0) properties ...)
                  (alist-let* properties (processes)
                    (if (null? processes)
                        (format #t (l10n "  Awaiting next timer alarm; \
service active since ~a.~%")
                                (time->string time))
                        (match processes
                          (((pids . start-times) ...)
                           (let ((start-time (reduce min 0 start-times)))
                             (format #t (highlight (l10n "  Executing \
timer action since ~a.~%"))
                                     (time->string start-time))))))))))
              ((live-service-transient? service)
               (format #t (l10n "  It is transient, running since ~a.~%")
                       (time->string time)))
              (else
               (format #t (l10n "  It is running since ~a.~%")
                       (time->string time)))))
       (_
        ;; Shepherd 0.9.x did not provide status change times.
        (if (live-service-transient? service)
            (format #t (l10n "  It is started and transient.~%"))
            (format #t (l10n "  It is started.~%")))))

     (match (live-service-running-value service)
       (('process ('version 0 _ ...)
                  ('id pid) ('command command) _ ...)
        ;; TRANSLATORS: "PID" is short for "process identifier" (Unix jargon).
        ;; The string here looks like "Main PID: 123".
        (format #t (l10n "  Main PID: ~a~%")
                (highlight (number->string pid)))
        (format #t (l10n "  Command: ~a~%")
                (shell-quoted-command command)))
       (('inetd-service ('version 0)
                        ('endpoints (('endpoint ('version 0)
                                                ('name names)
                                                ('address addresses)
                                                _ ...) ...))
                        rest ...)
        ;; TRANSLATORS: "Inetd" refers to a type of service and should be kept
        ;; as-is.
        (format #t (l10n "  Inetd-style service listening on ~a endpoint:~%"
                         "  Inetd-style service listening on ~a endpoints:~%"
                         (length names))
                (length names))
        (for-each (lambda (address)
                    (format #t "    - ~a~%"
                            (socket-address->string address)))
                  addresses)
        ;; The 'command' key appeared in version 1.0.4.
        (match (assoc 'command rest)
          (#f #t)
          (('command command)
           (format #t (l10n "  Command: ~a~%")
                   (shell-quoted-command command)))))
       (('systemd-service ('version 0)
                          ('endpoints (('endpoint ('version 0)
                                                  ('name names)
                                                  ('address addresses)
                                                  _ ...) ...))
                          rest ...)
        ;; TRANSLATORS: "Systemd" should be kept untranslated.
        (format #t (l10n "  Systemd-style service listening on ~a endpoint:~%"
                         "  Systemd-style service listening on ~a endpoints:~%"
                         (length names))
                (length names))
        (for-each (lambda (name address)
                    (format #t "    - ~a (~s)~%"
                            (socket-address->string address) name))
                  names addresses)
        ;; The 'command' key appeared in version 1.0.4.
        (match (assoc 'command rest)
          (#f #t)
          (('command command)
           (format #t (l10n "  Command: ~a~%")
                   (shell-quoted-command command)))))
       (('system-log ('version 0)
                     ('endpoints (('endpoint ('version 0)
                                             ('name names)
                                             ('address addresses)
                                             _ ...) ...))
                     ('kernel-log-file kernel-log-file)
                     rest ...)
        (format #t (l10n "  System log listening on ~a endpoint:~%"
                         "  System log listening on ~a endpoints:~%"
                         (length names))
                (length names))
        (for-each (lambda (name address)
                    (format #t "    - ~a (~s)~%"
                            (socket-address->string address) name))
                  names addresses)
        (format #t "  Kernel log file: ~a~%"
                (or kernel-log-file "-")))
       (('timer ('version 0)
                ('event event) ('action action)
                ('processes processes) _ ...)
        (match (or (sexp->command action) action)
          ((? command? command)
           (if (command-user command)
               (format #t (l10n "  Periodically running as ~s: ~a~%")
                       (command-user command)
                       (shell-quoted-command (command-arguments command)))
               (format #t (l10n "  Periodically running: ~a~%")
                       (shell-quoted-command (command-arguments command))))
           (when (pair? processes)
             (format #t (highlight (l10n "  Child process:~{ ~a~}~%"
                                         "  Child processes:~{ ~a~}~%"
                                         (length processes)))
                     (match processes
                       (((pids . start-times) ...)
                        pids)))))
          ('procedure
           (format #t (l10n "  Periodically running Scheme code.~%")))
          (_ #f)))
       (_
        ;; TRANSLATORS: The "~s" bit is most of the time a placeholder for a
        ;; Scheme value associated with the service.
        (format #t (l10n "  Running value is ~s.~%")
                (live-service-running-value service)))))
    ('stopped
     (if (live-service-one-shot? service)
         (format #t (l10n "  It is stopped (one-shot).~%"))
         (if (pair? (live-service-startup-failures service))
             (format #t (highlight/error
                         (l10n "  It is stopped (failing).~%")))
             (match (live-service-status-changes service)
               ((('stopped . time) . _)
                (format #t (highlight/warn
                            (l10n "  It is stopped since ~a.~%"))
                        (time->string time)))
               (_
                (format #t (highlight/warn
                            (l10n "  It is stopped.~%")))))))
     (match (live-service-process-exit-statuses service)
       (((status . time) . _)
        (display "  ")                            ;indent
        (display-process-exit-status status))
       (()
        #f)))
    ('starting
     (let ((highlight (highlight-if-long-transient-status service)))
       (format #t (highlight (l10n "  It is starting.~%")))))
    ('stopping
     (let ((highlight (highlight-if-long-transient-status service)))
       (format #t (highlight (l10n "  It is being stopped.~%")))))
    (x
     (format #t (l10n "  Unknown status '~a'.~%") x)))

  (if (live-service-enabled? service)
      (format #t (l10n "  It is enabled.~%"))
      (let ((highlight (if (null? (live-service-last-respawns service))
                           highlight/warn
                           highlight/error)))
        (format #t (highlight (l10n "  It is disabled.~%")))))
  (format #t (l10n "  Provides:~{ ~a~}~%") (live-service-provision service))
  (unless (null? (live-service-requirement service))
    (format #t (l10n "  Requires:~{ ~a~}~%")
            (live-service-requirement service)))
  (unless (null? (live-service-actions service))
    (format #t (l10n "  Custom action:~{ ~a~}~%"
                     "  Custom actions:~{ ~a~}~%"
                     (length (live-service-actions service)))
            (live-service-actions service)))

  (when (live-service-pending-replacement? service)
    (format #t (highlight/warn (l10n "  Replacement pending (restart \
to upgrade).~%"))))

  (if (live-service-respawn? service)
      (format #t (l10n "  Will be respawned.~%"))
      (format #t (l10n "  Will not be respawned.~%")))
  (match (live-service-last-respawns service)
    ((time _ ...)
     (format #t (highlight/warn (l10n "  Last respawned on ~a.~%"))
             (time->string time))
     (match (reverse (at-most log-history-size
                              (live-service-process-exit-statuses service)))
       (((statuses . times) ...)
        ;; Since SERVICE was respawned, show a log of exit times and statuses.
        (format #t (l10n "  Latest exit:~%"
                         "  Latest exits:~%" (length statuses)))
        (for-each (lambda (status time)
                    (format #t "    - ~a "
                            (strftime default-logfile-date-format
                                      (localtime time)))
                    (display-process-exit-status status))
                  statuses times))
       (()
        #f)))
    (_ #t))
  (when (eq? (live-service-status service) 'stopped)
    (match (live-service-startup-failures service)
      ((time _ ...)
       (format #t (highlight/error (l10n "  Failed to start at ~a.~%"))
               (time->string time)))
      (_ #t)))
  (match (live-service-log-files service)
    (() #t)
    (files
     (format #t (l10n "  Log file:~{ ~a~}~%"
                      "  Log files:~{ ~a~}~%"
                      (length files))
             (live-service-log-files service))))

  (when show-recent-messages?
    (match (live-service-running-value service)
      (('timer ('version 0) properties ...)
       (alist-let* properties (past-runs)
         (match past-runs
           ((or () #f)
            #t)
           (statuses
            (newline)
            (format #t (highlight (l10n "Recent runs:~%")))
            (for-each (match-lambda
                        ((status end start)
                         (format #t "  ~a"
                                 (strftime default-logfile-date-format
                                           (localtime end)))
                         (match status
                           ((? integer?)
                            (display-process-exit-status status
                                                         (- end start)))
                           ('success
                            (format #t (l10n "Completed in ~a.~%")
                                    (seconds->string (- end start))))
                           (('exception key args ...)
                            (format #t (highlight/error
                                        (l10n "Exception thrown after ~a: ~a~%"))
                                    (seconds->string (- end start))
                                    (string-trim-right
                                     (call-with-output-string
                                       (lambda (port)
                                         (print-exception port #f
                                                          key args))))))
                           (_ #f))))
                      (reverse (at-most timer-history-size statuses)))))))
      (_ #f))

    (match (live-service-recent-messages service)
      (() #t)
      (messages
       (newline)
       (if (= log-history-size %default-log-history-size)
           (format #t (highlight
                       (l10n "Recent messages (use '-n' to view more or \
less):~%")))
           (format #t (highlight (l10n "Recent messages:~%"))))
       (for-each (match-lambda
                   ((time . line)
                    (format #t "  ~a~a~%"
                            (strftime default-logfile-date-format
                                      (localtime time))
                            line)))
                 (reverse (at-most log-history-size messages)))))

    (match (live-service-running-value service)
      (('timer ('version 0) properties ...)
       (alist-let* properties (event remaining-occurrences)
         (let ((event (and=> event sexp->calendar-event)))
           (when event
             (newline)
             (if (zero? remaining-occurrences)
                 (format #t
                         (highlight/warn
                          (l10n "No upcoming timer alarm: about to stop.~%")))
                 (let ((count (min 5 (if (exact? remaining-occurrences)
                                         remaining-occurrences
                                         100))))
                   (format #t (highlight (l10n "Upcoming timer alarm:~%"
                                               "Upcoming timer alarms:~%"
                                               count)))
                   (display-timer-events event count)))))))
      (_ #t))))

(define (display-event-log services)
  "Display status changes of @var{services} as a chronologically-sorted log."
  (define events
    (map (lambda (service)
           (fold-right
            (lambda (pair result)
              (match pair
                (('stopped . time)
                 (cons (if (live-service-one-shot? service)
                           (list time service 'stopped)
                           (match result
                             (((_ _ 'starting) . _)
                              ;; Transition from "starting" to "stopped"
                              ;; indicates a startup failure.
                              (list time service 'startup-failure))
                             (_
                              (list time service 'stopped))))
                       result))
                ((status . time)
                 (cons (list time service status)
                       result))))
            '()
            (live-service-status-changes service)))
         services))

  (define event>?
    (match-lambda*
      (((time1 . _) (time2 . _))
       (> time1 time2))))

  (define sorted
    ;; Each event list is already sorted, so merge them.  (They cannot be
    ;; resorted based on timestamps because there may be several events with
    ;; the same timestamps so resorting would lose causal ordering.)
    (reduce (lambda (events1 events2)
              (merge events1 events2 event>?))
            '()
            events))

  (when (null? sorted)
    ;; The Shepherd 0.9.x and earlier did not log service status changes.
    (report-error (l10n "event log is missing (shepherd is too old?)"))
    (exit 1))

  (for-each (match-lambda
              ((time service status)
               (let ((name (live-service-canonical-name service)))
                 (format #t "~a\t"
                         (date->string
                          (time-utc->date
                           (make-time time-utc 0 time))
                          "~e ~b ~Y ~H:~M:~S"))
                 (match status
                   ('running
                    (format #t (highlight (l10n "service ~a is running~%"))
                            name))
                   ('stopped
                    (cond ((live-service-one-shot? service)
                           (format #t (l10n "service ~a is done (one-shot)~%")
                                   name))
                          ((live-service-transient? service)
                           (format #t
                                   (highlight/warn
                                    (l10n "service ~a is done (transient)~%"))
                                   name))
                          (else
                           (format #t (highlight/warn
                                       (l10n "service ~a is stopped~%"))
                                   name))))
                   ('startup-failure
                    (format #t (highlight/error
                                (l10n "service ~a failed to start~%"))
                            name))
                   ('starting
                    (format #t (l10n "service ~a is being started~%")
                            name))
                   ('stopping
                    (format #t (l10n "service ~a is being stopped~%")
                            name))
                   (_
                    (format #t (l10n "service ~a is entering state '~a'~%")
                            name status))))))
            (reverse sorted)))

(define (display-service-graph services)
  "Write to the current output port a Graphviz representation of
@var{services}."
  (define registry
    (fold (lambda (service registry)
            (fold (cut vhash-consq <> service <>)
                  registry
                  (live-service-provision service)))
          vlist-null
          services))

  (define (lookup-service name)
    (match (vhash-assq name registry)
      (#f
       (report-error (l10n "inconsistent graph: service '~a' not found~%")
                     name)
       (exit 1))
      ((_ . service) service)))

  (define (emit-graphviz services)
    (define (shape service)
      (cond ((live-service-one-shot? service)
             "circle")
            ((live-service-timer? service)
             "diamond")
            (else "box")))
    (define (style service)
      (if (live-service-transient? service)
          "dashed"
          "solid"))
    (define (text-color service)
      (cond ((live-service-failing? service)
             "red")
            ((eq? (live-service-status service) 'stopped)
             "purple")
            ((eq? (live-service-status service) 'running)
             "black")
            (else
             "gray")))
    (define (color service)
      (cond ((live-service-failing? service)
             "red")
            ((eq? (live-service-status service) 'stopped)
             "purple")
            ((eq? (live-service-status service) 'running)
             "green")
            (else
             "gray")))

    (format #t "digraph ~s {~%" (l10n "Service Graph"))
    (for-each (lambda (service)
                (format #t "  \"~a\" [shape = ~a, color = ~a, \
fontcolor = ~a, style = ~a];~%"
                        (live-service-canonical-name service)
                        (shape service) (color service)
                        (text-color service) (style service))
                (for-each (lambda (dependency)
                            (format #t "  \"~a\" -> \"~a\";~%"
                                    (live-service-canonical-name service)
                                    (live-service-canonical-name
                                     (lookup-service dependency))))
                          (if (memq 'root (live-service-provision service))
                              (live-service-requirement service)
                              (cons 'root (live-service-requirement service)))))
              services)
    (format #t "}~%"))

  (emit-graphviz services))

(define root-service?
  ;; XXX: This procedure is written in a surprising way to work around a
  ;; compilation bug in Guile 3.0.5 to 3.0.7: <https://bugs.gnu.org/47172>.
  (let ((names (list 'root 'shepherd)))
    (lambda (service)
      (memq service names))))

(define* (run-command socket-file action service args
                      #:key
                      (log-history-size %default-log-history-size)
                      (timer-history-size %default-timer-history-size))
  "Perform @var{action} with @var{args} on @var{service}, and display the
result.  If @var{service} is @code{#f}, perform @var{action} on the root
service but display a generic overview rather than information about
@code{root} itself.  Connect to the daemon via @var{socket-file}."
  (with-system-error-handling
   (let ((sock    (open-connection socket-file))
         (action* (if (and (memq action '(detailed-status log graph))
                           (or (not service)
                               (root-service? service)))
                      'status
                      action)))
     ;; Send the command.
     (write-command (shepherd-command action* (or service 'root)
                                      #:arguments args)
                    sock)

     ;; Receive output.  Interpret the command's output when possible and
     ;; format it in a human-readable way.
     (match (read sock)
       (('reply ('version 0 _ ...)                ;no errors
                ('result result) ('error #f)
                ('messages messages))
        ;; First, display raw messages coming from the daemon.  Since they are
        ;; not translated in the user's locale, they should be avoided!
        (for-each display-line messages)

        ;; Then interpret the result
        (match (list action service)
          (('status #f)
           (display-status-summary
            (map sexp->live-service (first result))))
          (('detailed-status #f)
           (display-detailed-status
            (map sexp->live-service (first result))))
          (('log (or 'root 'shepherd #f))
           (display-event-log
            (map sexp->live-service (first result))))
          (('graph (or 'root 'shepherd #f))
           (display-service-graph
            (map sexp->live-service (first result))))
          (('help (or 'root 'shepherd #f))
           (match result
             ((help-text)
              (display (gettext help-text))
              (newline))))
          (('eval (or 'root 'shepherd))
           (match result
             ((value)
              (write value)
              (newline))))
          (('status _)
           ;; RESULT is enclosed in a list (a singleton) because it used to be
           ;; that one name could map to several services.
           (let* ((result (first result))
                  (service (match service
                             ((or 'root 'shepherd)
                              ;; The 'status' action of 'root' returns the
                              ;; entire list of services.  Extract 'root'.
                              (any (lambda (sexp)
                                     (let ((service (sexp->live-service sexp)))
                                       (and (memq 'root
                                                  (live-service-provision
                                                   service))
                                            service)))
                                   result))
                             (_
                              (sexp->live-service result)))))
             (display-service-status service
                                     #:show-recent-messages? #t
                                     #:log-history-size
                                     log-history-size
                                     #:timer-history-size
                                     timer-history-size)))
          (('start _)
           (unless result
             (report-error (l10n "failed to start service ~a")
                           service)
             (exit 1)))
          (_
           ;; For other commands, exit successfully if and only if all the
           ;; values of RESULT are true.
           (unless (every ->bool result)
             (exit 1)))))
       (('reply ('version 0 _ ...)                ;an error
                ('result _) ('error error)
                ('messages messages))
        (for-each display-line messages)
        (report-command-error error)

        ;; Did the user swap ACTION and SERVICE?
        (match (list action service)
          ((_ (or 'start 'stop 'status 'doc))
           (report-hint (l10n "Did you mean 'herd ~a ~a'?")
                        service action))
          (('root (or 'help 'halt 'power-off 'load 'eval 'unload 'reload
                      'daemonize 'restart))
           (report-hint (l10n "Did you mean 'herd ~a ~a'?")
                        service action))
          ((_ _)
           (match error
             (('error ('version 0 _ ...) 'action-not-found action service)
              (report-hint (l10n "Run 'herd doc ~a list-actions' to list \
supported actions.")
                           service))
             (_ #f))))

        (exit 1))
       ((? eof-object?)
        ;; When stopping shepherd, we may get an EOF in lieu of a real reply,
        ;; and that's fine.  In other cases, a premature EOF is an error.
        (unless (and (eq? action 'stop)
                     (memq service '(root shepherd)))
          (report-error (l10n "premature end-of-file while \
talking to shepherd"))
          (exit 1))))

     (close-port sock))))


;; Main program.
(define (main . args)
  (define (positive-integer? obj)
    (and (integer? obj) (exact? obj) (>= obj 0)))

  (initialize-cli)

  (parameterize ((program-name "herd"))
    (let ((socket-file (current-socket-file))
          (command-args '())
          (log-history-size %default-log-history-size)

          ;; Options for programs started by 'timer'.
          (service-name #f)
          (log-file #f)
          (directory #f)
          (extra-environment '())
          (user #f)
          (group #f))
      (process-args (program-name) args
                    (l10n "ACTION SERVICE [ARG...]")
                    (l10n "Apply ACTION (start, stop, status, etc.) on \
SERVICE with the ARGs.")
                    (lambda (arg)
                      ;; Collect unknown args.
                      (set! command-args (cons arg command-args)))
                    (option
                      #:long-name "socket" #:short-name #\s
                      #:takes-argument? #t #:argument-is-optional? #f
                      #:argument-name (l10n "FILE")
                      #:description (l10n "send commands to FILE")
                      #:action (lambda (file)
                                 (set! socket-file file)))
                    (option
                     #:long-name "log-history" #:short-name #\n
                     #:takes-argument? #t #:argument-is-optional? #f
                     #:argument-name (l10n "NUMBER")
                     #:description
                     (l10n "display up to NUMBER service log lines")
                     #:action (lambda (str)
                                (match (string->number str)
                                  ((? positive-integer? n)
                                   (set! log-history-size n))
                                  (_
                                   (report-error (l10n "~a: expected \
a positive integer")
                                                 str)
                                   (exit 1)))))

                    ;; Options for actions like 'schedule timer' and 'spawn
                    ;; transient'.
                    (option
                     #:long-name "service-name" #:short-name #\N
                     #:takes-argument? #t #:argument-is-optional? #f
                     #:argument-name (l10n "NAME")
                     #:description
                     (l10n "register new service under NAME")
                     #:action (lambda (str)
                                (set! service-name (string->symbol str))))
                    (option
                     #:long-name "log-file"
                     #:takes-argument? #t #:argument-is-optional? #f
                     #:argument-name (l10n "FILE")
                     #:description
                     (l10n "log service output to FILE")
                     #:action (lambda (str)
                                (set! log-file
                                      (if (string-prefix? "/" str)
                                          str
                                          (in-vicinity (getcwd) str)))))
                    (option
                     #:long-name "working-directory" #:short-name #\d
                     #:takes-argument? #t #:argument-is-optional? #f
                     #:argument-name (l10n "DIRECTORY")
                     #:description
                     (l10n "run service from DIRECTORY (for transient \
services)")
                     #:action (lambda (str)
                                (set! directory str)))
                    (option
                     #:long-name "environment-variable" #:short-name #\E
                     #:takes-argument? #t #:argument-is-optional? #f
                     #:argument-name (l10n "ENVIRONMENT")
                     #:description
                     (l10n "pass the environment variable specified by \
ENVIRONMENT")
                     #:action (lambda (str)
                                (set! extra-environment
                                      (cons str extra-environment))))
                    (option
                     #:long-name "user"
                     #:takes-argument? #t #:argument-is-optional? #f
                     #:argument-name (l10n "USER")
                     #:description
                     (l10n "run the given program as USER")
                     #:action (lambda (str)
                                (set! user str)))
                    (option
                     #:long-name "group"
                     #:takes-argument? #t #:argument-is-optional? #f
                     #:argument-name (l10n "GROUP")
                     #:description
                     (l10n "run the given program as GROUP")
                     #:action (lambda (str)
                                (set! group str))))

      (match (reverse command-args)
        (((and action
               (or "status" "detailed-status" "help" "log" "graph"))) ;one argument
         (run-command socket-file (string->symbol action) #f '()
                      #:log-history-size log-history-size))
        ((action service args ...)
         ;; Prepare keyword arguments that are understood by actions such as
         ;; 'schedule timer' and 'spawn transient'.
         (let ((args `(,@args
                       ,@(if service-name
                             `(#:name ,service-name)
                             '())
                       ,@(if directory
                             `(#:directory ,directory)
                             '())
                       ,@(if (null? extra-environment)
                             '()
                             `(#:extra-environment-variables
                               ,extra-environment))
                       ,@(if log-file
                             `(#:log-file ,log-file)
                             '())
                       ,@(if user `(#:user ,user) '())
                       ,@(if group `(#:group ,group) '()))))
           (run-command socket-file
                        (string->symbol action)
                        (string->symbol service) args
                        #:log-history-size log-history-size
                        #:timer-history-size log-history-size))) ;approximation
        (_
         (format (current-error-port)
                 (l10n "Usage: herd ACTION [SERVICE [OPTIONS...]]~%"))
         (exit 1))))))

;; Local Variables:
;; eval: (put 'alist-let* 'scheme-indent-function 2)
;; End:
