1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
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.
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.
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/>.
19 (define-module (guix tests)
20 #:use-module (guix store)
21 #:use-module (guix derivations)
22 #:use-module (guix packages)
23 #:use-module (guix base32)
24 #:use-module (guix serialization)
25 #:use-module (guix hash)
26 #:use-module (guix build-system gnu)
27 #:use-module (gnu packages bootstrap)
28 #:use-module (srfi srfi-34)
29 #:use-module (rnrs bytevectors)
30 #:use-module (rnrs io ports)
31 #:use-module (web uri)
32 #:export (open-connection-for-tests
40 with-derivation-narinfo
41 with-derivation-substitute
47 ;;; This module provide shared infrastructure for the test suite. For
48 ;;; internal use only.
52 (define (open-connection-for-tests)
53 "Open a connection to the build daemon for tests purposes and return it."
54 (guard (c ((nix-error? c)
55 (format (current-error-port)
56 "warning: build daemon error: ~s~%" c)
58 (let ((store (open-connection)))
59 ;; Make sure we build everything by ourselves.
60 (set-build-options store #:use-substitutes? #f)
62 ;; Use the bootstrap Guile when running tests, so we don't end up
63 ;; building everything in the temporary test store.
64 (%guile-for-build (package-derivation store %bootstrap-guile))
69 (or (and=> (getenv "GUIX_TESTS_RANDOM_SEED")
71 (logxor (getpid) (car (gettimeofday)))))
74 (let ((seed (random-seed)))
75 (format (current-error-port) "random seed for tests: ~a~%"
77 (seed->random-state seed)))
80 "Return the hexadecimal representation of a random number."
81 (number->string (random (expt 2 256) %seed) 16))
83 (define (random-bytevector n)
84 "Return a random bytevector of N bytes."
85 (let ((bv (make-bytevector n)))
89 (bytevector-u8-set! bv i (random 256 %seed))
94 "Return true if files A and B have the same type and same content."
95 (and (eq? (stat:type (lstat a)) (stat:type (lstat b)))
96 (case (stat:type (lstat a))
99 (call-with-input-file a get-bytevector-all)
100 (call-with-input-file b get-bytevector-all)))
102 (string=? (readlink a) (readlink b)))
104 (error "what?" (lstat a))))))
106 (define (network-reachable?)
107 "Return true if we can reach the Internet."
108 (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)))
110 (define-syntax-rule (mock (module proc replacement) body ...)
111 "Within BODY, replace the definition of PROC from MODULE with the definition
112 given by REPLACEMENT."
113 (let* ((m (resolve-module 'module))
114 (original (module-ref m 'proc)))
116 (lambda () (module-set! m 'proc replacement))
118 (lambda () (module-set! m 'proc original)))))
122 ;;; Narinfo files, as used by the substituter.
125 (define* (derivation-narinfo drv #:key (nar "example.nar")
126 (sha256 (make-bytevector 32 0)))
127 "Return the contents of the narinfo corresponding to DRV; NAR should be the
128 file name of the archive containing the substitute for DRV, and SHA256 is the
130 (format #f "StorePath: ~a
138 (derivation->output-path drv) ; StorePath
140 (bytevector->nix-base32-string sha256) ; NarHash
141 (derivation-system drv) ; System
143 (derivation-file-name drv)))) ; Deriver
145 (define %substitute-directory
147 (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
148 (compose uri-path string->uri))))
150 (define* (call-with-derivation-narinfo drv thunk
151 #:key (sha256 (make-bytevector 32 0)))
152 "Call THUNK in a context where fake substituter data, as read by 'guix
153 substitute', has been installed for DRV. SHA256 is the hash of the
154 expected output of DRV."
155 (let* ((output (derivation->output-path drv))
156 (dir (%substitute-directory))
157 (info (string-append dir "/nix-cache-info"))
158 (narinfo (string-append dir "/" (store-path-hash-part output)
162 (call-with-output-file info
164 (format p "StoreDir: ~a\nWantMassQuery: 0\n"
166 (call-with-output-file narinfo
168 (display (derivation-narinfo drv #:sha256 sha256) p))))
171 (delete-file narinfo)
172 (delete-file info)))))
174 (define-syntax with-derivation-narinfo
175 (syntax-rules (sha256 =>)
176 "Evaluate BODY in a context where DRV looks substitutable from the
177 substituter's viewpoint."
178 ((_ drv (sha256 => hash) body ...)
179 (call-with-derivation-narinfo drv
183 (call-with-derivation-narinfo drv
187 (define* (call-with-derivation-substitute drv contents thunk
189 "Call THUNK in a context where a substitute for DRV has been installed,
190 using CONTENTS, a string, as its contents. If SHA256 is true, use it as the
191 expected hash of the substitute; otherwise use the hash of the nar containing
193 (define dir (%substitute-directory))
196 (call-with-output-file (string-append dir "/example.out")
198 (display contents port)))
199 (call-with-output-file (string-append dir "/example.nar")
201 (write-file (string-append dir "/example.out") p))))
203 (let ((hash (call-with-input-file (string-append dir "/example.nar")
205 ;; Create fake substituter data, to be read by 'guix substitute'.
206 (call-with-derivation-narinfo drv
208 #:sha256 (or sha256 hash))))
210 (delete-file (string-append dir "/example.out"))
211 (delete-file (string-append dir "/example.nar")))))
213 (define (shebang-too-long?)
214 "Return true if the typical shebang in the current store would exceed
215 Linux's static limit---the BINPRM_BUF_SIZE constant, normally 128 characters
218 (string-append "#!" (%store-prefix) "/"
220 "-bootstrap-binaries-0/bin/bash\0"))
222 (> (string-length shebang) 128))
224 (define-syntax with-derivation-substitute
225 (syntax-rules (sha256 =>)
226 "Evaluate BODY in a context where DRV is substitutable with the given
228 ((_ drv contents (sha256 => hash) body ...)
229 (call-with-derivation-substitute drv contents
232 ((_ drv contents body ...)
233 (call-with-derivation-substitute drv contents
237 (define-syntax-rule (dummy-package name* extra-fields ...)
238 "Return a \"dummy\" package called NAME*, with all its compulsory fields
239 initialized with default values, and with EXTRA-FIELDS set as specified."
240 (package extra-fields ...
241 (name name*) (version "0") (source #f)
242 (build-system gnu-build-system)
243 (synopsis #f) (description #f)
244 (home-page #f) (license #f)))
246 (define-syntax-rule (dummy-origin extra-fields ...)
247 "Return a \"dummy\" origin, with all its compulsory fields initialized with
248 default values, and with EXTRA-FIELDS set as specified."
249 (origin extra-fields ...
250 (method #f) (uri "http://www.example.com")
251 (sha256 (base32 (make-string 52 #\x)))))
254 ;; eval: (put 'call-with-derivation-narinfo 'scheme-indent-function 1)
255 ;; eval: (put 'call-with-derivation-substitute 'scheme-indent-function 2)
258 ;;; tests.scm ends here