projects/guix·blob javascript-team · refs

241 lines · 10.5 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2015, 2017, 2019, 2020 Ludovic Courtès <[email protected]>
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-challenge)
20 #:use-module (guix tests)
21 #:use-module (guix tests http)
22 #:use-module ((gcrypt hash) #:prefix gcrypt:)
23 #:use-module (guix store)
24 #:use-module (guix monads)
25 #:use-module (guix derivations)
26 #:use-module (guix serialization)
27 #:use-module (guix packages)
28 #:use-module (guix gexp)
29 #:use-module (guix base32)
30 #:use-module (guix narinfo)
31 #:use-module (guix scripts challenge)
32 #:use-module ((guix build utils) #:select (find-files))
33 #:use-module (gnu packages bootstrap)
34 #:use-module (srfi srfi-1)
35 #:use-module (srfi srfi-26)
36 #:use-module (srfi srfi-64)
37 #:use-module (rnrs bytevectors)
38 #:use-module (rnrs io ports)
39 #:use-module (ice-9 match))
40
41(define query-path-hash*
42 (store-lift query-path-hash))
43
44(define (query-path-size item)
45 (mlet %store-monad ((info (query-path-info* item)))
46 (return (path-info-nar-size info))))
47
48(define* (call-with-derivation-narinfo* drv thunk hash)
49 (lambda (store)
50 (with-derivation-narinfo drv (sha256 => hash)
51 (values (run-with-store store (thunk)) store))))
52
53(define-syntax with-derivation-narinfo*
54 (syntax-rules (sha256 =>)
55 ((_ drv (sha256 => hash) body ...)
56 (call-with-derivation-narinfo* drv
57 (lambda () body ...)
58 hash))))
59
60
61(test-begin "challenge")
62
63(test-assertm "no discrepancies"
64 (let ((text (random-text)))
65 (mlet* %store-monad ((drv (gexp->derivation "something"
66 #~(call-with-output-file
67 #$output
68 (lambda (port)
69 (display #$text port)))))
70 (out -> (derivation->output-path drv)))
71 (mbegin %store-monad
72 (built-derivations (list drv))
73 (mlet %store-monad ((hash (query-path-hash* out)))
74 (with-derivation-narinfo* drv (sha256 => hash)
75 (>>= (compare-contents (list out) (%test-substitute-urls))
76 (match-lambda
77 ((report)
78 (return
79 (and (string=? out (comparison-report-item report))
80 (bytevector=?
81 (comparison-report-local-sha256 report)
82 hash)
83 (comparison-report-match? report))))))))))))
84
85(test-assertm "one discrepancy"
86 (let ((text (random-text)))
87 (mlet* %store-monad ((drv (gexp->derivation "something"
88 #~(call-with-output-file
89 #$output
90 (lambda (port)
91 (display #$text port)))))
92 (out -> (derivation->output-path drv)))
93 (mbegin %store-monad
94 (built-derivations (list drv))
95 (mlet* %store-monad ((hash (query-path-hash* out))
96 (wrong-hash
97 -> (let* ((w (bytevector-copy hash))
98 (b (bytevector-u8-ref w 0)))
99 (bytevector-u8-set! w 0
100 (modulo (+ b 1) 128))
101 w)))
102 (with-derivation-narinfo* drv (sha256 => wrong-hash)
103 (>>= (compare-contents (list out) (%test-substitute-urls))
104 (match-lambda
105 ((report)
106 (return
107 (and (string=? out (comparison-report-item (pk report)))
108 (eq? 'mismatch (comparison-report-result report))
109 (bytevector=? hash
110 (comparison-report-local-sha256
111 report))
112 (match (comparison-report-narinfos report)
113 ((bad)
114 (bytevector=? wrong-hash
115 (narinfo-hash->sha256
116 (narinfo-hash bad))))))))))))))))
117
118(test-assertm "inconclusive: no substitutes"
119 (mlet* %store-monad ((drv (gexp->derivation "foo" #~(mkdir #$output)))
120 (out -> (derivation->output-path drv))
121 (_ (built-derivations (list drv)))
122 (hash (query-path-hash* out)))
123 (>>= (compare-contents (list out) (%test-substitute-urls))
124 (match-lambda
125 ((report)
126 (return
127 (and (string=? out (comparison-report-item report))
128 (comparison-report-inconclusive? report)
129 (null? (comparison-report-narinfos report))
130 (bytevector=? (comparison-report-local-sha256 report)
131 hash))))))))
132
133(test-assertm "inconclusive: no local build"
134 (let ((text (random-text)))
135 (mlet* %store-monad ((drv (gexp->derivation "something"
136 #~(list #$output #$text)))
137 (out -> (derivation->output-path drv))
138 (hash -> (gcrypt:sha256 #vu8())))
139 (with-derivation-narinfo* drv (sha256 => hash)
140 (>>= (compare-contents (list out) (%test-substitute-urls))
141 (match-lambda
142 ((report)
143 (return
144 (and (string=? out (comparison-report-item report))
145 (comparison-report-inconclusive? report)
146 (not (comparison-report-local-sha256 report))
147 (match (comparison-report-narinfos report)
148 ((narinfo)
149 (bytevector=? (narinfo-hash->sha256
150 (narinfo-hash narinfo))
151 hash))))))))))))
152(define (make-narinfo item size hash)
153 (format #f "StorePath: ~a
154Compression: none
155URL: nar/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
156NarSize: ~d
157NarHash: sha256:~a
158References: ~%" item size (bytevector->nix-base32-string hash)))
159
160(define (call-mismatch-test proc)
161 "Pass PROC a <comparison-report> for a mismatch and return its return
162value."
163
164 ;; Pretend we have two different results for the same store item, ITEM, with
165 ;; "/bin/guile" differing between the two nars.
166 (mlet* %store-monad
167 ((drv1 (package->derivation %bootstrap-guile))
168 (drv2 (gexp->derivation
169 "broken-guile"
170 (with-imported-modules '((guix build utils))
171 #~(begin
172 (use-modules (guix build utils))
173 (copy-recursively #$drv1 #$output)
174 (chmod (string-append #$output "/bin/guile")
175 #o755)
176 (call-with-output-file (string-append
177 #$output
178 "/bin/guile")
179 (lambda (port)
180 (display "corrupt!" port)))))))
181 (out1 -> (derivation->output-path drv1))
182 (out2 -> (derivation->output-path drv2))
183 (item -> (string-append (%store-prefix) "/"
184 (bytevector->nix-base32-string
185 (random-bytevector 20))
186 "-foo"
187 (number->string (current-time) 16))))
188 (mbegin %store-monad
189 (built-derivations (list drv1 drv2))
190 (mlet* %store-monad ((size1 (query-path-size out1))
191 (size2 (query-path-size out2))
192 (hash1 (query-path-hash* out1))
193 (hash2 (query-path-hash* out2))
194 (nar1 -> (call-with-bytevector-output-port
195 (lambda (port)
196 (write-file out1 port))))
197 (nar2 -> (call-with-bytevector-output-port
198 (lambda (port)
199 (write-file out2 port)))))
200 (parameterize ((%http-server-port 9000))
201 (with-http-server `((200 ,(make-narinfo item size1 hash1))
202 (200 ,nar1))
203 (parameterize ((%http-server-port 9001))
204 (with-http-server `((200 ,(make-narinfo item size2 hash2))
205 (200 ,nar2))
206 (mlet* %store-monad ((urls -> (list (%local-url 9000)
207 (%local-url 9001)))
208 (reports (compare-contents (list item)
209 urls)))
210 (pk 'report reports)
211 (return (proc (car reports))))))))))))
212
213(test-assertm "differing-files"
214 (call-mismatch-test
215 (lambda (report)
216 (equal? (differing-files report) '("/bin/guile")))))
217
218(test-assertm "call-with-mismatches"
219 (call-mismatch-test
220 (lambda (report)
221 (call-with-mismatches
222 report
223 (lambda (directory1 directory2)
224 (let* ((files1 (find-files directory1))
225 (files2 (find-files directory2))
226 (files (map (cute string-drop <> (string-length directory1))
227 files1)))
228 (and (equal? files
229 (map (cute string-drop <> (string-length directory2))
230 files2))
231 (equal? (remove (lambda (file)
232 (file=? (string-append directory1 "/" file)
233 (string-append directory2 "/" file)))
234 files)
235 '("/bin/guile")))))))))
236
237(test-end)
238
239;;; Local Variables:
240;;; eval: (put 'with-derivation-narinfo* 'scheme-indent-function 2)
241;;; End: