Commit | Line | Data |
---|---|---|
c1bc358f | 1 | ;;; GNU Guix --- Functional package management for GNU |
6eebbab5 | 2 | ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> |
c1bc358f LC |
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 (guix tests) | |
20 | #:use-module (guix store) | |
21 | #:use-module (guix derivations) | |
22 | #:use-module (guix packages) | |
6eebbab5 | 23 | #:use-module (guix base32) |
e6c8839c LC |
24 | #:use-module (guix serialization) |
25 | #:use-module (guix hash) | |
c1bc358f LC |
26 | #:use-module (gnu packages bootstrap) |
27 | #:use-module (srfi srfi-34) | |
28 | #:use-module (rnrs bytevectors) | |
e6740741 | 29 | #:use-module (web uri) |
c1bc358f LC |
30 | #:export (open-connection-for-tests |
31 | random-text | |
e6740741 | 32 | random-bytevector |
694b317c | 33 | mock |
e6c8839c | 34 | %substitute-directory |
8b385969 | 35 | with-derivation-narinfo |
e6c8839c | 36 | with-derivation-substitute |
8b385969 | 37 | dummy-package)) |
c1bc358f LC |
38 | |
39 | ;;; Commentary: | |
40 | ;;; | |
41 | ;;; This module provide shared infrastructure for the test suite. For | |
42 | ;;; internal use only. | |
43 | ;;; | |
44 | ;;; Code: | |
45 | ||
46 | (define (open-connection-for-tests) | |
47 | "Open a connection to the build daemon for tests purposes and return it." | |
48 | (guard (c ((nix-error? c) | |
49 | (format (current-error-port) | |
50 | "warning: build daemon error: ~s~%" c) | |
51 | #f)) | |
52 | (let ((store (open-connection))) | |
53 | ;; Make sure we build everything by ourselves. | |
54 | (set-build-options store #:use-substitutes? #f) | |
55 | ||
56 | ;; Use the bootstrap Guile when running tests, so we don't end up | |
57 | ;; building everything in the temporary test store. | |
58 | (%guile-for-build (package-derivation store %bootstrap-guile)) | |
59 | ||
60 | store))) | |
61 | ||
62 | (define %seed | |
63 | (seed->random-state (logxor (getpid) (car (gettimeofday))))) | |
64 | ||
65 | (define (random-text) | |
66 | "Return the hexadecimal representation of a random number." | |
67 | (number->string (random (expt 2 256) %seed) 16)) | |
68 | ||
69 | (define (random-bytevector n) | |
70 | "Return a random bytevector of N bytes." | |
71 | (let ((bv (make-bytevector n))) | |
72 | (let loop ((i 0)) | |
73 | (if (< i n) | |
74 | (begin | |
75 | (bytevector-u8-set! bv i (random 256 %seed)) | |
76 | (loop (1+ i))) | |
77 | bv)))) | |
78 | ||
694b317c EB |
79 | (define-syntax-rule (mock (module proc replacement) body ...) |
80 | "Within BODY, replace the definition of PROC from MODULE with the definition | |
81 | given by REPLACEMENT." | |
82 | (let* ((m (resolve-module 'module)) | |
83 | (original (module-ref m 'proc))) | |
84 | (dynamic-wind | |
85 | (lambda () (module-set! m 'proc replacement)) | |
86 | (lambda () body ...) | |
87 | (lambda () (module-set! m 'proc original))))) | |
88 | ||
e6740741 LC |
89 | \f |
90 | ;;; | |
91 | ;;; Narinfo files, as used by the substituter. | |
92 | ;;; | |
93 | ||
6eebbab5 LC |
94 | (define* (derivation-narinfo drv #:key (nar "example.nar") |
95 | (sha256 (make-bytevector 32 0))) | |
e6740741 | 96 | "Return the contents of the narinfo corresponding to DRV; NAR should be the |
6eebbab5 LC |
97 | file name of the archive containing the substitute for DRV, and SHA256 is the |
98 | expected hash." | |
e6740741 LC |
99 | (format #f "StorePath: ~a |
100 | URL: ~a | |
101 | Compression: none | |
102 | NarSize: 1234 | |
6eebbab5 | 103 | NarHash: sha256:~a |
e6740741 LC |
104 | References: |
105 | System: ~a | |
106 | Deriver: ~a~%" | |
107 | (derivation->output-path drv) ; StorePath | |
108 | nar ; URL | |
6eebbab5 | 109 | (bytevector->nix-base32-string sha256) ; NarHash |
e6740741 LC |
110 | (derivation-system drv) ; System |
111 | (basename | |
112 | (derivation-file-name drv)))) ; Deriver | |
113 | ||
e6c8839c LC |
114 | (define %substitute-directory |
115 | (make-parameter | |
116 | (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL") | |
117 | (compose uri-path string->uri)))) | |
118 | ||
6eebbab5 LC |
119 | (define* (call-with-derivation-narinfo drv thunk |
120 | #:key (sha256 (make-bytevector 32 0))) | |
e6740741 | 121 | "Call THUNK in a context where fake substituter data, as read by 'guix |
6eebbab5 LC |
122 | substitute-binary', has been installed for DRV. SHA256 is the hash of the |
123 | expected output of DRV." | |
e6740741 | 124 | (let* ((output (derivation->output-path drv)) |
e6c8839c | 125 | (dir (%substitute-directory)) |
e6740741 LC |
126 | (info (string-append dir "/nix-cache-info")) |
127 | (narinfo (string-append dir "/" (store-path-hash-part output) | |
128 | ".narinfo"))) | |
129 | (dynamic-wind | |
130 | (lambda () | |
131 | (call-with-output-file info | |
132 | (lambda (p) | |
133 | (format p "StoreDir: ~a\nWantMassQuery: 0\n" | |
134 | (%store-prefix)))) | |
135 | (call-with-output-file narinfo | |
136 | (lambda (p) | |
6eebbab5 | 137 | (display (derivation-narinfo drv #:sha256 sha256) p)))) |
e6740741 LC |
138 | thunk |
139 | (lambda () | |
140 | (delete-file narinfo) | |
141 | (delete-file info))))) | |
142 | ||
6eebbab5 LC |
143 | (define-syntax with-derivation-narinfo |
144 | (syntax-rules (sha256 =>) | |
145 | "Evaluate BODY in a context where DRV looks substitutable from the | |
e6740741 | 146 | substituter's viewpoint." |
6eebbab5 LC |
147 | ((_ drv (sha256 => hash) body ...) |
148 | (call-with-derivation-narinfo drv | |
149 | (lambda () body ...) | |
150 | #:sha256 hash)) | |
151 | ((_ drv body ...) | |
152 | (call-with-derivation-narinfo drv | |
153 | (lambda () | |
154 | body ...))))) | |
e6740741 | 155 | |
e6c8839c LC |
156 | (define* (call-with-derivation-substitute drv contents thunk |
157 | #:key sha256) | |
158 | "Call THUNK in a context where a substitute for DRV has been installed, | |
159 | using CONTENTS, a string, as its contents. If SHA256 is true, use it as the | |
160 | expected hash of the substitute; otherwise use the hash of the nar containing | |
161 | CONTENTS." | |
162 | (define dir (%substitute-directory)) | |
163 | (dynamic-wind | |
164 | (lambda () | |
165 | (call-with-output-file (string-append dir "/example.out") | |
166 | (lambda (port) | |
167 | (display contents port))) | |
168 | (call-with-output-file (string-append dir "/example.nar") | |
169 | (lambda (p) | |
170 | (write-file (string-append dir "/example.out") p)))) | |
171 | (lambda () | |
172 | (let ((hash (call-with-input-file (string-append dir "/example.nar") | |
173 | port-sha256))) | |
174 | ;; Create fake substituter data, to be read by `substitute-binary'. | |
175 | (call-with-derivation-narinfo drv | |
176 | thunk | |
177 | #:sha256 (or sha256 hash)))) | |
178 | (lambda () | |
179 | (delete-file (string-append dir "/example.out")) | |
180 | (delete-file (string-append dir "/example.nar"))))) | |
181 | ||
182 | (define-syntax with-derivation-substitute | |
183 | (syntax-rules (sha256 =>) | |
184 | "Evaluate BODY in a context where DRV is substitutable with the given | |
185 | CONTENTS." | |
186 | ((_ drv contents (sha256 => hash) body ...) | |
187 | (call-with-derivation-substitute drv contents | |
188 | (lambda () body ...) | |
189 | #:sha256 hash)) | |
190 | ((_ drv contents body ...) | |
191 | (call-with-derivation-substitute drv contents | |
192 | (lambda () | |
193 | body ...))))) | |
194 | ||
8b385969 LC |
195 | (define-syntax-rule (dummy-package name* extra-fields ...) |
196 | "Return a \"dummy\" package called NAME*, with all its compulsory fields | |
197 | initialized with default values, and with EXTRA-FIELDS set as specified." | |
198 | (package extra-fields ... | |
199 | (name name*) (version "0") (source #f) | |
200 | (build-system gnu-build-system) | |
201 | (synopsis #f) (description #f) | |
202 | (home-page #f) (license #f))) | |
203 | ||
e6740741 LC |
204 | ;; Local Variables: |
205 | ;; eval: (put 'call-with-derivation-narinfo 'scheme-indent-function 1) | |
e6c8839c | 206 | ;; eval: (put 'call-with-derivation-substitute 'scheme-indent-function 2) |
e6740741 LC |
207 | ;; End: |
208 | ||
c1bc358f | 209 | ;;; tests.scm ends here |