projects/guix·blob java-team · refs

1002 lines · 42.8 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2014 Nikita Karetnikov <[email protected]>
3;;; Copyright © 2014-2015, 2017-2019, 2021-2023, 2026 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-substitute)
21 #:use-module (guix scripts substitute)
22 #:use-module (guix narinfo)
23 #:use-module (guix base64)
24 #:use-module (gcrypt hash)
25 #:use-module (guix serialization)
26 #:use-module (gcrypt pk-crypto)
27 #:use-module (guix pki)
28 #:use-module (guix config)
29 #:use-module (guix base32)
30 #:use-module ((guix store) #:select (%store-prefix))
31 #:use-module ((guix ui) #:select (guix-warning-port))
32 #:use-module ((guix utils)
33 #:select (call-with-temporary-directory
34 call-with-compressed-output-port))
35 #:use-module ((guix build utils)
36 #:select (mkdir-p delete-file-recursively dump-port))
37 #:use-module (guix tests http)
38 #:use-module (rnrs bytevectors)
39 #:use-module (rnrs io ports)
40 #:use-module (web uri)
41 #:use-module (ice-9 match)
42 #:use-module (ice-9 regex)
43 #:use-module (ice-9 binary-ports)
44 #:use-module (srfi srfi-11)
45 #:use-module (srfi srfi-26)
46 #:use-module (srfi srfi-34)
47 #:use-module (srfi srfi-35)
48 #:use-module ((srfi srfi-64) #:hide (test-error)))
49
50(define-syntax-rule (test-quit name error-rx exp)
51 "Emit a test that passes when EXP throws to 'quit' with value 1, and when
52it writes to GUIX-WARNING-PORT a messages that matches ERROR-RX."
53 (test-equal name
54 '(1 #t)
55 (let ((error-output (open-output-string)))
56 (parameterize ((current-error-port error-output)
57 (guix-warning-port error-output))
58 (catch 'quit
59 (lambda ()
60 exp
61 #f)
62 (lambda (key value)
63 (list value
64 (let ((message (get-output-string error-output)))
65 (->bool (string-match error-rx message))))))))))
66
67(define (request-substitution item destination)
68 "Run 'guix substitute --substitute' to fetch ITEM to DESTINATION."
69 (false-if-exception (delete-file-recursively destination))
70 (with-input-from-string (string-append "substitute " item " "
71 destination "\n")
72 (lambda ()
73 (guix-substitute "--substitute"))))
74
75(define %public-key
76 ;; This key is known to be in the ACL by default.
77 (call-with-input-file (string-append %config-directory "/signing-key.pub")
78 (compose string->canonical-sexp get-string-all)))
79
80(define %private-key
81 (call-with-input-file (string-append %config-directory "/signing-key.sec")
82 (compose string->canonical-sexp get-string-all)))
83
84(define* (signature-body bv #:key (public-key %public-key))
85 "Return the signature of BV as the base64-encoded body of a narinfo's
86'Signature' field."
87 (base64-encode
88 (string->utf8
89 (canonical-sexp->string
90 (signature-sexp (bytevector->hash-data (sha256 bv)
91 #:key-type 'rsa)
92 %private-key
93 public-key)))))
94
95(define %wrong-public-key
96 (string->canonical-sexp "(public-key
97 (rsa
98 (n #00E05873AC2B168760343145918E954EE9AB73C026355693B192E01EE835261AA689E9EF46642E895BCD65C648524059FC450E4BA77A68F4C52D0E39EF0CC9359709AB6AAB153B63782201871325B0FDA19CB401CD99FD0C31A91CA9000AA90A77E82B89E036FB63BC1D3961207469B3B12468977148D376F8012BB12A4B11A8F1#)
99 (e #010001#)
100 )
101 )"))
102
103(define* (signature-field bv-or-str
104 #:key (version "1") (public-key %public-key))
105 "Return the 'Signature' field value of bytevector/string BV-OR-STR, using
106PUBLIC-KEY as the signature's principal, and using VERSION as the signature
107version identifier.."
108 (string-append version ";example.gnu.org;"
109 (signature-body (if (string? bv-or-str)
110 (string->utf8 bv-or-str)
111 bv-or-str)
112 #:public-key public-key)))
113
114
115
116(test-begin "substitute")
117
118(test-quit "not a number"
119 "signature version"
120 (narinfo-signature->canonical-sexp
121 (signature-field "foo" #:version "not a number")))
122
123(test-quit "wrong version number"
124 "unsupported.*version"
125 (narinfo-signature->canonical-sexp
126 (signature-field "foo" #:version "2")))
127
128(test-assert "valid narinfo-signature->canonical-sexp"
129 (canonical-sexp? (narinfo-signature->canonical-sexp (signature-field "foo"))))
130
131
132
133(define %main-substitute-directory
134 ;; The place where 'call-with-narinfo' stores its data by default.
135 (uri-path (string->uri (getenv "GUIX_BINARY_SUBSTITUTE_URL"))))
136
137(define %alternate-substitute-directory
138 ;; Another place.
139 (string-append (dirname %main-substitute-directory)
140 "/substituter-alt-data"))
141
142(define %unroutable-substitute-url
143 ;; Substitute URL with an unroutable server address, as per
144 ;; <https://www.rfc-editor.org/rfc/rfc5737>.
145 "http://203.0.113.1")
146
147(define (directory-nar-sha256 string)
148 "Compute the sha256 of the nar of a directory containing a single regular
149file named \"foo\" containing STRING."
150 (sha256 (call-with-output-bytevector
151 (lambda (port)
152 (let ((bv (string->utf8 string)))
153 (call-with-input-bytevector
154 bv
155 (lambda (contents)
156 (write-file-tree "root" port
157 #:file-type+size
158 (match-lambda
159 ("root"
160 (values 'directory #f))
161 ("root/foo"
162 (values 'regular
163 (bytevector-length
164 bv))))
165 #:file-port
166 (const contents)
167 #:directory-entries
168 (const '("foo"))))))))))
169
170(define (plain-file-nar-sha256 string)
171 (sha256 (call-with-output-bytevector
172 (lambda (port)
173 (let ((bv (string->utf8 string)))
174 (call-with-input-bytevector
175 bv
176 (lambda (contents)
177 (write-file-tree #t port
178 #:file-type+size
179 (lambda (_)
180 (values 'regular
181 (bytevector-length
182 bv)))
183 #:file-port
184 (const contents)))))))))
185
186(define %narinfo
187 ;; Skeleton of the narinfo used below.
188 (string-append "StorePath: " (%store-prefix)
189 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
190URL: example.nar
191Compression: none
192NarHash: sha256:" (bytevector->nix-base32-string
193 (plain-file-nar-sha256 "Substitutable data.")) "
194NarSize: 42
195References: aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-bar bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-baz
196Deriver: cccccccccccccccccccccccccccccccc-foo.drv
197System: mips64el-linux\n"))
198
199(define %narinfo/directory
200 (string-append "StorePath: " (%store-prefix)
201 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
202URL: example.nar
203Compression: none
204NarHash: sha256:" (bytevector->nix-base32-string
205 (directory-nar-sha256 "Substitutable data.")) "
206NarSize: 304
207References: aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-bar bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-baz
208Deriver: cccccccccccccccccccccccccccccccc-foo.drv
209System: mips64el-linux\n"))
210
211(define* (call-with-narinfo narinfo thunk
212 #:optional
213 (narinfo-directory %main-substitute-directory)
214 #:key directory?)
215 "Call THUNK in a context where the directory at URL is populated with
216a file for NARINFO."
217 (mkdir-p narinfo-directory)
218 (let ((cache-directory (string-append (getenv "XDG_CACHE_HOME")
219 "/guix/substitute/")))
220 (dynamic-wind
221 (lambda ()
222 (when (file-exists? cache-directory)
223 (delete-file-recursively cache-directory))
224 (call-with-output-file (string-append narinfo-directory
225 "/nix-cache-info")
226 (lambda (port)
227 (format port "StoreDir: ~a\nWantMassQuery: 0\n"
228 (%store-prefix))))
229 (call-with-output-file (string-append narinfo-directory "/"
230 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
231 ".narinfo")
232 (cut display narinfo <>))
233
234 ;; Prepare the nar.
235 (let ((out (string-append narinfo-directory "/example.out")))
236 (when (file-exists? out)
237 (delete-file-recursively out))
238 (if directory?
239 (begin
240 (mkdir out)
241 (call-with-output-file (string-append out "/foo")
242 (cut display "Substitutable data." <>)))
243 (call-with-output-file out
244 (cut display "Substitutable data." <>))))
245 (call-with-output-file
246 (string-append narinfo-directory "/example.nar")
247 (cute write-file
248 (string-append narinfo-directory "/example.out") <>))
249
250 (%allow-unauthenticated-substitutes? #f))
251 thunk
252 (lambda ()
253 (when (file-exists? cache-directory)
254 (delete-file-recursively cache-directory))))))
255
256(define-syntax-rule (with-narinfo narinfo body ...)
257 (call-with-narinfo narinfo (lambda () body ...)))
258
259(define-syntax-rule (with-narinfo* narinfo directory body ...)
260 (call-with-narinfo narinfo (lambda () body ...) directory))
261
262(define-syntax-rule (with-directory-narinfo narinfo body ...)
263 (call-with-narinfo narinfo (lambda () body ...) #:directory? #t))
264
265;; Transmit these options to 'guix substitute'.
266(substitute-urls (list (getenv "GUIX_BINARY_SUBSTITUTE_URL")))
267
268;; Never use file descriptor 4, unlike what happens when invoked by the
269;; daemon.
270(%reply-file-descriptor #f)
271
272(test-equal "file:// URI prohibited by default"
273 "not-found\n"
274 (with-output-to-string
275 (lambda ()
276 (%allow-unsafe-substitute-uris? #f)
277 (let ((narinfo %narinfo))
278 (with-narinfo (string-append narinfo "Signature: "
279 (signature-field narinfo) "\n")
280 (call-with-temporary-directory
281 (lambda (directory)
282 (with-input-from-string (string-append
283 "substitute " (%store-prefix)
284 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo "
285 directory "/shouldnotbewritten\n")
286 (lambda ()
287 (guix-substitute "--substitute"))))))))))
288
289;; Allow these for ease of testing for the rest of the tests
290(%allow-unsafe-substitute-uris? #t)
291
292
293(test-equal "query narinfo without signature"
294 "" ; not substitutable
295
296 (with-narinfo %narinfo
297 (string-trim-both
298 (with-output-to-string
299 (lambda ()
300 (with-input-from-string (string-append "have " (%store-prefix)
301 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
302 (lambda ()
303 (guix-substitute "--query"))))))))
304
305(test-equal "query narinfo with invalid hash"
306 ;; The hash in the signature differs from the hash of %NARINFO.
307 ""
308
309 (with-narinfo (string-append %narinfo "Signature: "
310 (signature-field "different body")
311 "\n")
312 (string-trim-both
313 (with-output-to-string
314 (lambda ()
315 (with-input-from-string (string-append "have " (%store-prefix)
316 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
317 (lambda ()
318 (guix-substitute "--query"))))))))
319
320(test-equal "query narinfo with signature over nothing"
321 ;; The signature is computed over the empty string, not over the important
322 ;; parts, so the narinfo must be ignored.
323 ""
324
325 (with-narinfo (string-append "Signature: " (signature-field "") "\n"
326 %narinfo "\n")
327 (string-trim-both
328 (with-output-to-string
329 (lambda ()
330 (with-input-from-string (string-append "have " (%store-prefix)
331 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
332 (lambda ()
333 (guix-substitute "--query"))))))))
334
335(test-equal "query narinfo with signature over irrelevant bits"
336 ;; The signature is valid but it does not cover the
337 ;; StorePath/NarHash/References tuple and is thus irrelevant; the narinfo
338 ;; must be ignored.
339 ""
340
341 (let ((prefix (string-append "StorePath: " (%store-prefix)
342 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
343URL: example.nar
344Compression: none\n")))
345 (with-narinfo (string-append prefix
346 "Signature: " (signature-field prefix) "
347NarHash: sha256:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
348NarSize: 42
349References: aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-bar bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-baz
350Deriver: cccccccccccccccccccccccccccccccc-foo.drv
351System: mips64el-linux\n")
352 (string-trim-both
353 (with-output-to-string
354 (lambda ()
355 (with-input-from-string (string-append "have " (%store-prefix)
356 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
357 (lambda ()
358 (guix-substitute "--query")))))))))
359
360(test-equal "query narinfo with signature over relevant subset"
361 ;; The signature covers the StorePath/NarHash/References tuple, so it is
362 ;; valid; it does not cover non-normative fields, which is fine.
363 (string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
364
365 (let ((prefix (string-append "StorePath: " (%store-prefix)
366 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
367NarHash: sha256:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
368References: aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-bar bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-baz\n")))
369 (with-narinfo (string-append prefix
370 "Signature: " (signature-field prefix) "
371URL: example.nar
372Compression: none
373NarSize: 42
374Deriver: aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo.drv")
375 (string-trim-both
376 (with-output-to-string
377 (lambda ()
378 (with-input-from-string (string-append "have " (%store-prefix)
379 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
380 (lambda ()
381 (guix-substitute "--query")))))))))
382
383(test-equal "query narinfo that contains invalid store path"
384 ;; The signature covers the StorePath/NarHash/References tuple, so it is
385 ;; valid, but the 'StorePath' field is invalid (contains forbidden
386 ;; characters).
387 ""
388
389 (let ((prefix (string-append "StorePath: " (%store-prefix)
390 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo/../../../etc/passwd
391NarHash: sha256:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
392References: bar baz\n")))
393 (with-narinfo (string-append prefix
394 "Signature: " (signature-field prefix) "
395URL: example.nar
396Compression: none
397NarSize: 42
398Deriver: foo.drv")
399 (string-trim-both
400 (with-output-to-string
401 (lambda ()
402 (with-input-from-string (string-append "have " (%store-prefix)
403 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
404 (lambda ()
405 (guix-substitute "--query")))))))))
406
407(test-equal "query narinfo that returns different store path"
408 ;; The narinfo is valid and authorized but its 'StorePath' field points to a
409 ;; different store item.
410 ""
411
412 (let ((prefix (string-append "StorePath: " (%store-prefix)
413 "/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-BAR
414NarHash: sha256:bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb
415References: bar baz\n")))
416 (with-narinfo (string-append prefix
417 "Signature: " (signature-field prefix) "
418URL: example.nar
419Compression: none
420NarSize: 42
421Deriver: foo.drv")
422 (string-trim-both
423 (with-output-to-string
424 (lambda ()
425 (with-input-from-string (string-append "have " (%store-prefix)
426 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
427 (lambda ()
428 (guix-substitute "--query")))))))))
429
430(test-equal "query narinfo signed with authorized key"
431 (string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
432
433 (with-narinfo (string-append %narinfo "Signature: "
434 (signature-field %narinfo)
435 "\n")
436 (string-trim-both
437 (with-output-to-string
438 (lambda ()
439 (with-input-from-string (string-append "have " (%store-prefix)
440 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
441 (lambda ()
442 (guix-substitute "--query"))))))))
443
444(test-equal "query narinfo signed with authorized key, unroutable URL first"
445 (string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
446
447 (with-narinfo (string-append %narinfo "Signature: "
448 (signature-field %narinfo)
449 "\n")
450 (string-trim-both
451 (with-output-to-string
452 (lambda ()
453 (with-input-from-string (string-append "have " (%store-prefix)
454 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
455 (lambda ()
456 (parameterize ((substitute-urls
457 (list %unroutable-substitute-url
458 (string-append "file://"
459 %main-substitute-directory))))
460 (guix-substitute "--query")))))))))
461
462(test-equal "query narinfo signed with unauthorized key"
463 "" ; not substitutable
464
465 (with-narinfo (string-append %narinfo "Signature: "
466 (signature-field
467 %narinfo
468 #:public-key %wrong-public-key)
469 "\n")
470 (string-trim-both
471 (with-output-to-string
472 (lambda ()
473 (with-input-from-string (string-append "have " (%store-prefix)
474 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
475 (lambda ()
476 (guix-substitute "--query"))))))))
477
478(test-quit "substitute, no signature"
479 "no valid substitute"
480 (with-narinfo %narinfo
481 (with-input-from-string (string-append "substitute "
482 (%store-prefix)
483 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo"
484 " foo\n")
485 (lambda ()
486 (guix-substitute "--substitute")))))
487
488(test-quit "substitute, invalid narinfo hash"
489 "no valid substitute"
490 ;; The hash in the signature differs from the hash of %NARINFO.
491 (with-narinfo (string-append %narinfo "Signature: "
492 (signature-field "different body")
493 "\n")
494 (with-input-from-string (string-append "substitute "
495 (%store-prefix)
496 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo"
497 " foo\n")
498 (lambda ()
499 (guix-substitute "--substitute")))))
500
501(test-equal "substitute, invalid hash"
502 (string-append "hash-mismatch sha256 "
503 (bytevector->nix-base32-string (sha256 #vu8())) " "
504 (let-values (((port get-hash)
505 (open-hash-port (hash-algorithm sha256)))
506 ((content)
507 "Substitutable data."))
508 (write-file-tree "foo" port
509 #:file-type+size
510 (lambda _
511 (values 'regular
512 (string-length content)))
513 #:file-port
514 (lambda _
515 (open-input-string content)))
516 (close-port port)
517 (bytevector->nix-base32-string (get-hash)))
518 "\n")
519
520 ;; Arrange so the actual data hash does not match the 'NarHash' field in the
521 ;; narinfo.
522 (with-output-to-string
523 (lambda ()
524 (let ((narinfo (string-append "StorePath: " (%store-prefix)
525 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-wrong-hash
526URL: example.nar
527Compression: none
528NarHash: sha256:" (bytevector->nix-base32-string (sha256 #vu8())) "
529NarSize: 42
530References:
531Deriver: aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo.drv
532System: mips64el-linux\n")))
533 (with-narinfo (string-append narinfo "Signature: "
534 (signature-field narinfo) "\n")
535 (call-with-temporary-directory
536 (lambda (directory)
537 (with-input-from-string (string-append
538 "substitute " (%store-prefix)
539 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-wrong-hash "
540 directory "/wrong-hash\n")
541 (lambda ()
542 (guix-substitute "--substitute"))))))))))
543
544(test-quit "substitute, unauthorized key"
545 "no valid substitute"
546 (with-narinfo (string-append %narinfo "Signature: "
547 (signature-field
548 %narinfo
549 #:public-key %wrong-public-key)
550 "\n")
551 (with-input-from-string (string-append "substitute "
552 (%store-prefix)
553 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo"
554 " foo\n")
555 (lambda ()
556 (guix-substitute "--substitute")))))
557
558(test-equal "substitute, authorized key"
559 '("Substitutable data." 1 #o444)
560 (with-narinfo (string-append %narinfo "Signature: "
561 (signature-field %narinfo))
562 (dynamic-wind
563 (const #t)
564 (lambda ()
565 (request-substitution (string-append (%store-prefix)
566 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
567 "substitute-retrieved")
568 (list (call-with-input-file "substitute-retrieved" get-string-all)
569 (stat:mtime (lstat "substitute-retrieved"))
570 (stat:perms (lstat "substitute-retrieved"))))
571 (lambda ()
572 (false-if-exception (delete-file "substitute-retrieved"))))))
573
574(test-equal "substitute, authorized key, directory"
575 '("Substitutable data." 1 #o555)
576 (with-directory-narinfo (string-append %narinfo/directory "Signature: "
577 (signature-field %narinfo/directory))
578 (dynamic-wind
579 (const #t)
580 (lambda ()
581 (request-substitution (string-append (%store-prefix)
582 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
583 "substitute-retrieved")
584 (list (call-with-input-file "substitute-retrieved/foo" get-string-all)
585 (stat:mtime (lstat "substitute-retrieved"))
586 (stat:perms (lstat "substitute-retrieved"))))
587 (lambda ()
588 ;; Needs to be writable to be deleted
589 (false-if-exception (chmod "substitute-retrieved" #o755))
590 (false-if-exception (delete-file-recursively "substitute-retrieved"))))))
591
592(test-equal "substitute, authorized key, first substitute URL is unroutable"
593 '("Substitutable data." 1 #o444)
594 (with-narinfo (string-append %narinfo "Signature: "
595 (signature-field %narinfo))
596 (dynamic-wind
597 (const #t)
598 (lambda ()
599 ;; Pick an unroutable URL as the first one. This shouldn't be a
600 ;; problem.
601 (parameterize ((substitute-urls
602 (list %unroutable-substitute-url
603 (string-append "file://"
604 %main-substitute-directory))))
605 (request-substitution (string-append (%store-prefix)
606 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
607 "substitute-retrieved")
608 (list (call-with-input-file "substitute-retrieved" get-string-all)
609 (stat:mtime (lstat "substitute-retrieved"))
610 (stat:perms (lstat "substitute-retrieved")))))
611 (lambda ()
612 (false-if-exception (delete-file "substitute-retrieved"))))))
613
614(test-equal "substitute, unauthorized narinfo comes first"
615 "Substitutable data."
616 (with-narinfo*
617 (string-append %narinfo "Signature: "
618 (signature-field
619 %narinfo
620 #:public-key %wrong-public-key))
621 %alternate-substitute-directory
622
623 (with-narinfo* (string-append %narinfo "Signature: "
624 (signature-field %narinfo))
625 %main-substitute-directory
626
627 (dynamic-wind
628 (const #t)
629 (lambda ()
630 ;; Remove this file so that the substitute can only be retrieved
631 ;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
632 (delete-file (string-append %main-substitute-directory
633 "/example.nar"))
634
635 (parameterize ((substitute-urls
636 (map (cut string-append "file://" <>)
637 (list %alternate-substitute-directory
638 %main-substitute-directory))))
639 (request-substitution (string-append (%store-prefix)
640 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
641 "substitute-retrieved"))
642 (call-with-input-file "substitute-retrieved" get-string-all))
643 (lambda ()
644 (false-if-exception (delete-file "substitute-retrieved")))))))
645
646(test-equal "substitute, unsigned narinfo comes first"
647 "Substitutable data."
648 (with-narinfo* %narinfo ;not signed!
649 %alternate-substitute-directory
650
651 (with-narinfo* (string-append %narinfo "Signature: "
652 (signature-field %narinfo))
653 %main-substitute-directory
654
655 (dynamic-wind
656 (const #t)
657 (lambda ()
658 ;; Remove this file so that the substitute can only be retrieved
659 ;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
660 (delete-file (string-append %main-substitute-directory
661 "/example.nar"))
662
663 (parameterize ((substitute-urls
664 (map (cut string-append "file://" <>)
665 (list %alternate-substitute-directory
666 %main-substitute-directory))))
667 (request-substitution (string-append (%store-prefix)
668 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
669 "substitute-retrieved"))
670 (call-with-input-file "substitute-retrieved" get-string-all))
671 (lambda ()
672 (false-if-exception (delete-file "substitute-retrieved")))))))
673
674(test-equal "substitute, first URL has narinfo but lacks nar, second URL unauthorized"
675 "Substitutable data."
676 (with-narinfo*
677 (string-append %narinfo "Signature: "
678 (signature-field
679 %narinfo
680 #:public-key %wrong-public-key))
681 %alternate-substitute-directory
682
683 (with-narinfo* (string-append %narinfo "Signature: "
684 (signature-field %narinfo))
685 %main-substitute-directory
686
687 (dynamic-wind
688 (const #t)
689 (lambda ()
690 ;; Remove this file so that the substitute can only be retrieved
691 ;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
692 (delete-file (string-append %main-substitute-directory
693 "/example.nar"))
694
695 (parameterize ((substitute-urls
696 (map (cut string-append "file://" <>)
697 (list %main-substitute-directory
698 %alternate-substitute-directory))))
699 (request-substitution (string-append (%store-prefix)
700 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
701 "substitute-retrieved"))
702 (call-with-input-file "substitute-retrieved" get-string-all))
703 (lambda ()
704 (false-if-exception (delete-file "substitute-retrieved")))))))
705
706(test-equal "substitute, first URL has narinfo but nar is 404, both URLs authorized"
707 "Substitutable data."
708 (with-narinfo*
709 (string-append %narinfo "Signature: "
710 (signature-field %narinfo))
711 %main-substitute-directory
712
713 (with-http-server `((200 ,(string-append %narinfo "Signature: "
714 (signature-field %narinfo)))
715 (404 "Sorry, nar is missing!"))
716 (dynamic-wind
717 (const #t)
718 (lambda ()
719 (parameterize ((substitute-urls
720 (list (%local-url)
721 (string-append "file://"
722 %main-substitute-directory))))
723 (request-substitution (string-append (%store-prefix)
724 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
725 "substitute-retrieved"))
726 (call-with-input-file "substitute-retrieved" get-string-all))
727 (lambda ()
728 (false-if-exception (delete-file "substitute-retrieved")))))))
729
730(test-equal "substitute, first URL has narinfo but nar is 404, one URL authorized"
731 "Substitutable data."
732 (with-narinfo*
733 (string-append %narinfo "Signature: "
734 (signature-field
735 %narinfo
736 #:public-key %wrong-public-key))
737 %main-substitute-directory
738
739 (with-http-server `((200 ,(string-append %narinfo "Signature: "
740 (signature-field
741 %narinfo
742 #:public-key %wrong-public-key)))
743 (404 "Sorry, nar is missing!"))
744 (let ((url1 (%local-url)))
745 (parameterize ((%http-server-port 0))
746 (with-http-server `((200 ,(string-append %narinfo "Signature: "
747 (signature-field %narinfo)))
748 (404 "Sorry, nar is missing!"))
749 (let ((url2 (%local-url)))
750 (dynamic-wind
751 (const #t)
752 (lambda ()
753 (parameterize ((substitute-urls
754 (list url1 url2
755 (string-append "file://"
756 %main-substitute-directory))))
757 (request-substitution (string-append (%store-prefix)
758 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
759 "substitute-retrieved"))
760 (call-with-input-file "substitute-retrieved" get-string-all))
761 (lambda ()
762 (false-if-exception (delete-file "substitute-retrieved")))))))))))
763
764(test-equal "substitute, preferred nar URL is 404, other is 200"
765 "Substitutable data."
766 (with-narinfo* (string-append %narinfo "Signature: " (signature-field %narinfo))
767 %main-substitute-directory
768
769 (define (compress input output compression)
770 (call-with-output-file output
771 (lambda (port)
772 (call-with-compressed-output-port compression port
773 (lambda (port)
774 (call-with-input-file input
775 (lambda (input)
776 (dump-port input port))))))))
777
778 ;; This test is dependent on which nar the substitute script picks to
779 ;; request first
780 (with-http-server `((200 ,(string-append %narinfo "Signature: "
781 (signature-field %narinfo)
782 "\n"
783 "URL: example.nar.lz\n"
784 "Compression: lzip\n"))
785 (404 "Sorry, nar.lz is missing!")
786 (200 ,(let ((nar (string-append
787 %main-substitute-directory
788 "/example.nar")))
789 (compress nar (string-append nar ".lz") 'lzip)
790 (call-with-input-file
791 (string-append nar ".lz")
792 get-bytevector-all))))
793 (dynamic-wind
794 (const #t)
795 (lambda ()
796 (parameterize ((substitute-urls (list (%local-url))))
797 (request-substitution (string-append (%store-prefix)
798 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
799 "substitute-retrieved"))
800 (call-with-input-file "substitute-retrieved" get-string-all))
801 (lambda ()
802 (false-if-exception (delete-file "substitute-retrieved")))))))
803
804(test-equal "substitute, previous partial download around"
805 "Substitutable data."
806 (with-narinfo* (string-append %narinfo "Signature: " (signature-field %narinfo))
807 %main-substitute-directory
808
809 (with-http-server `((200 ,(string-append %narinfo "Signature: "
810 (signature-field %narinfo)))
811 (200 ,(call-with-input-file
812 (string-append %main-substitute-directory
813 "/example.nar")
814 get-bytevector-all)))
815 (dynamic-wind
816 (const #t)
817 (lambda ()
818 (parameterize ((substitute-urls (list (%local-url))))
819 (mkdir-p "substitute-retrieved/a/b/c/d") ;add stale data
820 (request-substitution (string-append (%store-prefix)
821 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
822 "substitute-retrieved"))
823 (call-with-input-file "substitute-retrieved" get-string-all))
824 (lambda ()
825 (false-if-exception (delete-file "substitute-retrieved")))))))
826
827(test-equal "substitute, narinfo is available but nar is missing"
828 "not-found\n"
829 (let ((port (open-output-string)))
830 (parameterize ((current-output-port port))
831 (with-narinfo*
832 (string-append %narinfo "Signature: "
833 (signature-field
834 %narinfo
835 #:public-key %wrong-public-key))
836 %main-substitute-directory
837
838 (with-http-server `((200 ,(string-append %narinfo "Signature: "
839 (signature-field %narinfo)))
840 (404 "Sorry, nar is missing!"))
841 (parameterize ((substitute-urls
842 (list (%local-url)
843 (string-append "file://"
844 %main-substitute-directory))))
845 (delete-file (string-append %main-substitute-directory
846 "/example.nar"))
847 (request-substitution (string-append (%store-prefix)
848 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
849 "substitute-retrieved")
850 (and (not (file-exists? "substitute-retrieved"))
851 (get-output-string port))))))))
852
853(test-equal "substitute, first narinfo is unsigned and has wrong hash"
854 "Substitutable data."
855 (with-narinfo* (regexp-substitute #f
856 (string-match "NarHash: [[:graph:]]+"
857 %narinfo)
858 'pre
859 "NarHash: sha256:"
860 (bytevector->nix-base32-string
861 (make-bytevector 32))
862 'post)
863 %alternate-substitute-directory
864
865 (with-narinfo* (string-append %narinfo "Signature: "
866 (signature-field %narinfo))
867 %main-substitute-directory
868
869 (dynamic-wind
870 (const #t)
871 (lambda ()
872 ;; This time remove the file so that the substitute can only be
873 ;; retrieved from %MAIN-SUBSTITUTE-DIRECTORY.
874 (delete-file (string-append %alternate-substitute-directory
875 "/example.nar"))
876
877 (parameterize ((substitute-urls
878 (map (cut string-append "file://" <>)
879 (list %alternate-substitute-directory
880 %main-substitute-directory))))
881 (request-substitution (string-append (%store-prefix)
882 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
883 "substitute-retrieved"))
884 (call-with-input-file "substitute-retrieved" get-string-all))
885 (lambda ()
886 (false-if-exception (delete-file "substitute-retrieved")))))))
887
888(test-equal "substitute, first narinfo is unsigned and has wrong refs"
889 "Substitutable data."
890 (with-narinfo* (regexp-substitute #f
891 (string-match "References: ([^\n]+)\n"
892 %narinfo)
893 'pre "References: " 1
894 " wrong set of references\n"
895 'post)
896 %alternate-substitute-directory
897
898 (with-narinfo* (string-append %narinfo "Signature: "
899 (signature-field %narinfo))
900 %main-substitute-directory
901
902 (dynamic-wind
903 (const #t)
904 (lambda ()
905 ;; This time remove the file so that the substitute can only be
906 ;; retrieved from %MAIN-SUBSTITUTE-DIRECTORY.
907 (delete-file (string-append %alternate-substitute-directory
908 "/example.nar"))
909
910 (parameterize ((substitute-urls
911 (map (cut string-append "file://" <>)
912 (list %alternate-substitute-directory
913 %main-substitute-directory))))
914 (request-substitution (string-append (%store-prefix)
915 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
916 "substitute-retrieved"))
917 (call-with-input-file "substitute-retrieved" get-string-all))
918 (lambda ()
919 (false-if-exception (delete-file "substitute-retrieved")))))))
920
921(test-quit "substitute, two invalid narinfos"
922 "no valid substitute"
923 (with-narinfo* %narinfo ;not signed
924 %alternate-substitute-directory
925
926 (with-narinfo* (string-append %narinfo "Signature: " ;unauthorized
927 (signature-field
928 %narinfo
929 #:public-key %wrong-public-key))
930 %main-substitute-directory
931
932 (with-input-from-string (string-append "substitute "
933 (%store-prefix)
934 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo"
935 " substitute-retrieved\n")
936 (lambda ()
937 (guix-substitute "--substitute"))))))
938
939(test-equal "substitute, narinfo with several URLs"
940 "Substitutable data."
941 (let ((narinfo (string-append "StorePath: " (%store-prefix)
942 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
943URL: example.nar.gz
944Compression: gzip
945URL: example.nar.lz
946Compression: lzip
947URL: example.nar
948Compression: none
949NarHash: sha256:" (bytevector->nix-base32-string
950 (plain-file-nar-sha256 "Substitutable data.")) "
951NarSize: 42
952References: aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-bar bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-baz
953Deriver: cccccccccccccccccccccccccccccccc-foo.drv
954System: mips64el-linux\n")))
955 (with-narinfo (string-append narinfo "Signature: "
956 (signature-field narinfo))
957 (dynamic-wind
958 (const #t)
959 (lambda ()
960 (define (compress input output compression)
961 (call-with-output-file output
962 (lambda (port)
963 (call-with-compressed-output-port compression port
964 (lambda (port)
965 (call-with-input-file input
966 (lambda (input)
967 (dump-port input port))))))))
968
969 (let ((nar (string-append %main-substitute-directory
970 "/example.nar")))
971 (compress nar (string-append nar ".gz") 'gzip)
972 (compress nar (string-append nar ".lz") 'lzip))
973
974 (parameterize ((substitute-urls
975 (list (string-append "file://"
976 %main-substitute-directory))))
977 (request-substitution (string-append (%store-prefix)
978 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
979 "substitute-retrieved"))
980 (call-with-input-file "substitute-retrieved" get-string-all))
981 (lambda ()
982 (false-if-exception (delete-file "substitute-retrieved")))))))
983
984(test-quit "substitute, narinfo does not match requested store item"
985 "no valid substitute"
986 (with-http-server `((200 ,(string-append %narinfo "Signature: "
987 (signature-field %narinfo))))
988 (parameterize ((substitute-urls (list (%local-url))))
989 ;; Narinfo is valid, signed, and authorized but requested item is
990 ;; /bbb…-bar and narinfo is for /aaa…-foo.
991 (request-substitution (string-append (%store-prefix)
992 "/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-bar")
993 "substitute-retrieved")
994 #f)))
995
996(test-end "substitute")
997
998;;; Local Variables:
999;;; eval: (put 'with-narinfo 'scheme-indent-function 1)
1000;;; eval: (put 'with-narinfo* 'scheme-indent-function 2)
1001;;; eval: (put 'test-quit 'scheme-indent-function 2)
1002;;; End: