1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com>
5 ;;; This file is part of GNU Guix.
7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
8 ;;; under the terms of the GNU General Public License as published by
9 ;;; the Free Software Foundation; either version 3 of the License, or (at
10 ;;; your option) any later version.
12 ;;; GNU Guix is distributed in the hope that it will be useful, but
13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;;; GNU General Public License for more details.
17 ;;; You should have received a copy of the GNU General Public License
18 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
20 (define-module (test-processes)
21 #:use-module (guix scripts processes)
22 #:use-module (guix store)
23 #:use-module (guix derivations)
24 #:use-module (guix packages)
25 #:use-module (guix gexp)
26 #:use-module ((guix utils) #:select (call-with-temporary-directory))
27 #:use-module (gnu packages bootstrap)
28 #:use-module (guix tests)
29 #:use-module (srfi srfi-1)
30 #:use-module (srfi srfi-64)
31 #:use-module (rnrs bytevectors)
32 #:use-module (rnrs io ports)
33 #:use-module (ice-9 match)
34 #:use-module (ice-9 threads))
36 ;; When using --system argument, binfmt-misc mechanism may be used. In that
37 ;; case, (guix script processes) won't work because:
39 ;; * ARGV0 is qemu-user and not guix-daemon.
40 ;; * Guix-daemon won't be able to stuff client PID in ARGV1 of forked
43 ;; See: https://lists.gnu.org/archive/html/bug-guix/2019-12/msg00017.html.
45 ;; If we detect that we are running with binfmt emulation, all the following
46 ;; tests must be skipped.
48 (define (binfmt-misc?)
50 (cmdline (call-with-input-file "/proc/self/cmdline" get-string-all)))
51 (match (primitive-fork)
57 (call-with-input-file (format #f "/proc/~a/cmdline" pid)
61 (x (zero? (cdr (waitpid x)))))))
63 (define-syntax-rule (test-assert* description exp)
67 (test-assert description exp)))
69 (test-begin "processes")
71 (test-assert* "not a client"
72 (not (find (lambda (session)
74 (process-id (daemon-session-client session))))
77 (test-assert* "client"
79 (let* ((session (find (lambda (session)
81 (process-id (daemon-session-client session))))
83 (daemon (daemon-session-process session)))
84 (and (kill (process-id daemon) 0)
85 (string-suffix? "guix-daemon" (first (process-command daemon)))))))
87 (test-assert* "client + lock"
89 (call-with-temporary-directory
91 (let* ((token1 (string-append directory "/token1"))
92 (token2 (string-append directory "/token2"))
93 (exp #~(begin #$(random-text)
96 (unless (file-exists? #$token2)
100 (guile (package-derivation store %bootstrap-guile))
101 (drv (run-with-store store
102 (gexp->derivation "foo" exp
103 #:guile-for-build guile)))
104 (thread (call-with-new-thread
106 (build-derivations store (list drv)))))
108 (unless (file-exists? token1)
111 (session (find (lambda (session)
113 (process-id (daemon-session-client session))))
115 (locks (daemon-session-locks-held (pk 'session session))))
116 (call-with-output-file token2 (const #t))
117 (equal? (list (string-append (derivation->output-path drv) ".lock"))
120 (test-end "processes")