# GNU Shepherd --- Test status sexps.
# Copyright © 2016, 2023-2025 Ludovic Courtès <ludo@gnu.org>
#
# 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/>.

shepherd --version
herd --version

socket="t-socket-$$"
conf="t-conf-$$"
log="t-log-$$"
pid="t-pid-$$"
client="t-sexp-client-$$"

herd="herd -s $socket"

trap "cat $log || true; rm -f $socket $conf $stamp $log $client;
      test -f $pid && kill \`cat $pid\` || true; rm -f $pid" EXIT

cat > "$conf"<<EOF
(default-respawn-delay 1)

(register-services
 (list (service
         '(foo)
         #:start (const 'abc)
         #:stop  (const #f)
         #:documentation "Foo!"
         #:respawn? #t)
       (service
         '(bar)
         #:requirement '(foo)
         #:start (const 'up-and-running)
         #:stop  (const #f)
         #:documentation "Bar!"
         #:respawn? #f)))

(start-service (lookup-service 'foo))
EOF

rm -f "$pid"
shepherd -I -s "$socket" -c "$conf" -l "$log" --pid="$pid" &

# Wait till it's ready.
while ! test -f "$pid" ; do sleep 0.3 ; done

shepherd_pid="`cat $pid`"

kill -0 $shepherd_pid
test -S "$socket"

# Code to fetch service status info.
fetch_status="
  (let ((sock (open-connection \"$socket\")))
    (write-command (shepherd-command 'status 'root) sock)
    (read sock))"

# Get the full command line of the shepherd process.  When running under
# transparent emulation through Linux binfmt_misc and QEMU, argv[0] is
# 'qemu-CPU' but the emulated process does not see that when reading its own
# /proc/self/cmdline.  Thus, to avoid that discrepancy which would lead to a
# test failure, strip it with the first 'sed' below.
shepherd_command="
  $(cat /proc/$shepherd_pid/cmdline \
    | xargs -0 \
    | sed -e's,^[[:graph:]]\+/qemu-[[:graph:]]\+ [[:graph:]]\+ ,,g' \
    | sed -e's/ /" "/g ; s/^/"/; s/$/"/')"

root_service_sexp="
   (service (version 0)
      (provides (root shepherd))
      (requires ())
      (respawn? #f)
      (docstring \"The root service is used to operate on shepherd itself.\")
      (enabled? #t)
      (running (process (version 0)
                        (id $shepherd_pid)
                        (command ($shepherd_command))))
      (conflicts ())
      (last-respawns ())
      (status-changes ((running . 0) (starting . 0)))
      (startup-failures ())
      (status running)
      (one-shot? #f)
      (transient? #f)
      (respawn-limit (5 . 7))
      (respawn-delay 0.1)
      (actions (help status halt power-off kexec load eval unload reload daemonize restart))
      (exit-statuses ())
      (recent-messages ())
      (log-files (\"$PWD/$log\"))
      (pending-replacement? #f))"

# Define a helper procedure that resets timestamps in the 'status-changes'
# property to make it easier to compare them.
define_canonicalize="
(define (reset-timestamps service)
  (match service
    (('service version properties ...)
     (cons* 'service version
            (map (match-lambda
                   (('status-changes alist)
                    (list 'status-changes
                          (map (match-lambda
                                 ((status . _)
                                  (cons status 0)))
                               alist)))
                   (prop prop))
                 properties)))))

(define (remove-messages service)
  (match service
    (('service version properties ...)
     (cons* 'service version
            (map (match-lambda
                   (('recent-messages _)
                    '(recent-messages ()))
                   (prop prop))
                 properties)))))

(define canonicalize-service-sexp
  (compose reset-timestamps remove-messages))
"

"$GUILE" -c "
(use-modules (shepherd comm) (srfi srfi-1) (ice-9 match))

$define_canonicalize

(exit
 (match $fetch_status
   (('reply _ ('result (services)) ('error #f) ('messages ()))
    (lset= equal?
           (pk 'ACTUAL (map canonicalize-service-sexp services))
           '($root_service_sexp
             (service (version 0)
               (provides (foo)) (requires ())
               (respawn? #t) (docstring \"Foo!\")
               (enabled? #t) (running abc) (conflicts ())
               (last-respawns ())
               (status-changes ((running . 0) (starting . 0)))
               (startup-failures ())
               (status running)
               (one-shot? #f) (transient? #f)
               (respawn-limit (5 . 7)) (respawn-delay 1)
               (actions ())
               (exit-statuses ())
	       (recent-messages ())
	       (log-files ())
	       (pending-replacement? #f))
             (service (version 0)
               (provides (bar)) (requires (foo))
               (respawn? #f) (docstring \"Bar!\")
               (enabled? #t) (running #f) (conflicts ())
               (last-respawns ())
               (status-changes ())
               (startup-failures ())
               (status stopped)
               (one-shot? #f) (transient? #f)
               (respawn-limit (5 . 7)) (respawn-delay 1)
               (actions ())
               (exit-statuses ())
               (recent-messages ())
	       (log-files ())
	       (pending-replacement? #f)))))))
"

# The 'start' command should return the service sexp on success.
"$GUILE" -c "
(use-modules (shepherd comm) (srfi srfi-1) (ice-9 match))

$define_canonicalize

(define (start name)
  ;; Start service NAME.
  (let ((sock (open-connection \"$socket\")))
    (write-command (shepherd-command 'start name) sock)
    (read sock)))

(exit
 (match (start 'bar)
   (('reply _ ('result service) ('error #f) ('messages (_)))
    (equal? (canonicalize-service-sexp service)
            '(service (version 0)
               (provides (bar)) (requires (foo))
               (respawn? #f) (docstring \"Bar!\")
               (enabled? #t) (running up-and-running) (conflicts ())
               (last-respawns ())
               (status-changes ((running . 0) (starting . 0)))
               (startup-failures ())
               (status running)
               (one-shot? #f) (transient? #f)
               (respawn-limit (5 . 7)) (respawn-delay 1)
               (actions ())
               (exit-statuses ())
	       (recent-messages ())
	       (log-files ())
	       (pending-replacement? #f))))))
"

# Make sure we get an 'error' sexp when querying a nonexistent service.
"$GUILE" -c "
(use-modules (shepherd comm) (ice-9 match))

(match (let ((sock (open-connection \"$socket\")))
         (write-command (shepherd-command 'status 'does-not-exist) sock)
         (read sock))
  (('reply _ ...
    ('error ('error _ 'service-not-found 'does-not-exist))
    ('messages ()))
   #t)
  (x
   (pk 'wrong x)
   (exit 1)))"

# Unload everything and make sure only 'root' is left.
$herd unload root all

"$GUILE" -c "
(use-modules (shepherd comm) (ice-9 match))

$define_canonicalize

(exit
  (equal? (match $fetch_status
            (('reply version ('result ((service))) rest ...)
             (cons* 'reply version
                     (list 'result
                            (list (list (canonicalize-service-sexp service))))
                     rest)))
          '(reply
            (version 0)
            (result (($root_service_sexp)))
            (error #f) (messages ()))))"

cat > "$client" <<EOF
#!$GUILE --no-auto-compile
!#
;; -*- coding: utf-8 -*-
(use-modules (shepherd comm) (ice-9 match))

;; Make sure commands are written and read as UTF-8.
(let ((sock (open-connection "$socket")))
  (write-command (shepherd-command '😓 'root) sock)
  (match (read sock)
    ((quasiquote (reply (version 0) (result #f)
                        (error (error (version 0) action-not-found 😓 root))
                        (messages ())))
     (= (string-length "😓") 1))))
EOF

chmod +x "$client"
"$client"

$herd stop root

test -f "$log"
