tests/processes.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (test-processes)
  20   #:use-module (guix scripts processes)
  21   #:use-module (guix store)
  22   #:use-module (guix derivations)
  23   #:use-module (guix packages)
  24   #:use-module (guix gexp)
  25   #:use-module ((guix utils) #:select (call-with-temporary-directory))
  26   #:use-module (gnu packages bootstrap)
  27   #:use-module (guix tests)
  28   #:use-module (srfi srfi-1)
  29   #:use-module (srfi srfi-64)
  30   #:use-module (rnrs bytevectors)
  31   #:use-module (rnrs io ports)
  32   #:use-module (ice-9 match)
  33   #:use-module (ice-9 threads))
  34
  35 (test-begin "processes")
  36
  37 (test-assert "not a client"
  38   (not (find (lambda (session)
  39                (= (getpid)
  40                   (process-id (daemon-session-client session))))
  41              (daemon-sessions))))
  42
  43 (test-assert "client"
  44   (with-store store
  45     (let* ((session (find (lambda (session)
  46                             (= (getpid)
  47                                (process-id (daemon-session-client session))))
  48                           (daemon-sessions)))
  49            (daemon  (daemon-session-process session)))
  50       (and (kill (process-id daemon) 0)
  51            (string-suffix? "guix-daemon" (first (process-command daemon)))))))
  52
  53 (test-assert "client + lock"
  54   (with-store store
  55     (call-with-temporary-directory
  56      (lambda (directory)
  57        (let* ((token1  (string-append directory "/token1"))
  58               (token2  (string-append directory "/token2"))
  59               (exp     #~(begin #$(random-text)
  60                                 (mkdir #$token1)
  61                                 (let loop ()
  62                                   (unless (file-exists? #$token2)
  63                                     (sleep 1)
  64                                     (loop)))
  65                                 (mkdir #$output)))
  66               (guile   (package-derivation store %bootstrap-guile))
  67               (drv     (run-with-store store
  68                          (gexp->derivation "foo" exp
  69                                            #:guile-for-build guile)))
  70               (thread  (call-with-new-thread
  71                         (lambda ()
  72                           (build-derivations store (list drv)))))
  73               (_       (let loop ()
  74                          (unless (file-exists? token1)
  75                            (usleep 200)
  76                            (loop))))
  77               (session (find (lambda (session)
  78                                (= (getpid)
  79                                   (process-id (daemon-session-client session))))
  80                              (daemon-sessions)))
  81               (locks   (daemon-session-locks-held (pk 'session session))))
  82          (call-with-output-file token2 (const #t))
  83          (equal? (list (string-append (derivation->output-path drv) ".lock"))
  84                  locks))))))
  85
  86 (test-end "processes")