guix/scripts/challenge.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015 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 monads)
  25   #:use-module (guix base32)
  26   #:use-module (guix packages)
  27   #:use-module (guix serialization)
  28   #:use-module (guix scripts substitute)
  29   #:use-module (rnrs bytevectors)
  30   #:use-module (srfi srfi-1)
  31   #:use-module (srfi srfi-9)
  32   #:use-module (srfi srfi-26)
  33   #:use-module (srfi srfi-34)
  34   #:use-module (srfi srfi-37)
  35   #:use-module (ice-9 match)
  36   #:use-module (ice-9 vlist)
  37   #:use-module (ice-9 format)
  38   #:use-module (web uri)
  39   #:export (discrepancies
  40
  41             discrepancy?
  42             discrepancy-item
  43             discrepancy-local-sha256
  44             discrepancy-narinfos
  45
  46             guix-challenge))
  47
  48 ;;; Commentary:
  49 ;;;
  50 ;;; Challenge substitute servers, checking whether they provide the same
  51 ;;; binaries as those built locally.
  52 ;;;
  53 ;;; Here we completely bypass the daemon to access substitutes.  This is
  54 ;;; because we want to be able to report fine-grain information about
  55 ;;; discrepancies: We need to show the URL of the offending nar, its hash, and
  56 ;;; so on.
  57 ;;;
  58 ;;; Code:
  59
  60 (define ensure-store-item                         ;XXX: move to (guix ui)?
  61   (@@ (guix scripts size) ensure-store-item))
  62
  63 ;; Representation of a hash mismatch for ITEM.
  64 (define-record-type <discrepancy>
  65   (discrepancy item local-sha256 narinfos)
  66   discrepancy?
  67   (item         discrepancy-item)                   ;string, /gnu/store/… item
  68   (local-sha256 discrepancy-local-sha256)           ;bytevector | #f
  69   (narinfos     discrepancy-narinfos))              ;list of <narinfo>
  70
  71 (define (locally-built? store item)
  72   "Return true if ITEM was built locally."
  73   ;; XXX: For now approximate it by checking whether there's a build log for
  74   ;; ITEM.  There could be false negatives, if logs have been removed.
  75   (->bool (log-file store item)))
  76
  77 (define (query-locally-built-hash item)
  78   "Return the hash of ITEM, a store item, if ITEM was built locally.
  79 Otherwise return #f."
  80   (lambda (store)
  81     (guard (c ((nix-protocol-error? c)
  82                (values #f store)))
  83       (if (locally-built? store item)
  84           (values (query-path-hash store item) store)
  85           (values #f store)))))
  86
  87 (define-syntax-rule (report args ...)
  88   (format (current-error-port) args ...))
  89
  90 (define (discrepancies items servers)
  91   "Challenge the substitute servers whose URLs are listed in SERVERS by
  92 comparing the hash of the substitutes of ITEMS that they serve.  Return the
  93 list of discrepancies.
  94
  95 This procedure does not authenticate narinfos from SERVERS, nor does it verify
  96 that they are signed by an authorized public keys.  The reason is that, by
  97 definition, we may want to target unknown servers.  Furthermore, no risk is
  98 taken since we do not import the archives."
  99   (define (compare item reference)
 100     ;; Return a procedure to compare the hash of ITEM with REFERENCE.
 101     (lambda (narinfo url)
 102       (if (not narinfo)
 103           (begin
 104             (warning (_ "~a: no substitute at '~a'~%")
 105                      item url)
 106             #t)
 107           (let ((value (narinfo-hash->sha256 (narinfo-hash narinfo))))
 108             (bytevector=? reference value)))))
 109
 110   (define (select-reference item narinfos urls)
 111     ;; Return a "reference" narinfo among NARINFOS.
 112     (match narinfos
 113       ((first narinfos ...)
 114        (match servers
 115          ((url urls ...)
 116           (if (not first)
 117               (select-reference item narinfos urls)
 118               (narinfo-hash->sha256 (narinfo-hash first))))))
 119       (()
 120        (leave (_ "no substitutes for '~a'~%") item))))
 121
 122   (mlet* %store-monad ((local     (mapm %store-monad
 123                                         query-locally-built-hash items))
 124                        (remote -> (append-map (cut lookup-narinfos <> items)
 125                                               servers))
 126                        ;; No 'assert-valid-narinfo' on purpose.
 127                        (narinfos -> (fold (lambda (narinfo vhash)
 128                                             (if narinfo
 129                                                 (vhash-cons (narinfo-path narinfo) narinfo
 130                                                             vhash)
 131                                                 vhash))
 132                                           vlist-null
 133                                           remote)))
 134     (return (filter-map (lambda (item local)
 135                           (let ((narinfos (vhash-fold* cons '() item narinfos)))
 136                             (define reference
 137                               (or local
 138                                   (begin
 139                                     (warning (_ "no local build for '~a'~%") item)
 140                                     (select-reference item narinfos servers))))
 141
 142                             (if (every (compare item reference)
 143                                        narinfos servers)
 144                                 #f
 145                                 (discrepancy item local narinfos))))
 146                         items
 147                         local))))
 148
 149 (define* (summarize-discrepancy discrepancy
 150                                 #:key (hash->string
 151                                        bytevector->nix-base32-string))
 152   "Write to the current error port a summary of DISCREPANCY, a <discrepancy>
 153 object that denotes a hash mismatch."
 154   (match discrepancy
 155     (($ <discrepancy> item local (narinfos ...))
 156      (report (_ "~a contents differ:~%") item)
 157      (if local
 158          (report (_ "  local hash: ~a~%") (hash->string local))
 159          (warning (_ "no local build for '~a'~%") item))
 160
 161      (for-each (lambda (narinfo)
 162                  (if narinfo
 163                      (report (_ "  ~50a: ~a~%")
 164                              (uri->string (narinfo-uri narinfo))
 165                              (hash->string
 166                               (narinfo-hash->sha256 (narinfo-hash narinfo))))
 167                      (report (_ "  ~50a: unavailable~%")
 168                              (uri->string (narinfo-uri narinfo)))))
 169                narinfos))))
 170
 171 \f
 172 ;;;
 173 ;;; Command-line options.
 174 ;;;
 175
 176 (define (show-help)
 177   (display (_ "Usage: guix challenge [PACKAGE...]
 178 Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
 179   (display (_ "
 180       --substitute-urls=URLS
 181                          compare build results with those at URLS"))
 182   (newline)
 183   (display (_ "
 184   -h, --help             display this help and exit"))
 185   (display (_ "
 186   -V, --version          display version information and exit"))
 187   (newline)
 188   (show-bug-report-information))
 189
 190 (define %options
 191   (list  (option '(#\h "help") #f #f
 192                  (lambda args
 193                    (show-help)
 194                    (exit 0)))
 195          (option '(#\V "version") #f #f
 196                  (lambda args
 197                    (show-version-and-exit "guix challenge")))
 198
 199          (option '("substitute-urls") #t #f
 200                  (lambda (opt name arg result . rest)
 201                    (apply values
 202                           (alist-cons 'substitute-urls
 203                                       (string-tokenize arg)
 204                                       (alist-delete 'substitute-urls result))
 205                           rest)))))
 206
 207 (define %default-options
 208   `((system . ,(%current-system))
 209     (substitute-urls . ,%default-substitute-urls)))
 210
 211 \f
 212 ;;;
 213 ;;; Entry point.
 214 ;;;
 215
 216 (define (guix-challenge . args)
 217   (with-error-handling
 218     (let* ((opts     (parse-command-line args %options (list %default-options)))
 219            (files    (filter-map (match-lambda
 220                                    (('argument . file) file)
 221                                    (_ #f))
 222                                  opts))
 223            (system   (assoc-ref opts 'system))
 224            (urls     (assoc-ref opts 'substitute-urls)))
 225       (leave-on-EPIPE
 226        (with-store store
 227          (let ((files (match files
 228                         (()
 229                          (filter (cut locally-built? store <>)
 230                                  (live-paths store)))
 231                         (x
 232                          files))))
 233            (set-build-options store
 234                               #:use-substitutes? #f)
 235
 236            (run-with-store store
 237              (mlet* %store-monad ((items  (mapm %store-monad
 238                                                ensure-store-item files))
 239                                   (issues (discrepancies items urls)))
 240                (for-each summarize-discrepancy issues)
 241                (return (null? issues)))
 242              #:system system)))))))
 243
 244 ;;; challenge.scm ends here