guix/scripts/challenge.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015, 2016, 2017 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 ((nix-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 (narinfo-uri 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 \f
 214 ;;;
 215 ;;; Command-line options.
 216 ;;;
 217
 218 (define (show-help)
 219   (display (G_ "Usage: guix challenge [PACKAGE...]
 220 Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
 221   (display (G_ "
 222       --substitute-urls=URLS
 223                          compare build results with those at URLS"))
 224   (display (G_ "
 225       -v, --verbose      show details about successful comparisons"))
 226   (newline)
 227   (display (G_ "
 228   -h, --help             display this help and exit"))
 229   (display (G_ "
 230   -V, --version          display version information and exit"))
 231   (newline)
 232   (show-bug-report-information))
 233
 234 (define %options
 235   (list  (option '(#\h "help") #f #f
 236                  (lambda args
 237                    (show-help)
 238                    (exit 0)))
 239          (option '(#\V "version") #f #f
 240                  (lambda args
 241                    (show-version-and-exit "guix challenge")))
 242
 243          (option '("substitute-urls") #t #f
 244                  (lambda (opt name arg result . rest)
 245                    (apply values
 246                           (alist-cons 'substitute-urls
 247                                       (string-tokenize arg)
 248                                       (alist-delete 'substitute-urls result))
 249                           rest)))
 250          (option '("verbose" #\v) #f #f
 251                  (lambda (opt name arg result . rest)
 252                    (apply values
 253                           (alist-cons 'verbose? #t result)
 254                           rest)))))
 255
 256 (define %default-options
 257   `((system . ,(%current-system))
 258     (substitute-urls . ,%default-substitute-urls)))
 259
 260 \f
 261 ;;;
 262 ;;; Entry point.
 263 ;;;
 264
 265 (define (guix-challenge . args)
 266   (with-error-handling
 267     (let* ((opts     (parse-command-line args %options (list %default-options)))
 268            (files    (filter-map (match-lambda
 269                                    (('argument . file) file)
 270                                    (_ #f))
 271                                  opts))
 272            (system   (assoc-ref opts 'system))
 273            (urls     (assoc-ref opts 'substitute-urls))
 274            (verbose? (assoc-ref opts 'verbose?)))
 275       (leave-on-EPIPE
 276        (with-store store
 277          ;; Disable grafts since substitute servers normally provide only
 278          ;; ungrafted stuff.
 279          (parameterize ((%graft? #f))
 280            (let ((files (match files
 281                           (()
 282                            (filter (cut locally-built? store <>)
 283                                    (live-paths store)))
 284                           (x
 285                            files))))
 286              (set-build-options store
 287                                 #:use-substitutes? #f)
 288
 289              (run-with-store store
 290                (mlet* %store-monad ((items   (mapm %store-monad
 291                                                    ensure-store-item files))
 292                                     (reports (compare-contents items urls)))
 293                  (for-each (cut summarize-report <> #:verbose? verbose?)
 294                            reports)
 295
 296                  (exit (cond ((any comparison-report-mismatch? reports) 2)
 297                              ((every comparison-report-match? reports) 0)
 298                              (else 1))))
 299                #:system system))))))))
 300
 301 ;;; challenge.scm ends here