projects/guix·blob master · refs

127 lines · 5.0 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2018, 2025 Ludovic Courtès <[email protected]>
3;;; Copyright © 2019 Mathieu Othacehe <[email protected]>
4;;;
5;;; This file is part of GNU Guix.
6;;;
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.
11;;;
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.
16;;;
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/>.
19
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 ((gnu build linux-container)
29 #:select (unprivileged-user-namespace-supported?))
30 #:use-module (guix tests)
31 #:use-module (srfi srfi-1)
32 #:use-module (srfi srfi-64)
33 #:use-module (rnrs bytevectors)
34 #:use-module (rnrs io ports)
35 #:use-module (ice-9 match)
36 #:use-module (ice-9 threads))
37
38;; When using --system argument, binfmt-misc mechanism may be used. In that
39;; case, (guix script processes) won't work because:
40;;
41;; * ARGV0 is qemu-user and not guix-daemon.
42;; * Guix-daemon won't be able to stuff client PID in ARGV1 of forked
43;; processes.
44;;
45;; See: https://lists.gnu.org/archive/html/bug-guix/2019-12/msg00017.html.
46;;
47;; If we detect that we are running with binfmt emulation, all the following
48;; tests must be skipped.
49
50(define (binfmt-misc?)
51 (let ((pid (getpid))
52 (cmdline (call-with-input-file "/proc/self/cmdline" get-string-all)))
53 (match (primitive-fork)
54 (0 (dynamic-wind
55 (const #t)
56 (lambda ()
57 (exit
58 (not (equal?
59 (call-with-input-file (format #f "/proc/~a/cmdline" pid)
60 get-string-all)
61 cmdline))))
62 (const #t)))
63 (x (zero? (cdr (waitpid x)))))))
64
65(define-syntax-rule (test-assert* description exp)
66 (begin
67 (when (binfmt-misc?)
68 (test-skip 1))
69 (test-assert description exp)))
70
71(test-begin "processes")
72
73(test-assert* "not a client"
74 (not (find (lambda (session)
75 (= (getpid)
76 (process-id (daemon-session-client session))))
77 (daemon-sessions))))
78
79(test-assert* "client"
80 (with-store store
81 (let* ((session (find (lambda (session)
82 (= (getpid)
83 (process-id (daemon-session-client session))))
84 (daemon-sessions)))
85 (daemon (daemon-session-process session)))
86 (and (kill (process-id daemon) 0)
87 (string-suffix? "guix-daemon" (first (process-command daemon)))))))
88
89(when (unprivileged-user-namespace-supported?)
90 ;; The test below assumes the build process can communicate with the outside
91 ;; world via the TOKEN1 and TOKEN2 files, which is impossible when
92 ;; guix-daemon is set up to build in separate namespaces.
93 (test-skip 1))
94(test-assert* "client + lock"
95 (with-store store
96 (call-with-temporary-directory
97 (lambda (directory)
98 (let* ((token1 (string-append directory "/token1"))
99 (token2 (string-append directory "/token2"))
100 (exp #~(begin #$(random-text)
101 (mkdir #$token1)
102 (let loop ()
103 (unless (file-exists? #$token2)
104 (sleep 1)
105 (loop)))
106 (mkdir #$output)))
107 (guile (package-derivation store %bootstrap-guile))
108 (drv (run-with-store store
109 (gexp->derivation "foo" exp
110 #:guile-for-build guile)))
111 (thread (call-with-new-thread
112 (lambda ()
113 (build-derivations store (list drv)))))
114 (_ (let loop ()
115 (unless (file-exists? token1)
116 (usleep 200)
117 (loop))))
118 (session (find (lambda (session)
119 (= (getpid)
120 (process-id (daemon-session-client session))))
121 (daemon-sessions)))
122 (locks (daemon-session-locks-held (pk 'session session))))
123 (call-with-output-file token2 (const #t))
124 (equal? (list (string-append (derivation->output-path drv) ".lock"))
125 locks))))))
126
127(test-end "processes")