guix/scripts/challenge.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015, 2016, 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 (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 serialization)
  29   #:use-module (guix scripts substitute)
  30   #:use-module (rnrs bytevectors)
  31   #:use-module (srfi srfi-1)
  32   #:use-module (srfi srfi-9)
  33   #:use-module (srfi srfi-26)
  34   #:use-module (srfi srfi-34)
  35   #:use-module (srfi srfi-37)
  36   #:use-module (ice-9 match)
  37   #:use-module (ice-9 vlist)
  38   #:use-module (ice-9 format)
  39   #:use-module (web uri)
  40   #:export (compare-contents
  41
  42             comparison-report?
  43             comparison-report-item
  44             comparison-report-result
  45             comparison-report-local-sha256
  46             comparison-report-narinfos
  47
  48             comparison-report-match?
  49             comparison-report-mismatch?
  50             comparison-report-inconclusive?
  51
  52             guix-challenge))
  53
  54 ;;; Commentary:
  55 ;;;
  56 ;;; Challenge substitute servers, checking whether they provide the same
  57 ;;; binaries as those built locally.
  58 ;;;
  59 ;;; Here we completely bypass the daemon to access substitutes.  This is
  60 ;;; because we want to be able to report fine-grain information about
  61 ;;; discrepancies: We need to show the URL of the offending nar, its hash, and
  62 ;;; so on.
  63 ;;;
  64 ;;; Code:
  65
  66 (define ensure-store-item                         ;XXX: move to (guix ui)?
  67   (@@ (guix scripts size) ensure-store-item))
  68
  69 ;; Representation of a comparison report for ITEM.
  70 (define-record-type <comparison-report>
  71   (%comparison-report item result local-sha256 narinfos)
  72   comparison-report?
  73   (item         comparison-report-item)    ;string, /gnu/store/… item
  74   (result       comparison-report-result)  ;'match | 'mismatch | 'inconclusive
  75   (local-sha256 comparison-report-local-sha256)   ;bytevector | #f
  76   (narinfos     comparison-report-narinfos))      ;list of <narinfo>
  77
  78 (define-syntax comparison-report
  79   ;; Some sort of a an enum to make sure 'result' is correct.
  80   (syntax-rules (match mismatch inconclusive)
  81     ((_ item 'match rest ...)
  82      (%comparison-report item 'match rest ...))
  83     ((_ item 'mismatch rest ...)
  84      (%comparison-report item 'mismatch rest ...))
  85     ((_ item 'inconclusive rest ...)
  86      (%comparison-report item 'inconclusive rest ...))))
  87
  88 (define (comparison-report-predicate result)
  89   "Return a predicate that returns true when pass a REPORT that has RESULT."
  90   (lambda (report)
  91     (eq? (comparison-report-result report) result)))
  92
  93 (define comparison-report-mismatch?
  94   (comparison-report-predicate 'mismatch))
  95
  96 (define comparison-report-match?
  97   (comparison-report-predicate 'match))
  98
  99 (define comparison-report-inconclusive?
 100   (comparison-report-predicate 'inconclusive))
 101
 102 (define (locally-built? store item)
 103   "Return true if ITEM was built locally."
 104   ;; XXX: For now approximate it by checking whether there's a build log for
 105   ;; ITEM.  There could be false negatives, if logs have been removed.
 106   (->bool (log-file store item)))
 107
 108 (define (query-locally-built-hash item)
 109   "Return the hash of ITEM, a store item, if ITEM was built locally.
 110 Otherwise return #f."
 111   (lambda (store)
 112     (guard (c ((store-protocol-error? c)
 113                (values #f store)))
 114       (if (locally-built? store item)
 115           (values (query-path-hash store item) store)
 116           (values #f store)))))
 117
 118 (define-syntax-rule (report args ...)
 119   (format (current-error-port) args ...))
 120
 121 (define (compare-contents items servers)
 122   "Challenge the substitute servers whose URLs are listed in SERVERS by
 123 comparing the hash of the substitutes of ITEMS that they serve.  Return the
 124 list of <comparison-report> objects.
 125
 126 This procedure does not authenticate narinfos from SERVERS, nor does it verify
 127 that they are signed by an authorized public keys.  The reason is that, by
 128 definition, we may want to target unknown servers.  Furthermore, no risk is
 129 taken since we do not import the archives."
 130   (define (compare item reference)
 131     ;; Return a procedure to compare the hash of ITEM with REFERENCE.
 132     (lambda (narinfo url)
 133       (or (not narinfo)
 134           (let ((value (narinfo-hash->sha256 (narinfo-hash narinfo))))
 135             (bytevector=? reference value)))))
 136
 137   (define (select-reference item narinfos urls)
 138     ;; Return a "reference" narinfo among NARINFOS.
 139     (match narinfos
 140       ((first narinfos ...)
 141        (match servers
 142          ((url urls ...)
 143           (if (not first)
 144               (select-reference item narinfos urls)
 145               (narinfo-hash->sha256 (narinfo-hash first))))))))
 146
 147   (mlet* %store-monad ((local     (mapm %store-monad
 148                                         query-locally-built-hash items))
 149                        (remote -> (append-map (cut lookup-narinfos <> items)
 150                                               servers))
 151                        ;; No 'assert-valid-narinfo' on purpose.
 152                        (narinfos -> (fold (lambda (narinfo vhash)
 153                                             (vhash-cons (narinfo-path narinfo) narinfo
 154                                                         vhash))
 155                                           vlist-null
 156                                           remote)))
 157     (return (map (lambda (item local)
 158                    (match (vhash-fold* cons '() item narinfos)
 159                      (()                          ;no substitutes
 160                       (comparison-report item 'inconclusive local '()))
 161                      ((narinfo)
 162                       (if local
 163                           (if ((compare item local) narinfo (first servers))
 164                               (comparison-report item 'match
 165                                                  local (list narinfo))
 166                               (comparison-report item 'mismatch
 167                                                  local (list narinfo)))
 168                           (comparison-report item 'inconclusive
 169                                              local (list narinfo))))
 170                      ((narinfos ...)
 171                       (let ((reference
 172                              (or local (select-reference item narinfos
 173                                                          servers))))
 174                         (if (every (compare item reference) narinfos servers)
 175                             (comparison-report item 'match
 176                                                local narinfos)
 177                             (comparison-report item 'mismatch
 178                                                local narinfos))))))
 179                  items
 180                  local))))
 181
 182 (define* (summarize-report comparison-report
 183                            #:key
 184                            (hash->string bytevector->nix-base32-string)
 185                            verbose?)
 186   "Write to the current error port a summary of REPORT, a <comparison-report>
 187 object.  When VERBOSE?, display matches in addition to mismatches and
 188 inconclusive reports."
 189   (define (report-hashes item local narinfos)
 190     (if local
 191         (report (G_ "  local hash: ~a~%") (hash->string local))
 192         (report (G_ "  no local build for '~a'~%") item))
 193     (for-each (lambda (narinfo)
 194                 (report (G_ "  ~50a: ~a~%")
 195                         (uri->string (first (narinfo-uris narinfo)))
 196                         (hash->string
 197                          (narinfo-hash->sha256 (narinfo-hash narinfo)))))
 198               narinfos))
 199
 200   (match comparison-report
 201     (($ <comparison-report> item 'mismatch local (narinfos ...))
 202      (report (G_ "~a contents differ:~%") item)
 203      (report-hashes item local narinfos))
 204     (($ <comparison-report> item 'inconclusive #f narinfos)
 205      (warning (G_ "could not challenge '~a': no local build~%") item))
 206     (($ <comparison-report> item 'inconclusive locals ())
 207      (warning (G_ "could not challenge '~a': no substitutes~%") item))
 208     (($ <comparison-report> item 'match local (narinfos ...))
 209      (when verbose?
 210        (report (G_ "~a contents match:~%") item)
 211        (report-hashes item local narinfos)))))
 212
 213 (define (summarize-report-list reports)
 214   "Display the overall summary of REPORTS."
 215   (let ((total         (length reports))
 216         (inconclusive  (count comparison-report-inconclusive? reports))
 217         (matches       (count comparison-report-match? reports))
 218         (discrepancies (count comparison-report-mismatch? reports)))
 219     (report (G_ "~h store items were analyzed:~%") total)
 220     (report (G_ "  - ~h (~,1f%) were identical~%")
 221             matches (* 100. (/ matches total)))
 222     (report (G_ "  - ~h (~,1f%) differed~%")
 223             discrepancies (* 100. (/ discrepancies total)))
 224     (report (G_ "  - ~h (~,1f%) were inconclusive~%")
 225             inconclusive (* 100. (/ inconclusive total)))))
 226
 227 \f
 228 ;;;
 229 ;;; Command-line options.
 230 ;;;
 231
 232 (define (show-help)
 233   (display (G_ "Usage: guix challenge [PACKAGE...]
 234 Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
 235   (display (G_ "
 236       --substitute-urls=URLS
 237                          compare build results with those at URLS"))
 238   (display (G_ "
 239       -v, --verbose      show details about successful comparisons"))
 240   (newline)
 241   (display (G_ "
 242   -h, --help             display this help and exit"))
 243   (display (G_ "
 244   -V, --version          display version information and exit"))
 245   (newline)
 246   (show-bug-report-information))
 247
 248 (define %options
 249   (list  (option '(#\h "help") #f #f
 250                  (lambda args
 251                    (show-help)
 252                    (exit 0)))
 253          (option '(#\V "version") #f #f
 254                  (lambda args
 255                    (show-version-and-exit "guix challenge")))
 256
 257          (option '("substitute-urls") #t #f
 258                  (lambda (opt name arg result . rest)
 259                    (apply values
 260                           (alist-cons 'substitute-urls
 261                                       (string-tokenize arg)
 262                                       (alist-delete 'substitute-urls result))
 263                           rest)))
 264          (option '("verbose" #\v) #f #f
 265                  (lambda (opt name arg result . rest)
 266                    (apply values
 267                           (alist-cons 'verbose? #t result)
 268                           rest)))))
 269
 270 (define %default-options
 271   `((system . ,(%current-system))
 272     (substitute-urls . ,%default-substitute-urls)))
 273
 274 \f
 275 ;;;
 276 ;;; Entry point.
 277 ;;;
 278
 279 (define (guix-challenge . args)
 280   (with-error-handling
 281     (let* ((opts     (parse-command-line args %options (list %default-options)
 282                                          #:build-options? #f))
 283            (files    (filter-map (match-lambda
 284                                    (('argument . file) file)
 285                                    (_ #f))
 286                                  opts))
 287            (system   (assoc-ref opts 'system))
 288            (urls     (assoc-ref opts 'substitute-urls))
 289            (verbose? (assoc-ref opts 'verbose?)))
 290       (leave-on-EPIPE
 291        (with-store store
 292          ;; Disable grafts since substitute servers normally provide only
 293          ;; ungrafted stuff.
 294          (parameterize ((%graft? #f))
 295            (let ((files (match files
 296                           (()
 297                            (filter (cut locally-built? store <>)
 298                                    (live-paths store)))
 299                           (x
 300                            files))))
 301              (set-build-options store
 302                                 #:use-substitutes? #f)
 303
 304              (run-with-store store
 305                (mlet* %store-monad ((items   (mapm %store-monad
 306                                                    ensure-store-item files))
 307                                     (reports (compare-contents items urls)))
 308                  (for-each (cut summarize-report <> #:verbose? verbose?)
 309                            reports)
 310                  (report "\n")
 311                  (summarize-report-list reports)
 312
 313                  (exit (cond ((any comparison-report-mismatch? reports) 2)
 314                              ((every comparison-report-match? reports) 0)
 315                              (else 1))))
 316                #:system system))))))))
 317
 318 ;;; challenge.scm ends here