guix/narinfo.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
   4 ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (guix narinfo)
  22   #:use-module (guix pki)
  23   #:use-module (guix i18n)
  24   #:use-module (guix base32)
  25   #:use-module (guix base64)
  26   #:use-module (guix records)
  27   #:use-module (guix diagnostics)
  28   #:use-module (gcrypt hash)
  29   #:use-module (gcrypt pk-crypto)
  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 (ice-9 match)
  35   #:use-module (ice-9 binary-ports)
  36   #:use-module (web uri)
  37   #:export (narinfo-signature->canonical-sexp
  38
  39             narinfo?
  40             narinfo-path
  41             narinfo-uris
  42             narinfo-uri-base
  43             narinfo-compressions
  44             narinfo-file-hashes
  45             narinfo-file-sizes
  46             narinfo-hash
  47             narinfo-size
  48             narinfo-references
  49             narinfo-deriver
  50             narinfo-system
  51             narinfo-signature
  52             narinfo-contents
  53
  54             narinfo-hash-algorithm+value
  55
  56             narinfo-hash->sha256
  57             narinfo-best-uri
  58
  59             valid-narinfo?
  60
  61             read-narinfo
  62             write-narinfo
  63
  64             string->narinfo
  65             narinfo->string
  66
  67             equivalent-narinfo?))
  68
  69 (define-record-type <narinfo>
  70   (%make-narinfo path uri-base uris compressions file-sizes file-hashes
  71                  nar-hash nar-size references deriver system
  72                  signature contents)
  73   narinfo?
  74   (path         narinfo-path)
  75   (uri-base     narinfo-uri-base)        ;URI of the cache it originates from
  76   (uris         narinfo-uris)            ;list of strings
  77   (compressions narinfo-compressions)    ;list of strings
  78   (file-sizes   narinfo-file-sizes)      ;list of (integers | #f)
  79   (file-hashes  narinfo-file-hashes)
  80   (nar-hash     narinfo-hash)
  81   (nar-size     narinfo-size)
  82   (references   narinfo-references)
  83   (deriver      narinfo-deriver)
  84   (system       narinfo-system)
  85   (signature    narinfo-signature)      ; canonical sexp
  86   ;; The original contents of a narinfo file.  This field is needed because we
  87   ;; want to preserve the exact textual representation for verification purposes.
  88   ;; See <https://lists.gnu.org/archive/html/guix-devel/2014-02/msg00340.html>
  89   ;; for more information.
  90   (contents     narinfo-contents))
  91
  92 (define (narinfo-hash-algorithm+value narinfo)
  93   "Return two values: the hash algorithm used by NARINFO and its value as a
  94 bytevector."
  95   (match (string-tokenize (narinfo-hash narinfo)
  96                           (char-set-complement (char-set #\:)))
  97     ((algorithm base32)
  98      (values (lookup-hash-algorithm (string->symbol algorithm))
  99              (nix-base32-string->bytevector base32)))
 100     (_
 101      (raise (formatted-message
 102              (G_ "invalid narinfo hash: ~s") (narinfo-hash narinfo))))))
 103
 104 (define (narinfo-hash->sha256 hash)
 105   "If the string HASH denotes a sha256 hash, return it as a bytevector.
 106 Otherwise return #f."
 107   (and (string-prefix? "sha256:" hash)
 108        (nix-base32-string->bytevector (string-drop hash 7))))
 109
 110 (define (narinfo-signature->canonical-sexp str)
 111   "Return the value of a narinfo's 'Signature' field as a canonical sexp."
 112   (match (string-split str #\;)
 113     ((version host-name sig)
 114      (let ((maybe-number (string->number version)))
 115        (cond ((not (number? maybe-number))
 116               (leave (G_ "signature version must be a number: ~s~%")
 117                      version))
 118              ;; Currently, there are no other versions.
 119              ((not (= 1 maybe-number))
 120               (leave (G_ "unsupported signature version: ~a~%")
 121                      maybe-number))
 122              (else
 123               (let ((signature (utf8->string (base64-decode sig))))
 124                 (catch 'gcry-error
 125                   (lambda ()
 126                     (string->canonical-sexp signature))
 127                   (lambda (key proc err)
 128                     (leave (G_ "signature is not a valid \
 129 s-expression: ~s~%")
 130                            signature))))))))
 131     (x
 132      (leave (G_ "invalid format of the signature field: ~a~%") x))))
 133
 134 (define (narinfo-maker str cache-url)
 135   "Return a narinfo constructor for narinfos originating from CACHE-URL.  STR
 136 must contain the original contents of a narinfo file."
 137   (lambda (path urls compressions file-hashes file-sizes
 138                 nar-hash nar-size references deriver system
 139                 signature)
 140     "Return a new <narinfo> object."
 141     (define len (length urls))
 142     (%make-narinfo path cache-url
 143                    ;; Handle the case where URL is a relative URL.
 144                    (map (lambda (url)
 145                           (or (string->uri url)
 146                               (string->uri
 147                                (if (string-suffix? "/" cache-url)
 148                                    (string-append cache-url url)
 149                                    (string-append cache-url "/" url)))))
 150                         urls)
 151                    compressions
 152                    (match file-sizes
 153                      (()        (make-list len #f))
 154                      ((lst ...) (map string->number lst)))
 155                    (match file-hashes
 156                      (()        (make-list len #f))
 157                      ((lst ...) (map string->number lst)))
 158                    nar-hash
 159                    (and=> nar-size string->number)
 160                    (string-tokenize references)
 161                    (match deriver
 162                      ((or #f "") #f)
 163                      (_ deriver))
 164                    system
 165                    (false-if-exception
 166                     (and=> signature narinfo-signature->canonical-sexp))
 167                    str)))
 168
 169 (define fields->alist
 170   ;; The narinfo format is really just like recutils.
 171   recutils->alist)
 172
 173 (define* (read-narinfo port #:optional url
 174                        #:key size)
 175   "Read a narinfo from PORT.  If URL is true, it must be a string used to
 176 build full URIs from relative URIs found while reading PORT.  When SIZE is
 177 true, read at most SIZE bytes from PORT; otherwise, read as much as possible.
 178
 179 No authentication and authorization checks are performed here!"
 180   (let ((str (utf8->string (if size
 181                                (get-bytevector-n port size)
 182                                (get-bytevector-all port)))))
 183     (alist->record (call-with-input-string str fields->alist)
 184                    (narinfo-maker str url)
 185                    '("StorePath" "URL" "Compression"
 186                      "FileHash" "FileSize" "NarHash" "NarSize"
 187                      "References" "Deriver" "System"
 188                      "Signature")
 189                    '("URL" "Compression" "FileSize" "FileHash"))))
 190
 191 (define (narinfo-sha256 narinfo)
 192   "Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a
 193 'Signature' field."
 194   (define %mandatory-fields
 195     ;; List of fields that must be signed.  If they are not signed, the
 196     ;; narinfo is considered unsigned.
 197     '("StorePath" "NarHash" "References"))
 198
 199   (let ((contents (narinfo-contents narinfo)))
 200     (match (string-contains contents "Signature:")
 201       (#f #f)
 202       (index
 203        (let* ((above-signature (string-take contents index))
 204               (signed-fields (match (call-with-input-string above-signature
 205                                       fields->alist)
 206                                (((fields . values) ...) fields))))
 207          (and (every (cut member <> signed-fields) %mandatory-fields)
 208               (sha256 (string->utf8 above-signature))))))))
 209
 210 (define* (valid-narinfo? narinfo #:optional (acl (current-acl))
 211                          #:key verbose?)
 212   "Return #t if NARINFO's signature is not valid."
 213   (let ((hash      (narinfo-sha256 narinfo))
 214         (signature (narinfo-signature narinfo))
 215         (uri       (uri->string (first (narinfo-uris narinfo)))))
 216     (and hash signature
 217          (signature-case (signature hash acl)
 218            (valid-signature #t)
 219            (invalid-signature
 220             (when verbose?
 221               (format (current-error-port)
 222                       "invalid signature for substitute at '~a'~%"
 223                       uri))
 224             #f)
 225            (hash-mismatch
 226             (when verbose?
 227               (format (current-error-port)
 228                       "hash mismatch for substitute at '~a'~%"
 229                       uri))
 230             #f)
 231            (unauthorized-key
 232             (when verbose?
 233               (format (current-error-port)
 234                       "substitute at '~a' is signed by an \
 235 unauthorized party~%"
 236                       uri))
 237             #f)
 238            (corrupt-signature
 239             (when verbose?
 240               (format (current-error-port)
 241                       "corrupt signature for substitute at '~a'~%"
 242                       uri))
 243             #f)))))
 244
 245 (define (write-narinfo narinfo port)
 246   "Write NARINFO to PORT."
 247   (put-bytevector port (string->utf8 (narinfo-contents narinfo))))
 248
 249 (define (narinfo->string narinfo)
 250   "Return the external representation of NARINFO."
 251   (call-with-output-string (cut write-narinfo narinfo <>)))
 252
 253 (define (string->narinfo str cache-uri)
 254   "Return the narinfo represented by STR.  Assume CACHE-URI as the base URI of
 255 the cache STR originates form."
 256   (call-with-input-string str (cut read-narinfo <> cache-uri)))
 257
 258 (define (equivalent-narinfo? narinfo1 narinfo2)
 259   "Return true if NARINFO1 and NARINFO2 are equivalent--i.e., if they describe
 260 the same store item.  This ignores unnecessary metadata such as the Nar URL."
 261   (and (string=? (narinfo-hash narinfo1)
 262                  (narinfo-hash narinfo2))
 263
 264        ;; The following is not needed if all we want is to download a valid
 265        ;; nar, but it's necessary if we want valid narinfo.
 266        (string=? (narinfo-path narinfo1)
 267                  (narinfo-path narinfo2))
 268        (equal? (narinfo-references narinfo1)
 269                (narinfo-references narinfo2))
 270
 271        (= (narinfo-size narinfo1)
 272           (narinfo-size narinfo2))))
 273
 274 (define %compression-methods
 275   ;; Known compression methods and a thunk to determine whether they're
 276   ;; supported.  See 'decompressed-port' in (guix utils).
 277   `(("gzip"  . ,(const #t))
 278     ("lzip"  . ,(const #t))
 279     ("zstd"  . ,(lambda ()
 280                   (resolve-module '(zstd) #t #f #:ensure #f)))
 281     ("xz"    . ,(const #t))
 282     ("bzip2" . ,(const #t))
 283     ("none"  . ,(const #t))))
 284
 285 (define (supported-compression? compression)
 286   "Return true if COMPRESSION, a string, denotes a supported compression
 287 method."
 288   (match (assoc-ref %compression-methods compression)
 289     (#f         #f)
 290     (supported? (supported?))))
 291
 292 (define (compresses-better? compression1 compression2)
 293   "Return true if COMPRESSION1 generally compresses better than COMPRESSION2;
 294 this is a rough approximation."
 295   (match compression1
 296     ("none" #f)
 297     ("gzip" (string=? compression2 "none"))
 298     ("lzip" #t)
 299     (_      (or (string=? compression2 "none")
 300                 (string=? compression2 "gzip")))))
 301
 302 (define (decompresses-faster? compression1 compression2)
 303   "Return true if COMPRESSION1 generally has a higher decompression throughput
 304 than COMPRESSION2."
 305   (match compression1
 306     ("none" #t)
 307     ("zstd" #t)
 308     ("gzip" (string=? compression2 "lzip"))
 309     (_      #f)))
 310
 311 (define* (narinfo-best-uri narinfo #:key fast-decompression?)
 312   "Select the \"best\" URI to download NARINFO's nar, and return three values:
 313 the URI, its compression method (a string), and the compressed file size.
 314 When FAST-DECOMPRESSION? is true, prefer substitutes with faster
 315 decompression (typically zstd) rather than substitutes with a higher
 316 compression ratio (typically lzip)."
 317   (define choices
 318     (filter (match-lambda
 319               ((uri compression file-size)
 320                (supported-compression? compression)))
 321             (zip (narinfo-uris narinfo)
 322                  (narinfo-compressions narinfo)
 323                  (narinfo-file-sizes narinfo))))
 324
 325   (define (file-size<? c1 c2)
 326     (match c1
 327       ((uri1 compression1 (? integer? file-size1))
 328        (match c2
 329          ((uri2 compression2 (? integer? file-size2))
 330           (< file-size1 file-size2))
 331          (_ #t)))
 332       ((uri compression1 #f)
 333        (match c2
 334          ((uri2 compression2 _)
 335           (compresses-better? compression1 compression2))))
 336       (_ #f)))                                    ;we can't tell
 337
 338   (define (speed<? c1 c2)
 339     (match c1
 340       ((uri1 compression1 . _)
 341        (match c2
 342          ((uri2 compression2 . _)
 343           (decompresses-faster? compression2 compression1))))))
 344
 345   (match (sort choices (if fast-decompression? (negate speed<?) file-size<?))
 346     (((uri compression file-size) _ ...)
 347      (values uri compression file-size))))