tests/challenge.scm

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