tests/challenge.scm

   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: