| 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> |
| 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 (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)) |
| 35 | |
| 36 | ;; When using --system argument, binfmt-misc mechanism may be used. In that |
| 37 | ;; case, (guix script processes) won't work because: |
| 38 | ;; |
| 39 | ;; * ARGV0 is qemu-user and not guix-daemon. |
| 40 | ;; * Guix-daemon won't be able to stuff client PID in ARGV1 of forked |
| 41 | ;; processes. |
| 42 | ;; |
| 43 | ;; See: https://lists.gnu.org/archive/html/bug-guix/2019-12/msg00017.html. |
| 44 | ;; |
| 45 | ;; If we detect that we are running with binfmt emulation, all the following |
| 46 | ;; tests must be skipped. |
| 47 | |
| 48 | (define (binfmt-misc?) |
| 49 | (let ((pid (getpid)) |
| 50 | (cmdline (call-with-input-file "/proc/self/cmdline" get-string-all))) |
| 51 | (match (primitive-fork) |
| 52 | (0 (dynamic-wind |
| 53 | (const #t) |
| 54 | (lambda () |
| 55 | (exit |
| 56 | (not (equal? |
| 57 | (call-with-input-file (format #f "/proc/~a/cmdline" pid) |
| 58 | get-string-all) |
| 59 | cmdline)))) |
| 60 | (const #t))) |
| 61 | (x (zero? (cdr (waitpid x))))))) |
| 62 | |
| 63 | (define-syntax-rule (test-assert* description exp) |
| 64 | (begin |
| 65 | (when (binfmt-misc?) |
| 66 | (test-skip 1)) |
| 67 | (test-assert description exp))) |
| 68 | |
| 69 | (test-begin "processes") |
| 70 | |
| 71 | (test-assert* "not a client" |
| 72 | (not (find (lambda (session) |
| 73 | (= (getpid) |
| 74 | (process-id (daemon-session-client session)))) |
| 75 | (daemon-sessions)))) |
| 76 | |
| 77 | (test-assert* "client" |
| 78 | (with-store store |
| 79 | (let* ((session (find (lambda (session) |
| 80 | (= (getpid) |
| 81 | (process-id (daemon-session-client session)))) |
| 82 | (daemon-sessions))) |
| 83 | (daemon (daemon-session-process session))) |
| 84 | (and (kill (process-id daemon) 0) |
| 85 | (string-suffix? "guix-daemon" (first (process-command daemon))))))) |
| 86 | |
| 87 | (test-assert* "client + lock" |
| 88 | (with-store store |
| 89 | (call-with-temporary-directory |
| 90 | (lambda (directory) |
| 91 | (let* ((token1 (string-append directory "/token1")) |
| 92 | (token2 (string-append directory "/token2")) |
| 93 | (exp #~(begin #$(random-text) |
| 94 | (mkdir #$token1) |
| 95 | (let loop () |
| 96 | (unless (file-exists? #$token2) |
| 97 | (sleep 1) |
| 98 | (loop))) |
| 99 | (mkdir #$output))) |
| 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 |
| 105 | (lambda () |
| 106 | (build-derivations store (list drv))))) |
| 107 | (_ (let loop () |
| 108 | (unless (file-exists? token1) |
| 109 | (usleep 200) |
| 110 | (loop)))) |
| 111 | (session (find (lambda (session) |
| 112 | (= (getpid) |
| 113 | (process-id (daemon-session-client session)))) |
| 114 | (daemon-sessions))) |
| 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")) |
| 118 | locks)))))) |
| 119 | |
| 120 | (test-end "processes") |