aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016-2019, 2022-2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu services herd)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 match)
  #:export (%shepherd-socket-file
            shepherd-message-port

            shepherd-error?
            service-not-found-error?
            service-not-found-error-service
            action-not-found-error?
            action-not-found-error-service
            action-not-found-error-action
            action-exception-error?
            action-exception-error-service
            action-exception-error-action
            action-exception-error-key
            action-exception-error-arguments
            unknown-shepherd-error?
            unknown-shepherd-error-sexp

            live-service
            live-service?
            live-service-provision
            live-service-requirement
            live-service-running
            live-service-transient?
            live-service-canonical-name

            with-shepherd-action
            current-service
            current-services
            unload-services
            unload-service
            load-services
            load-services/safe
            start-service
            stop-service
            restart-service
            wait-for-service))

;;; Commentary:
;;;
;;; This module provides an interface to the GNU Shepherd, similar to the
;;; 'herd' command.  Essentially it implements a subset of the (shepherd comm)
;;; module, but focusing only on the parts relevant to 'guix system
;;; reconfigure'.
;;;
;;; Code:

(define %shepherd-socket-file
  (make-parameter "/var/run/shepherd/socket"))

(define* (open-connection #:optional (file (%shepherd-socket-file)))
  "Open a connection to the daemon, using the Unix-domain socket at FILE, and
return the socket."
  ;; The protocol is sexp-based and UTF-8-encoded.
  (with-fluids ((%default-port-encoding "UTF-8"))
    (let ((sock    (socket PF_UNIX SOCK_STREAM 0))
          (address (make-socket-address PF_UNIX file)))
      (catch 'system-error
        (lambda ()
          (connect sock address)
          (setvbuf sock 'block 1024)
          sock)
        (lambda args
          (close-port sock)
          (apply throw args))))))

(define-syntax-rule (with-shepherd connection body ...)
  "Evaluate BODY... with CONNECTION bound to an open socket to PID 1."
  (let ((connection (open-connection)))
    (dynamic-wind
      (const #t)
      (lambda ()
        body ...)
      (lambda ()
        (close-port connection)))))

(define-condition-type &shepherd-error &error
  shepherd-error?)

(define-condition-type &service-not-found-error &shepherd-error
  service-not-found-error?
  (service service-not-found-error-service))

(define-condition-type &action-not-found-error &shepherd-error
  action-not-found-error?
  (service action-not-found-error-service)
  (action  action-not-found-error-action))

(define-condition-type &action-exception-error &shepherd-error
  action-exception-error?
  (service action-exception-error-service)
  (action  action-exception-error-action)
  (key     action-exception-error-key)
  (args    action-exception-error-arguments))

(define-condition-type &unknown-shepherd-error &shepherd-error
  unknown-shepherd-error?
  (sexp   unknown-shepherd-error-sexp))

(define (raise-shepherd-error error)
  "Raise an error condition corresponding to ERROR, an sexp received by a
shepherd client in reply to COMMAND, a command object.  Return #t if ERROR
does not denote an error."
  (match error
    (('error ('version 0 x ...) 'service-not-found service)
     (raise (condition (&service-not-found-error
                        (service service)))))
    (('error ('version 0 x ...) 'action-not-found action service)
     (raise (condition (&action-not-found-error
                        (service service)
                        (action action)))))
    (('error ('version 0 x ...) 'action-exception action service
             key (args ...))
     (raise (condition (&action-exception-error
                        (service service)
                        (action action)
                        (key key) (args args)))))
    (('error . _)
     (raise (condition (&unknown-shepherd-error (sexp error)))))
    (#f                                           ;not an error
     #t)))

(define shepherd-message-port
  ;; Port where messages coming from shepherd are printed.
  (make-parameter (current-error-port)))

(define (display-message message)
  (format (shepherd-message-port) "shepherd: ~a~%" message))

(define* (invoke-action service action arguments cont)
  "Invoke ACTION on SERVICE with ARGUMENTS.  On success, call CONT with the
list of results (one result per instance with the name SERVICE).  Otherwise
return #f."
  (with-shepherd sock
    (write `(shepherd-command (version 0)
                              (action ,action)
                              (service ,service)
                              (arguments ,arguments)
                              (directory ,(getcwd)))
           sock)
    (force-output sock)

    (match (read sock)
      (('reply ('version 0 _ ...) ('result result) ('error #f)
               ('messages messages))
       (for-each display-message messages)
       (cont result))
      (('reply ('version 0 x ...) ('result y) ('error error)
               ('messages messages))
       (for-each display-message messages)
       (raise-shepherd-error error)
       #f)
      (x
       ;; invalid reply
       #f))))

(define-syntax-rule (with-shepherd-action service (action args ...)
                      result body ...)
  "Invoke ACTION on SERVICE with the given ARGS, and evaluate BODY with RESULT
bound to the action's result."
  (invoke-action service action (list args ...)
                 (lambda (result) body ...)))

(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 ...))))

;; Information about live Shepherd services.
(define-record-type <live-service>
  (live-service provision requirement transient? running)
  live-service?
  (provision    live-service-provision)           ;list of symbols
  (requirement  live-service-requirement)         ;list of symbols
  (transient?   live-service-transient?)          ;Boolean
  (running      live-service-running))            ;#f | object

(define (live-service-canonical-name service)
  "Return the 'canonical name' of SERVICE."
  (first (live-service-provision service)))

(define (current-service name)
  "Return the currently defined Shepherd service NAME, as a <live-service>
object.  Return #f if the service could not be obtained.  As a special case,
@code{(current-service 'root)} returns all the current services."
  (define (process-services services)
    (resolve-transients
     (map (lambda (service)
            (alist-let* service (provides requires running transient?)
              ;; The Shepherd 0.9.0 would not provide 'transient?' in
              ;; its status sexp.  Thus, when it's missing, query it
              ;; via an "eval" request.
              (live-service provides requires
                            (if (sloppy-assq 'transient? service)
                                transient?
                                (and running *unspecified*))
                            running)))
          services)))

  (with-shepherd-action name ('status) results
    ;; We get a list of results, one for each service with the name NAME.
    ;; In practice there's only one such service though.
    (match results
      ((services _ ...)
       (match services
         ((('service ('version 0 _ ...) _ ...) ...)
          ;; Summary of all services (when NAME is 'root or 'shepherd).
          (process-services services))
         (('service ('version 0 _ ...) _ ...) ;single service
          (first (process-services (list services))))
         (x
          #f))))))                ;singleton

(define (current-services)
  "Return the list of currently defined Shepherd services, represented as
<live-service> objects.  Return #f if the list of services could not be
obtained."
  (current-service 'root))

(define (resolve-transients services)
  "Resolve the subset of SERVICES whose 'transient?' field is undefined.  This
is necessary to deal with Shepherd 0.9.0, which did not communicate whether a
service is transient."
  ;; All the fuss here is to make sure we make a single "eval root" request
  ;; for all of SERVICES.
  (let* ((unresolved (filter (compose unspecified? live-service-transient?)
                             services))
         (values     (or (and (pair? unresolved)
                              (eval-there
                               `(and (defined? 'transient?) ;shepherd >= 0.9.0
                                     (map (compose transient? lookup-running)
                                          ',(map (compose first
                                                          live-service-provision)
                                                 unresolved)))))
                         (make-list (length unresolved) #f)))
         (resolved   (map (lambda (unresolved transient?)
                            (cons unresolved
                                  (set-field unresolved
                                             (live-service-transient?)
                                             transient?)))
                          unresolved values)))
    (map (lambda (service)
           (or (assq-ref resolved service) service))
         services)))

(define (unload-service service)
  "Unload SERVICE, a symbol name; return #t on success."
  (with-shepherd-action 'root ('unload (symbol->string service)) result
    (first result)))

(define (%load-file file)
  "Load FILE in the Shepherd."
  (with-shepherd-action 'root ('load file) result
    (first result)))

(define (eval-there exp)
  "Eval EXP in the Shepherd."
  (with-shepherd-action 'root ('eval (object->string exp)) result
    (first result)))

(define (load-services files)
  "Load and register the services from FILES, where FILES contain code that
returns a shepherd <service> object."
  (eval-there `(register-services
                ,@(map (lambda (file)
                         `(primitive-load ,file))
                       files))))

(define load-services/safe
  ;; Deprecated.  It used to behave differently before service replacements
  ;; were a thing.
  load-services)

(define* (start-service name #:optional (arguments '()))
  (invoke-action name 'start arguments
                 (lambda (result)
                   result)))

(define (stop-service name)
  (with-shepherd-action name ('stop) result
    result))

(define (restart-service name)
  (with-shepherd-action name ('restart) result
    result))

(define* (wait-for-service name #:key (timeout 20))
  "Wait for the service providing NAME, a symbol, to be up and running, and
return its \"running value\".  Give up after TIMEOUT seconds and raise a
'&shepherd-error' exception.  Raise a '&service-not-found-error' exception
when NAME is not found."
  (define (relevant-service? service)
    (memq name (live-service-provision service)))

  (define start
    (car (gettimeofday)))

  ;; Note: As of Shepherd 0.9.1, we cannot just call the 'start' method and
  ;; wait for it: it would spawn an additional elogind process.  Thus, poll.
  (let loop ((attempts 0))
    (define services
      (current-services))

    (define now
      (car (gettimeofday)))

    (when (>= (- now start) timeout)
      (raise (condition (&shepherd-error))))      ;XXX: better exception?

    (match (find relevant-service? services)
      (#f
       (raise (condition (&service-not-found-error
                          (service name)))))
      (service
       (or (live-service-running service)
           (begin
             (sleep 1)
             (loop (+ attempts 1))))))))

;; Local Variables:
;; eval: (put 'alist-let* 'scheme-indent-function 2)
;; eval: (put 'with-shepherd 'scheme-indent-function 1)
;; eval: (put 'with-shepherd-action 'scheme-indent-function 3)
;; End:

;;; herd.scm ends here
generated by cgit
;/two"))) (file-exists? (string-append out "/one/replacement"))))))) (test-assert "graft-derivation, multiple outputs need to be replaced" ;; Build a reference graph like this: ;; ;; ,- p2:out --. ;; v v ;; p1:one <---- p1:two ;; | ;; `-> p0 ;; ;; Graft p0r in lieu of p0, and make sure all the paths from the grafted p2 ;; lead to p0r. See <https://issues.guix.gnu.org/66662>. (let* ((p0 (build-expression->derivation %store "p0" '(mkdir (assoc-ref %outputs "out")))) (p0r (build-expression->derivation %store "P0" '(let ((out (assoc-ref %outputs "out"))) (mkdir out) (call-with-output-file (string-append out "/replacement") (const #t))))) (p1 (build-expression->derivation %store "p1" `(let ((one (assoc-ref %outputs "one")) (two (assoc-ref %outputs "two")) (p0 (assoc-ref %build-inputs "p0"))) (mkdir one) (mkdir two) (symlink p0 (string-append one "/p0")) (symlink one (string-append two "/link"))) #:inputs `(("p0" ,p0)) #:outputs '("one" "two"))) (p2 (build-expression->derivation %store "p2" `(let ((out (assoc-ref %outputs "out"))) (mkdir out) (chdir out) (symlink (assoc-ref %build-inputs "p1:one") "one") (symlink (assoc-ref %build-inputs "p1:two") "two")) #:inputs `(("p1:one" ,p1 "one") ("p1:two" ,p1 "two")))) (p0g (list (graft (origin p0) (replacement p0r)))) (p2d (graft-derivation %store p2 p0g))) (build-derivations %store (list p2d)) (let ((out (derivation->output-path (pk 'p2d p2d)))) (equal? (stat (string-append out "/one/p0/replacement")) (stat (string-append out "/two/link/p0/replacement")))))) (test-assert "graft-derivation with #:outputs" ;; Call 'graft-derivation' with a narrowed set of outputs passed as ;; #:outputs. (let* ((p1 (build-expression->derivation %store "p1" `(let ((one (assoc-ref %outputs "one")) (two (assoc-ref %outputs "two"))) (mkdir one) (mkdir two)) #:outputs '("one" "two"))) (p1r (build-expression->derivation %store "P1" `(let ((other (assoc-ref %outputs "ONE"))) (mkdir other) (call-with-output-file (string-append other "/replacement") (const #t))) #:outputs '("ONE"))) (p2 (build-expression->derivation %store "p2" `(let ((aaa (assoc-ref %outputs "aaa")) (zzz (assoc-ref %outputs "zzz"))) (mkdir zzz) (chdir zzz) (mkdir aaa) (chdir aaa) (symlink (assoc-ref %build-inputs "p1:two") "two")) #:outputs '("aaa" "zzz") #:inputs `(("p1:one" ,p1 "one") ("p1:two" ,p1 "two")))) (p1g (graft (origin p1) (origin-output "one") (replacement p1r) (replacement-output "ONE"))) (p2g (graft-derivation %store p2 (list p1g) #:outputs '("aaa")))) ;; P2:aaa depends on P1:two, but not on P1:one, so nothing to graft. (eq? p2g p2))) (test-equal "graft-derivation, unused outputs not depended on" '("aaa") ;; Make sure that the result of 'graft-derivation' does not pull outputs ;; that are irrelevant to the grafting process. See ;; <http://bugs.gnu.org/24886>. (let* ((p1 (build-expression->derivation %store "p1" `(let ((one (assoc-ref %outputs "one")) (two (assoc-ref %outputs "two"))) (mkdir one) (mkdir two)) #:outputs '("one" "two"))) (p1r (build-expression->derivation %store "P1" `(let ((other (assoc-ref %outputs "ONE"))) (mkdir other) (call-with-output-file (string-append other "/replacement") (const #t))) #:outputs '("ONE"))) (p2 (build-expression->derivation %store "p2" `(let ((aaa (assoc-ref %outputs "aaa")) (zzz (assoc-ref %outputs "zzz"))) (mkdir zzz) (chdir zzz) (symlink (assoc-ref %build-inputs "p1:two") "two") (mkdir aaa) (chdir aaa) (symlink (assoc-ref %build-inputs "p1:one") "one")) #:outputs '("aaa" "zzz") #:inputs `(("p1:one" ,p1 "one") ("p1:two" ,p1 "two")))) (p1g (graft (origin p1) (origin-output "one") (replacement p1r) (replacement-output "ONE"))) (p2g (graft-derivation %store p2 (list p1g) #:outputs '("aaa")))) ;; Here P2G should only depend on P1:one and P1R:one; it must not depend ;; on P1:two or P1R:two since these are unused in the grafting process. (and (not (eq? p2g p2)) (let* ((inputs (derivation-inputs p2g)) (match-input (lambda (drv) (lambda (input) (string=? (derivation-input-path input) (derivation-file-name drv))))) (p1-inputs (filter (match-input p1) inputs)) (p1r-inputs (filter (match-input p1r) inputs)) (p2-inputs (filter (match-input p2) inputs))) (and (equal? p1-inputs (list (derivation-input p1 '("one")))) (equal? p1r-inputs (list (derivation-input p1r '("ONE")))) (equal? p2-inputs (list (derivation-input p2 '("aaa")))) (derivation-output-names p2g)))))) (test-assert "graft-derivation, renaming" ;<http://bugs.gnu.org/23132> (let* ((build `(begin (use-modules (guix build utils)) (mkdir-p (string-append (assoc-ref %outputs "out") "/" (assoc-ref %build-inputs "in"))))) (orig (build-expression->derivation %store "thing-to-graft" build #:modules '((guix build utils)) #:inputs `(("in" ,%bash)))) (repl (add-text-to-store %store "bash" "fake bash")) (grafted (graft-derivation %store orig (list (graft (origin %bash) (replacement repl)))))) (and (build-derivations %store (list grafted)) (let ((out (derivation->output-path grafted))) (file-is-directory? (string-append out "/" repl)))))) (test-assert "graft-derivation, grafts are not shadowed" ;; We build a DAG as below, where dotted arrows represent replacements and ;; solid arrows represent dependencies: ;; ;; P1 ·············> P1R ;; |\__________________. ;; v v ;; P2 ·············> P2R ;; | ;; v ;; P3 ;; ;; We want to make sure that the two grafts we want to apply to P3 are ;; honored and not shadowed by other computed grafts. (let* ((p1 (build-expression->derivation %store "p1" '(mkdir (assoc-ref %outputs "out")))) (p1r (build-expression->derivation %store "P1" '(let ((out (assoc-ref %outputs "out"))) (mkdir out) (call-with-output-file (string-append out "/replacement") (const #t))))) (p2 (build-expression->derivation %store "p2" `(let ((out (assoc-ref %outputs "out"))) (mkdir out) (chdir out) (symlink (assoc-ref %build-inputs "p1") "p1")) #:inputs `(("p1" ,p1)))) (p2r (build-expression->derivation %store "P2" `(let ((out (assoc-ref %outputs "out"))) (mkdir out) (chdir out) (symlink (assoc-ref %build-inputs "p1") "p1") (call-with-output-file (string-append out "/replacement") (const #t))) #:inputs `(("p1" ,p1)))) (p3 (build-expression->derivation %store "p3" `(let ((out (assoc-ref %outputs "out"))) (mkdir out) (chdir out) (symlink (assoc-ref %build-inputs "p2") "p2")) #:inputs `(("p2" ,p2)))) (p1g (graft (origin p1) (replacement p1r))) (p2g (graft (origin p2) (replacement (graft-derivation %store p2r (list p1g))))) (p3d (graft-derivation %store p3 (list p1g p2g)))) (and (build-derivations %store (list p3d)) (let ((out (derivation->output-path (pk p3d)))) ;; Make sure OUT refers to the replacement of P2, which in turn ;; refers to the replacement of P1, as specified by P1G and P2G. ;; It used to be the case that P2G would be shadowed by a simple ;; P2->P2R graft, which is not what we want. (and (file-exists? (string-append out "/p2/replacement")) (file-exists? (string-append out "/p2/p1/replacement"))))))) (define buffer-size ;; Must be equal to REQUEST-SIZE in 'replace-store-references'. (expt 2 20)) (test-equal "replace-store-references, <http://bugs.gnu.org/28212>" (string-append (make-string (- buffer-size 47) #\a) "/gnu/store/" (make-string 32 #\8) "-SoMeTHiNG" (list->string (map integer->char (iota 77 33)))) ;; Create input data where the right-hand-size of the dash ("-something" ;; here) goes beyond the end of the internal buffer of ;; 'replace-store-references'. (let* ((content (string-append (make-string (- buffer-size 47) #\a) "/gnu/store/" (make-string 32 #\7) "-something" (list->string (map integer->char (iota 77 33))))) (replacement (alist->vhash `((,(make-string 32 #\7) . ,(string->utf8 (string-append (make-string 32 #\8) "-SoMeTHiNG"))))))) (call-with-output-string (lambda (output) ((@@ (guix build graft) replace-store-references) (open-input-string content) output replacement "/gnu/store"))))) (define (insert-nuls char-size str) (string-join (map string (string->list str)) (make-string (- char-size 1) #\nul))) (define (nuls-to-underscores s) (string-replace-substring s "\0" "_")) (define (annotate-buffer-boundary s) (string-append (string-take s buffer-size) "|" (string-drop s buffer-size))) (define (abbreviate-leading-fill s) (let ((s* (string-trim s #\=))) (format #f "[~a =s]~a" (- (string-length s) (string-length s*)) s*))) (define (prettify-for-display s) (abbreviate-leading-fill (annotate-buffer-boundary (nuls-to-underscores s)))) (define (two-sample-refs-with-gap char-size1 char-size2 gap offset char1 name1 char2 name2) (string-append (make-string (- buffer-size offset) #\=) (insert-nuls char-size1 (string-append "/gnu/store/" (make-string 32 char1) name1)) gap (insert-nuls char-size2 (string-append "/gnu/store/" (make-string 32 char2) name2)) (list->string (map integer->char (iota 77 33))))) (define (sample-map-entry old-char new-char new-name) (cons (make-string 32 old-char) (string->utf8 (string-append (make-string 32 new-char) new-name)))) (define (test-two-refs-with-gap char-size1 char-size2 gap offset) (test-equal (format #f "test-two-refs-with-gap, char-sizes ~a ~a, gap ~s, offset ~a" char-size1 char-size2 gap offset) (prettify-for-display (two-sample-refs-with-gap char-size1 char-size2 gap offset #\6 "-BlahBlaH" #\8"-SoMeTHiNG")) (prettify-for-display (let* ((content (two-sample-refs-with-gap char-size1 char-size2 gap offset #\5 "-blahblah" #\7 "-something")) (replacement (alist->vhash (list (sample-map-entry #\5 #\6 "-BlahBlaH") (sample-map-entry #\7 #\8 "-SoMeTHiNG"))))) (call-with-output-string (lambda (output) ((@@ (guix build graft) replace-store-references) (open-input-string content) output replacement "/gnu/store"))))))) (for-each (lambda (char-size1) (for-each (lambda (char-size2) (for-each (lambda (gap) (for-each (lambda (offset) (test-two-refs-with-gap char-size1 char-size2 gap offset)) ;; offsets to test (map (lambda (i) (+ i (* 40 char-size1))) (iota 30)))) ;; gaps '("" "-" " " "a"))) ;; char-size2 values to test '(1 2))) ;; char-size1 values to test '(1 2 4)) (test-end)
generated by cgit