| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2015, 2017, 2019, 2020 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-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 scripts challenge) |
| 31 | #:use-module (guix scripts substitute) |
| 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 | \f |
| 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 |
| 154 | Compression: none |
| 155 | URL: nar/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo |
| 156 | NarSize: ~d |
| 157 | NarHash: sha256:~a |
| 158 | References: ~%" 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 |
| 162 | value." |
| 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 32)) |
| 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: |