guix/scripts/challenge.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015, 2016, 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 (guix scripts challenge)
  20   #:use-module (guix ui)
  21   #:use-module (guix scripts)
  22   #:use-module (guix store)
  23   #:use-module (guix utils)
  24   #:use-module (guix grafts)
  25   #:use-module (guix monads)
  26   #:use-module (guix base32)
  27   #:use-module (guix packages)
  28   #:use-module ((guix progress) #:hide (dump-port*))
  29   #:use-module (guix serialization)
  30   #:use-module (guix scripts substitute)
  31   #:use-module (rnrs bytevectors)
  32   #:autoload   (guix http-client) (http-fetch)
  33   #:use-module ((guix build syscalls) #:select (terminal-columns))
  34   #:use-module (gcrypt hash)
  35   #:use-module (srfi srfi-1)
  36   #:use-module (srfi srfi-9)
  37   #:use-module (srfi srfi-11)
  38   #:use-module (srfi srfi-26)
  39   #:use-module (srfi srfi-34)
  40   #:use-module (srfi srfi-37)
  41   #:use-module (ice-9 match)
  42   #:use-module (ice-9 vlist)
  43   #:use-module (ice-9 format)
  44   #:use-module (ice-9 ftw)
  45   #:use-module (web uri)
  46   #:export (compare-contents
  47
  48             comparison-report?
  49             comparison-report-item
  50             comparison-report-result
  51             comparison-report-local-sha256
  52             comparison-report-narinfos
  53
  54             comparison-report-match?
  55             comparison-report-mismatch?
  56             comparison-report-inconclusive?
  57
  58             differing-files
  59             call-with-mismatches
  60
  61             guix-challenge))
  62
  63 ;;; Commentary:
  64 ;;;
  65 ;;; Challenge substitute servers, checking whether they provide the same
  66 ;;; binaries as those built locally.
  67 ;;;
  68 ;;; Here we completely bypass the daemon to access substitutes.  This is
  69 ;;; because we want to be able to report fine-grain information about
  70 ;;; discrepancies: We need to show the URL of the offending nar, its hash, and
  71 ;;; so on.
  72 ;;;
  73 ;;; Code:
  74
  75 (define ensure-store-item                         ;XXX: move to (guix ui)?
  76   (@@ (guix scripts size) ensure-store-item))
  77
  78 ;; Representation of a comparison report for ITEM.
  79 (define-record-type <comparison-report>
  80   (%comparison-report item result local-sha256 narinfos)
  81   comparison-report?
  82   (item         comparison-report-item)    ;string, /gnu/store/… item
  83   (result       comparison-report-result)  ;'match | 'mismatch | 'inconclusive
  84   (local-sha256 comparison-report-local-sha256)   ;bytevector | #f
  85   (narinfos     comparison-report-narinfos))      ;list of <narinfo>
  86
  87 (define-syntax comparison-report
  88   ;; Some sort of a an enum to make sure 'result' is correct.
  89   (syntax-rules (match mismatch inconclusive)
  90     ((_ item 'match rest ...)
  91      (%comparison-report item 'match rest ...))
  92     ((_ item 'mismatch rest ...)
  93      (%comparison-report item 'mismatch rest ...))
  94     ((_ item 'inconclusive rest ...)
  95      (%comparison-report item 'inconclusive rest ...))))
  96
  97 (define (comparison-report-predicate result)
  98   "Return a predicate that returns true when pass a REPORT that has RESULT."
  99   (lambda (report)
 100     (eq? (comparison-report-result report) result)))
 101
 102 (define comparison-report-mismatch?
 103   (comparison-report-predicate 'mismatch))
 104
 105 (define comparison-report-match?
 106   (comparison-report-predicate 'match))
 107
 108 (define comparison-report-inconclusive?
 109   (comparison-report-predicate 'inconclusive))
 110
 111 (define (locally-built? store item)
 112   "Return true if ITEM was built locally."
 113   ;; XXX: For now approximate it by checking whether there's a build log for
 114   ;; ITEM.  There could be false negatives, if logs have been removed.
 115   (->bool (log-file store item)))
 116
 117 (define (query-locally-built-hash item)
 118   "Return the hash of ITEM, a store item, if ITEM was built locally.
 119 Otherwise return #f."
 120   (lambda (store)
 121     (guard (c ((store-protocol-error? c)
 122                (values #f store)))
 123       (if (locally-built? store item)
 124           (values (query-path-hash store item) store)
 125           (values #f store)))))
 126
 127 (define-syntax-rule (report args ...)
 128   (format (current-error-port) args ...))
 129
 130 (define (compare-contents items servers)
 131   "Challenge the substitute servers whose URLs are listed in SERVERS by
 132 comparing the hash of the substitutes of ITEMS that they serve.  Return the
 133 list of <comparison-report> objects.
 134
 135 This procedure does not authenticate narinfos from SERVERS, nor does it verify
 136 that they are signed by an authorized public keys.  The reason is that, by
 137 definition, we may want to target unknown servers.  Furthermore, no risk is
 138 taken since we do not import the archives."
 139   (define (compare item reference)
 140     ;; Return a procedure to compare the hash of ITEM with REFERENCE.
 141     (lambda (narinfo url)
 142       (or (not narinfo)
 143           (let ((value (narinfo-hash->sha256 (narinfo-hash narinfo))))
 144             (bytevector=? reference value)))))
 145
 146   (define (select-reference item narinfos urls)
 147     ;; Return a "reference" narinfo among NARINFOS.
 148     (match narinfos
 149       ((first narinfos ...)
 150        (match servers
 151          ((url urls ...)
 152           (if (not first)
 153               (select-reference item narinfos urls)
 154               (narinfo-hash->sha256 (narinfo-hash first))))))))
 155
 156   (mlet* %store-monad ((local     (mapm %store-monad
 157                                         query-locally-built-hash items))
 158                        (remote -> (append-map (cut lookup-narinfos <> items)
 159                                               servers))
 160                        ;; No 'assert-valid-narinfo' on purpose.
 161                        (narinfos -> (fold (lambda (narinfo vhash)
 162                                             (vhash-cons (narinfo-path narinfo) narinfo
 163                                                         vhash))
 164                                           vlist-null
 165                                           remote)))
 166     (return (map (lambda (item local)
 167                    (match (vhash-fold* cons '() item narinfos)
 168                      (()                          ;no substitutes
 169                       (comparison-report item 'inconclusive local '()))
 170                      ((narinfo)
 171                       (if local
 172                           (if ((compare item local) narinfo (first servers))
 173                               (comparison-report item 'match
 174                                                  local (list narinfo))
 175                               (comparison-report item 'mismatch
 176                                                  local (list narinfo)))
 177                           (comparison-report item 'inconclusive
 178                                              local (list narinfo))))
 179                      ((narinfos ...)
 180                       (let ((reference
 181                              (or local (select-reference item narinfos
 182                                                          servers))))
 183                         (if (every (compare item reference) narinfos servers)
 184                             (comparison-report item 'match
 185                                                local narinfos)
 186                             (comparison-report item 'mismatch
 187                                                local narinfos))))))
 188                  items
 189                  local))))
 190
 191 \f
 192 ;;;
 193 ;;; Reporting.
 194 ;;;
 195
 196 (define (port-sha256* port size)
 197   ;; Like 'port-sha256', but limited to SIZE bytes.
 198   (let-values (((out get) (open-sha256-port)))
 199     (dump-port* port out size)
 200     (close-port out)
 201     (get)))
 202
 203 (define (archive-contents port)
 204   "Return a list representing the files contained in the nar read from PORT."
 205   (fold-archive (lambda (file type contents result)
 206                   (match type
 207                     ((or 'regular 'executable)
 208                      (match contents
 209                        ((port . size)
 210                         (cons `(,file ,type ,(port-sha256* port size))
 211                               result))))
 212                     ('directory result)
 213                     ('symlink
 214                      (cons `(,file ,type ,contents) result))))
 215                 '()
 216                 port
 217                 ""))
 218
 219 (define (store-item-contents item)
 220   "Return a list of files and contents for ITEM in the same format as
 221 'archive-contents'."
 222   (file-system-fold (const #t)                    ;enter?
 223                     (lambda (file stat result)    ;leaf
 224                       (define short
 225                         (string-drop file (string-length item)))
 226
 227                       (match (stat:type stat)
 228                         ('regular
 229                          (let ((size (stat:size stat))
 230                                (type (if (zero? (logand (stat:mode stat)
 231                                                         #o100))
 232                                          'regular
 233                                          'executable)))
 234                            (cons `(,short ,type
 235                                           ,(call-with-input-file file
 236                                              (cut port-sha256* <> size)))
 237                                  result)))
 238                         ('symlink
 239                          (cons `(,short symlink ,(readlink file))
 240                                result))))
 241                     (lambda (directory stat result) result)  ;down
 242                     (lambda (directory stat result) result)  ;up
 243                     (lambda (file stat result) result)       ;skip
 244                     (lambda (file stat errno result) result) ;error
 245                     '()
 246                     item
 247                     lstat))
 248
 249 (define (call-with-nar narinfo proc)
 250   "Call PROC with an input port from which it can read the nar pointed to by
 251 NARINFO."
 252   (let*-values (((uri compression size)
 253                  (narinfo-best-uri narinfo))
 254                 ((port response)
 255                  (http-fetch uri)))
 256     (define reporter
 257       (progress-reporter/file (narinfo-path narinfo) size
 258                               #:abbreviation (const (uri-host uri))))
 259
 260     (define result
 261       (call-with-decompressed-port (string->symbol compression)
 262           (progress-report-port reporter port)
 263         proc))
 264
 265     (close-port port)
 266     (erase-current-line (current-output-port))
 267     result))
 268
 269 (define (narinfo-contents narinfo)
 270   "Fetch the nar described by NARINFO and return a list representing the file
 271 it contains."
 272   (call-with-nar narinfo archive-contents))
 273
 274 (define (differing-files comparison-report)
 275   "Return a list of files that differ among the nars and possibly the local
 276 store item specified in COMPARISON-REPORT."
 277   (define contents
 278     (map narinfo-contents
 279          (comparison-report-narinfos comparison-report)))
 280
 281   (define local-contents
 282     (and (comparison-report-local-sha256 comparison-report)
 283          (store-item-contents (comparison-report-item comparison-report))))
 284
 285   (match (apply lset-difference equal?
 286                 (take (delete-duplicates
 287                        (if local-contents
 288                            (cons local-contents contents)
 289                            contents))
 290                       2))
 291     (((files _ ...) ...)
 292      files)))
 293
 294 (define (report-differing-files comparison-report)
 295   "Report differences among the nars and possibly the local store item
 296 specified in COMPARISON-REPORT."
 297   (match (differing-files comparison-report)
 298     (()
 299      #t)
 300     ((files ...)
 301      (format #t (N_ "  differing file:~%"
 302                     "  differing files:~%"
 303                     (length files)))
 304      (format #t     "~{    ~a~%~}" files))))
 305
 306 (define (call-with-mismatches comparison-report proc)
 307   "Call PROC with two directories containing the mismatching store items."
 308   (define local-hash
 309     (comparison-report-local-sha256 comparison-report))
 310
 311   (define narinfos
 312     (comparison-report-narinfos comparison-report))
 313
 314   (call-with-temporary-directory
 315    (lambda (directory1)
 316      (call-with-temporary-directory
 317       (lambda (directory2)
 318         (define narinfo1
 319           (if local-hash
 320               (find (lambda (narinfo)
 321                       (not (bytevector=? (narinfo-hash->sha256
 322                                           (narinfo-hash narinfo))
 323                                          local-hash)))
 324                     narinfos)
 325               (first (comparison-report-narinfos comparison-report))))
 326
 327         (define narinfo2
 328           (and (not local-hash)
 329                (find (lambda (narinfo)
 330                        (not (eq? narinfo narinfo1)))
 331                      narinfos)))
 332
 333         (rmdir directory1)
 334         (call-with-nar narinfo1 (cut restore-file <> directory1))
 335         (when narinfo2
 336           (rmdir directory2)
 337           (call-with-nar narinfo2 (cut restore-file <> directory2)))
 338         (proc directory1
 339               (if local-hash
 340                   (comparison-report-item comparison-report)
 341                   directory2)))))))
 342
 343 (define %diffoscope-command
 344   ;; Default external diff command.  Pass "--exclude-directory-metadata" so
 345   ;; that the mtime/ctime differences are ignored.
 346   '("diffoscope" "--exclude-directory-metadata=yes"))
 347
 348 (define* (report-differing-files/external comparison-report
 349                                           #:optional
 350                                           (command %diffoscope-command))
 351   "Run COMMAND to show the file-level differences for the mismatches in
 352 COMPARISON-REPORT."
 353   (call-with-mismatches comparison-report
 354                         (lambda (directory1 directory2)
 355                           (apply system*
 356                                  (append command
 357                                          (list directory1 directory2))))))
 358
 359 (define* (summarize-report comparison-report
 360                            #:key
 361                            (report-differences (const #f))
 362                            (hash->string bytevector->nix-base32-string)
 363                            verbose?)
 364   "Write to the current error port a summary of COMPARISON-REPORT, a
 365 <comparison-report> object.  When VERBOSE?, display matches in addition to
 366 mismatches and inconclusive reports.  Upon mismatch, call REPORT-DIFFERENCES
 367 with COMPARISON-REPORT."
 368   (define (report-hashes item local narinfos)
 369     (if local
 370         (report (G_ "  local hash: ~a~%") (hash->string local))
 371         (report (G_ "  no local build for '~a'~%") item))
 372     (for-each (lambda (narinfo)
 373                 (report (G_ "  ~50a: ~a~%")
 374                         (uri->string (narinfo-best-uri narinfo))
 375                         (hash->string
 376                          (narinfo-hash->sha256 (narinfo-hash narinfo)))))
 377               narinfos))
 378
 379   (match comparison-report
 380     (($ <comparison-report> item 'mismatch local (narinfos ...))
 381      (report (G_ "~a contents differ:~%") item)
 382      (report-hashes item local narinfos)
 383      (report-differences comparison-report))
 384     (($ <comparison-report> item 'inconclusive #f narinfos)
 385      (warning (G_ "could not challenge '~a': no local build~%") item))
 386     (($ <comparison-report> item 'inconclusive locals ())
 387      (warning (G_ "could not challenge '~a': no substitutes~%") item))
 388     (($ <comparison-report> item 'match local (narinfos ...))
 389      (when verbose?
 390        (report (G_ "~a contents match:~%") item)
 391        (report-hashes item local narinfos)))))
 392
 393 (define (summarize-report-list reports)
 394   "Display the overall summary of REPORTS."
 395   (let ((total         (length reports))
 396         (inconclusive  (count comparison-report-inconclusive? reports))
 397         (matches       (count comparison-report-match? reports))
 398         (discrepancies (count comparison-report-mismatch? reports)))
 399     (report (G_ "~h store items were analyzed:~%") total)
 400     (report (G_ "  - ~h (~,1f%) were identical~%")
 401             matches (* 100. (/ matches total)))
 402     (report (G_ "  - ~h (~,1f%) differed~%")
 403             discrepancies (* 100. (/ discrepancies total)))
 404     (report (G_ "  - ~h (~,1f%) were inconclusive~%")
 405             inconclusive (* 100. (/ inconclusive total)))))
 406
 407 \f
 408 ;;;
 409 ;;; Command-line options.
 410 ;;;
 411
 412 (define (show-help)
 413   (display (G_ "Usage: guix challenge [PACKAGE...]
 414 Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
 415   (display (G_ "
 416       --substitute-urls=URLS
 417                          compare build results with those at URLS"))
 418   (display (G_ "
 419   -v, --verbose          show details about successful comparisons"))
 420   (display (G_ "
 421       --diff=MODE        show differences according to MODE"))
 422   (newline)
 423   (display (G_ "
 424   -h, --help             display this help and exit"))
 425   (display (G_ "
 426   -V, --version          display version information and exit"))
 427   (newline)
 428   (show-bug-report-information))
 429
 430 (define %options
 431   (list  (option '(#\h "help") #f #f
 432                  (lambda args
 433                    (show-help)
 434                    (exit 0)))
 435          (option '(#\V "version") #f #f
 436                  (lambda args
 437                    (show-version-and-exit "guix challenge")))
 438
 439          (option '("diff") #t #f
 440                  (lambda (opt name arg result . rest)
 441                    (define mode
 442                      (match arg
 443                        ("none" (const #t))
 444                        ("simple" report-differing-files)
 445                        ("diffoscope" report-differing-files/external)
 446                        ((and (? (cut string-prefix? "/" <>)) command)
 447                         (cute report-differing-files/external <>
 448                               (string-tokenize command)))
 449                        (_ (leave (G_ "~a: unknown diff mode~%") arg))))
 450
 451                    (apply values
 452                           (alist-cons 'difference-report mode result)
 453                           rest)))
 454
 455          (option '("substitute-urls") #t #f
 456                  (lambda (opt name arg result . rest)
 457                    (apply values
 458                           (alist-cons 'substitute-urls
 459                                       (string-tokenize arg)
 460                                       (alist-delete 'substitute-urls result))
 461                           rest)))
 462          (option '("verbose" #\v) #f #f
 463                  (lambda (opt name arg result . rest)
 464                    (apply values
 465                           (alist-cons 'verbose? #t result)
 466                           rest)))))
 467
 468 (define %default-options
 469   `((system . ,(%current-system))
 470     (substitute-urls . ,%default-substitute-urls)
 471     (difference-report . ,report-differing-files)))
 472
 473 \f
 474 ;;;
 475 ;;; Entry point.
 476 ;;;
 477
 478 (define-command (guix-challenge . args)
 479   (category packaging)
 480   (synopsis "challenge substitute servers, comparing their binaries")
 481
 482   (with-error-handling
 483     (let* ((opts     (parse-command-line args %options (list %default-options)
 484                                          #:build-options? #f))
 485            (files    (filter-map (match-lambda
 486                                    (('argument . file) file)
 487                                    (_ #f))
 488                                  opts))
 489            (system   (assoc-ref opts 'system))
 490            (urls     (assoc-ref opts 'substitute-urls))
 491            (diff     (assoc-ref opts 'difference-report))
 492            (verbose? (assoc-ref opts 'verbose?)))
 493       (leave-on-EPIPE
 494        (with-store store
 495          ;; Disable grafts since substitute servers normally provide only
 496          ;; ungrafted stuff.
 497          (parameterize ((%graft? #f)
 498                         (current-terminal-columns (terminal-columns)))
 499            (let ((files (match files
 500                           (()
 501                            (filter (cut locally-built? store <>)
 502                                    (live-paths store)))
 503                           (x
 504                            files))))
 505              (set-build-options store
 506                                 #:use-substitutes? #f)
 507
 508              (run-with-store store
 509                (mlet* %store-monad ((items   (mapm %store-monad
 510                                                    ensure-store-item files))
 511                                     (reports (compare-contents items urls)))
 512                  (for-each (cut summarize-report <> #:verbose? verbose?
 513                                 #:report-differences diff)
 514                            reports)
 515                  (report "\n")
 516                  (summarize-report-list reports)
 517
 518                  (exit (cond ((any comparison-report-mismatch? reports) 2)
 519                              ((every comparison-report-match? reports) 0)
 520                              (else 1))))
 521                #:system system))))))))
 522
 523 ;;; challenge.scm ends here