projects/guix·blob java-team · refs

90 lines · 3.4 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2024 Reepca Russelstein <[email protected]>
3;;; Copyright © 2024 Ludovic Courtès <[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-store-deadlock)
21 #:use-module (guix tests)
22 #:use-module (guix store)
23 #:use-module (guix derivations)
24 #:use-module (guix gexp)
25 #:use-module (guix monads)
26 #:use-module (gnu packages bootstrap)
27 #:use-module (ice-9 threads)
28 #:use-module (srfi srfi-1)
29 #:use-module (srfi srfi-64))
30
31(define input-drvs
32 (map (lambda (n)
33 (computed-file (string-append "drv" (number->string n))
34 #~(begin
35 #$(random-text)
36 (sleep 4)
37 (mkdir #$output))
38 #:guile %bootstrap-guile))
39 (iota 15)))
40
41(define top-drv
42 (computed-file "top-drv"
43 #~(begin
44 #$(random-text)
45 (sleep 3)
46 (pk 'deps: #$@input-drvs)
47 (mkdir #$output))
48 #:guile %bootstrap-guile))
49
50(%graft? #f)
51
52
53(test-begin "store-deadlock")
54
55(test-equal "no deadlock" ;https://issues.guix.gnu.org/31785
56 '(thread1 thread2 thread3)
57
58 ;; This test checks for the absence of a deadlock when guix-daemon spawns
59 ;; several child processes (one for each client) that compete to build the
60 ;; same set of derivations. See <https://issues.guix.gnu.org/31785>.
61 (let* ((drvs (cons top-drv input-drvs))
62 (builder (lambda (name lst)
63 (call-with-new-thread
64 (lambda ()
65 (with-store store
66 (set-build-options store
67 #:verbosity 3
68 #:max-build-jobs 1)
69 (run-with-store store
70 (mlet %store-monad ((lst (mapm %store-monad
71 lower-object lst)))
72 (mbegin %store-monad
73 (built-derivations lst)
74 (return name)))))))))
75 (thread1 (builder 'thread1 drvs))
76 (thread2 (begin
77 (sleep 1)
78 (builder 'thread2 drvs)))
79 (thread3 (begin
80 (sleep 1)
81 (builder 'thread3 drvs))))
82
83 ;; This test should complete in less than a minute; if not, there's a
84 ;; deadlock.
85 (let ((deadline (+ (current-time) 120)))
86 (list (join-thread thread1 deadline 'timeout)
87 (join-thread thread2 deadline 'timeout)
88 (join-thread thread3 deadline 'timeout)))))
89
90(test-end)