guix/upstream.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
   4 ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
   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 upstream)
  22   #:use-module (guix records)
  23   #:use-module (guix utils)
  24   #:use-module (guix discovery)
  25   #:use-module ((guix download)
  26                 #:select (download-to-store url-fetch))
  27   #:use-module (guix gnupg)
  28   #:use-module (guix packages)
  29   #:use-module (guix diagnostics)
  30   #:use-module (guix ui)
  31   #:use-module (guix base32)
  32   #:use-module (guix gexp)
  33   #:use-module (guix store)
  34   #:use-module ((guix derivations) #:select (built-derivations derivation->output-path))
  35   #:autoload   (gcrypt hash) (port-sha256)
  36   #:use-module (guix monads)
  37   #:use-module (srfi srfi-1)
  38   #:use-module (srfi srfi-9)
  39   #:use-module (srfi srfi-11)
  40   #:use-module (srfi srfi-26)
  41   #:use-module (srfi srfi-34)
  42   #:use-module (srfi srfi-35)
  43   #:use-module (rnrs bytevectors)
  44   #:use-module (ice-9 match)
  45   #:use-module (ice-9 regex)
  46   #:export (upstream-source
  47             upstream-source?
  48             upstream-source-package
  49             upstream-source-version
  50             upstream-source-urls
  51             upstream-source-signature-urls
  52             upstream-source-archive-types
  53             upstream-source-input-changes
  54
  55             url-predicate
  56             url-prefix-predicate
  57             coalesce-sources
  58
  59             upstream-updater
  60             upstream-updater?
  61             upstream-updater-name
  62             upstream-updater-description
  63             upstream-updater-predicate
  64             upstream-updater-latest
  65
  66             upstream-input-change?
  67             upstream-input-change-name
  68             upstream-input-change-type
  69             upstream-input-change-action
  70             changed-inputs
  71
  72             %updaters
  73             lookup-updater
  74
  75             download-tarball
  76             package-latest-release
  77             package-latest-release*
  78             package-update
  79             update-package-source))
  80
  81 ;;; Commentary:
  82 ;;;
  83 ;;; This module provides tools to represent and manipulate a upstream source
  84 ;;; code, and to auto-update package recipes.
  85 ;;;
  86 ;;; Code:
  87
  88 ;; Representation of upstream's source.  There can be several URLs--e.g.,
  89 ;; tar.gz, tar.gz, etc.  There can be correspond signature URLs, one per
  90 ;; source URL.
  91 (define-record-type* <upstream-source>
  92   upstream-source make-upstream-source
  93   upstream-source?
  94   (package        upstream-source-package)        ;string
  95   (version        upstream-source-version)        ;string
  96   (urls           upstream-source-urls)           ;list of strings
  97   (signature-urls upstream-source-signature-urls  ;#f | list of strings
  98                   (default #f))
  99   (input-changes  upstream-source-input-changes
 100                   (default '()) (thunked)))
 101
 102 ;; Representation of an upstream input change.
 103 (define-record-type* <upstream-input-change>
 104   upstream-input-change make-upstream-input-change
 105   upstream-input-change?
 106   (name    upstream-input-change-name)    ;string
 107   (type    upstream-input-change-type)    ;symbol: regular | native | propagated
 108   (action  upstream-input-change-action)) ;symbol: add | remove
 109
 110 (define (changed-inputs package package-sexp)
 111   "Return a list of input changes for PACKAGE based on the newly imported
 112 S-expression PACKAGE-SEXP."
 113   (match package-sexp
 114     ((and expr ('package fields ...))
 115      (let* ((input->name (match-lambda ((name pkg . out) name)))
 116             (new-regular
 117              (match expr
 118                ((path *** ('inputs
 119                            ('quasiquote ((label ('unquote sym)) ...)))) label)
 120                (_ '())))
 121             (new-native
 122              (match expr
 123                ((path *** ('native-inputs
 124                            ('quasiquote ((label ('unquote sym)) ...)))) label)
 125                (_ '())))
 126             (new-propagated
 127              (match expr
 128                ((path *** ('propagated-inputs
 129                            ('quasiquote ((label ('unquote sym)) ...)))) label)
 130                (_ '())))
 131             (current-regular
 132              (map input->name (package-inputs package)))
 133             (current-native
 134              (map input->name (package-native-inputs package)))
 135             (current-propagated
 136              (map input->name (package-propagated-inputs package))))
 137        (append-map
 138         (match-lambda
 139           ((action type names)
 140            (map (lambda (name)
 141                   (upstream-input-change
 142                    (name name)
 143                    (type type)
 144                    (action action)))
 145                 names)))
 146         `((add regular
 147            ,(lset-difference equal?
 148                              new-regular current-regular))
 149           (remove regular
 150            ,(lset-difference equal?
 151                              current-regular new-regular))
 152           (add native
 153            ,(lset-difference equal?
 154                              new-native current-native))
 155           (remove native
 156            ,(lset-difference equal?
 157                              current-native new-native))
 158           (add propagated
 159            ,(lset-difference equal?
 160                              new-propagated current-propagated))
 161           (remove propagated
 162            ,(lset-difference equal?
 163                              current-propagated new-propagated))))))
 164     (_ '())))
 165
 166 (define* (url-predicate matching-url?)
 167   "Return a predicate that returns true when passed a package whose source is
 168 an <origin> with the URL-FETCH method, and one of its URLs passes
 169 MATCHING-URL?."
 170   (lambda (package)
 171     (match (package-source package)
 172       ((? origin? origin)
 173        (and (eq? (origin-method origin) url-fetch)
 174             (match (origin-uri origin)
 175               ((? string? url)
 176                (matching-url? url))
 177               (((? string? urls) ...)
 178                (any matching-url? urls))
 179               (_
 180                #f))))
 181       (_ #f))))
 182
 183 (define (url-prefix-predicate prefix)
 184   "Return a predicate that returns true when passed a package where one of its
 185 source URLs starts with PREFIX."
 186   (url-predicate (cut string-prefix? prefix <>)))
 187
 188 (define (upstream-source-archive-types release)
 189   "Return the available types of archives for RELEASE---a list of strings such
 190 as \"gz\" or \"xz\"."
 191   (map file-extension (upstream-source-urls release)))
 192
 193 (define (coalesce-sources sources)
 194   "Coalesce the elements of SOURCES, a list of <upstream-source>, that
 195 correspond to the same version."
 196   (define (same-version? r1 r2)
 197     (string=? (upstream-source-version r1) (upstream-source-version r2)))
 198
 199   (define (release>? r1 r2)
 200     (version>? (upstream-source-version r1) (upstream-source-version r2)))
 201
 202   (fold (lambda (release result)
 203           (match result
 204             ((head . tail)
 205              (if (same-version? release head)
 206                  (cons (upstream-source
 207                         (inherit release)
 208                         (urls (append (upstream-source-urls release)
 209                                       (upstream-source-urls head)))
 210                         (signature-urls
 211                          (let ((one (upstream-source-signature-urls release))
 212                                (two (upstream-source-signature-urls head)))
 213                            (and one two (append one two)))))
 214                        tail)
 215                  (cons release result)))
 216             (()
 217              (list release))))
 218         '()
 219         (sort sources release>?)))
 220
 221 \f
 222 ;;;
 223 ;;; Auto-update.
 224 ;;;
 225
 226 (define-record-type* <upstream-updater>
 227   upstream-updater make-upstream-updater
 228   upstream-updater?
 229   (name        upstream-updater-name)
 230   (description upstream-updater-description)
 231   (pred        upstream-updater-predicate)
 232   (latest      upstream-updater-latest))
 233
 234 (define (importer-modules)
 235   "Return the list of importer modules."
 236   (cons (resolve-interface '(guix gnu-maintenance))
 237         (all-modules (map (lambda (entry)
 238                             `(,entry . "guix/import"))
 239                           %load-path)
 240                      #:warn warn-about-load-error)))
 241
 242 (define %updaters
 243   ;; The list of publically-known updaters.
 244   (delay (fold-module-public-variables (lambda (obj result)
 245                                          (if (upstream-updater? obj)
 246                                              (cons obj result)
 247                                              result))
 248                                        '()
 249                                        (importer-modules))))
 250
 251 ;; Tests need to mock this variable so mark it as "non-declarative".
 252 (set! %updaters %updaters)
 253
 254 (define* (lookup-updater package
 255                          #:optional (updaters (force %updaters)))
 256   "Return an updater among UPDATERS that matches PACKAGE, or #f if none of
 257 them matches."
 258   (find (match-lambda
 259           (($ <upstream-updater> name description pred latest)
 260            (pred package)))
 261         updaters))
 262
 263 (define* (package-latest-release package
 264                                  #:optional
 265                                  (updaters (force %updaters)))
 266   "Return an upstream source to update PACKAGE, a <package> object, or #f if
 267 none of UPDATERS matches PACKAGE.  When several updaters match PACKAGE, try
 268 them until one of them returns an upstream source.  It is the caller's
 269 responsibility to ensure that the returned source is newer than the current
 270 one."
 271   (any (match-lambda
 272          (($ <upstream-updater> name description pred latest)
 273           (and (pred package)
 274                (latest package))))
 275        updaters))
 276
 277 (define* (package-latest-release* package
 278                                   #:optional
 279                                   (updaters (force %updaters)))
 280   "Like 'package-latest-release', but ensure that the return source is newer
 281 than that of PACKAGE."
 282   (match (package-latest-release package updaters)
 283     ((and source ($ <upstream-source> name version))
 284      (and (version>? version (package-version package))
 285           source))
 286     (_
 287      #f)))
 288
 289 (define (uncompressed-tarball name tarball)
 290   "Return a derivation that decompresses TARBALL."
 291   (define (ref package)
 292     (module-ref (resolve-interface '(gnu packages compression))
 293                 package))
 294
 295   (define compressor
 296     (cond ((or (string-suffix? ".gz" tarball)
 297                (string-suffix? ".tgz" tarball))
 298            (file-append (ref 'gzip) "/bin/gzip"))
 299           ((string-suffix? ".bz2" tarball)
 300            (file-append (ref 'bzip2) "/bin/bzip2"))
 301           ((string-suffix? ".xz" tarball)
 302            (file-append (ref 'xz) "/bin/xz"))
 303           ((string-suffix? ".lz" tarball)
 304            (file-append (ref 'lzip) "/bin/lzip"))
 305           (else
 306            (error "unknown archive type" tarball))))
 307
 308   (gexp->derivation (file-sans-extension name)
 309                     #~(begin
 310                         (copy-file #+tarball #+name)
 311                         (and (zero? (system* #+compressor "-d" #+name))
 312                              (copy-file #+(file-sans-extension name)
 313                                         #$output)))))
 314
 315 (define* (download-tarball store url signature-url
 316                            #:key (key-download 'interactive))
 317   "Download the tarball at URL to the store; check its OpenPGP signature at
 318 SIGNATURE-URL, unless SIGNATURE-URL is false.  On success, return the tarball
 319 file name; return #f on failure (network failure or authentication failure).
 320 KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
 321 values: 'interactive' (default), 'always', and 'never'."
 322   (let ((tarball (download-to-store store url)))
 323     (if (not signature-url)
 324         tarball
 325         (let* ((sig  (download-to-store store signature-url))
 326
 327                ;; Sometimes we get a signature over the uncompressed tarball.
 328                ;; In that case, decompress the tarball in the store so that we
 329                ;; can check the signature.
 330                (data (if (string-prefix? (basename url)
 331                                          (basename signature-url))
 332                          tarball
 333                          (run-with-store store
 334                            (mlet %store-monad ((drv (uncompressed-tarball
 335                                                      (basename url) tarball)))
 336                              (mbegin %store-monad
 337                                (built-derivations (list drv))
 338                                (return (derivation->output-path drv))))))))
 339           (let-values (((status data)
 340                         (if sig
 341                             (gnupg-verify* sig data
 342                                            #:key-download key-download)
 343                             (values 'missing-signature data))))
 344             (match status
 345               ('valid-signature
 346                tarball)
 347               ('missing-signature
 348                (warning (G_ "failed to download detached signature from ~a~%")
 349                         signature-url)
 350                #f)
 351               ('invalid-signature
 352                (warning (G_ "signature verification failed for '~a' (key: ~a)~%")
 353                         url data)
 354                #f)
 355               ('missing-key
 356                (warning (G_ "missing public key ~a for '~a'~%")
 357                         data url)
 358                #f)))))))
 359
 360 (define-gexp-compiler (upstream-source-compiler (source <upstream-source>)
 361                                                 system target)
 362   "Download SOURCE from its first URL and lower it as a fixed-output
 363 derivation that would fetch it."
 364   (mlet* %store-monad ((url -> (first (upstream-source-urls source)))
 365                        (signature
 366                         -> (and=> (upstream-source-signature-urls source)
 367                                   first))
 368                        (tarball ((store-lift download-tarball) url signature)))
 369     (unless tarball
 370       (raise (formatted-message (G_ "failed to fetch source from '~a'")
 371                                 url)))
 372
 373     ;; Instead of returning TARBALL, return a fixed-output derivation that
 374     ;; would be able to re-download it.  In practice, since TARBALL is already
 375     ;; in the store, no extra download will happen, but having the derivation
 376     ;; in store improves provenance tracking.
 377     (let ((hash (call-with-input-file tarball port-sha256)))
 378       (url-fetch url 'sha256 hash (store-path-package-name tarball)
 379                  #:system system))))
 380
 381 (define (find2 pred lst1 lst2)
 382   "Like 'find', but operate on items from both LST1 and LST2.  Return two
 383 values: the item from LST1 and the item from LST2 that match PRED."
 384   (let loop ((lst1 lst1) (lst2 lst2))
 385     (match lst1
 386       ((head1 . tail1)
 387        (match lst2
 388          ((head2 . tail2)
 389           (if (pred head1 head2)
 390               (values head1 head2)
 391               (loop tail1 tail2)))))
 392       (()
 393        (values #f #f)))))
 394
 395 (define* (package-update/url-fetch store package source
 396                                    #:key key-download)
 397   "Return the version, tarball, and SOURCE, to update PACKAGE to
 398 SOURCE, an <upstream-source>."
 399   (match source
 400     (($ <upstream-source> _ version urls signature-urls)
 401      (let*-values (((archive-type)
 402                     (match (and=> (package-source package) origin-uri)
 403                       ((? string? uri)
 404                        (let ((type (or (file-extension (basename uri)) "")))
 405                          ;; Sometimes we have URLs such as
 406                          ;; "https://github.com/…/tarball/v0.1", in which case
 407                          ;; we must not consider "1" as the extension.
 408                          (and (or (string-contains type "z")
 409                                   (string=? type "tar"))
 410                               type)))
 411                       (_
 412                        "gz")))
 413                    ((url signature-url)
 414                     ;; Try to find a URL that matches ARCHIVE-TYPE.
 415                     (find2 (lambda (url sig-url)
 416                              ;; Some URIs lack a file extension, like
 417                              ;; 'https://crates.io/???/0.1/download'.  In that
 418                              ;; case, pick the first URL.
 419                              (or (not archive-type)
 420                                  (string-suffix? archive-type url)))
 421                            urls
 422                            (or signature-urls (circular-list #f)))))
 423        ;; If none of URLS matches ARCHIVE-TYPE, then URL is #f; in that case,
 424        ;; pick up the first element of URLS.
 425        (let ((tarball (download-tarball store
 426                                         (or url (first urls))
 427                                         (and (pair? signature-urls)
 428                                              (or signature-url
 429                                                  (first signature-urls)))
 430                                         #:key-download key-download)))
 431          (values version tarball source))))))
 432
 433 (define %method-updates
 434   ;; Mapping of origin methods to source update procedures.
 435   `((,url-fetch . ,package-update/url-fetch)))
 436
 437 (define* (package-update store package
 438                          #:optional (updaters (force %updaters))
 439                          #:key (key-download 'interactive))
 440   "Return the new version, the file name of the new version tarball, and input
 441 changes for PACKAGE; return #f (three values) when PACKAGE is up-to-date.
 442 KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
 443 values: 'always', 'never', and 'interactive' (default)."
 444   (match (package-latest-release* package updaters)
 445     ((? upstream-source? source)
 446      (let ((method (match (package-source package)
 447                      ((? origin? origin)
 448                       (origin-method origin))
 449                      (_
 450                       #f))))
 451        (match (assq method %method-updates)
 452          (#f
 453           (raise (make-compound-condition
 454                   (formatted-message (G_ "cannot download for \
 455 this method: ~s")
 456                                      method)
 457                   (condition
 458                    (&error-location
 459                     (location (package-location package)))))))
 460          ((_ . update)
 461           (update store package source
 462                   #:key-download key-download)))))
 463     (#f
 464      (values #f #f #f))))
 465
 466 (define* (update-package-source package source hash)
 467   "Modify the source file that defines PACKAGE to refer to SOURCE, an
 468 <upstream-source> whose tarball has SHA256 HASH (a bytevector).  Return the
 469 new version string if an update was made, and #f otherwise."
 470   (define (update-expression expr replacements)
 471     ;; Apply REPLACEMENTS to package expression EXPR, a string.  REPLACEMENTS
 472     ;; must be a list of replacement pairs, either bytevectors or strings.
 473     (fold (lambda (replacement str)
 474             (match replacement
 475               (((? bytevector? old-bv) . (? bytevector? new-bv))
 476                (string-replace-substring
 477                 str
 478                 (bytevector->nix-base32-string old-bv)
 479                 (bytevector->nix-base32-string new-bv)))
 480               ((old . new)
 481                (string-replace-substring str old new))))
 482           expr
 483           replacements))
 484
 485   (let ((name        (package-name package))
 486         (version     (upstream-source-version source))
 487         (version-loc (package-field-location package 'version)))
 488     (if version-loc
 489         (let* ((loc         (package-location package))
 490                (old-version (package-version package))
 491                (old-hash    (content-hash-value
 492                              (origin-hash (package-source package))))
 493                (old-url     (match (origin-uri (package-source package))
 494                               ((? string? url) url)
 495                               (_ #f)))
 496                (new-url     (match (upstream-source-urls source)
 497                               ((first _ ...) first)))
 498                (file        (and=> (location-file loc)
 499                                    (cut search-path %load-path <>))))
 500           (if file
 501               ;; Be sure to use absolute filename.  Replace the URL directory
 502               ;; when OLD-URL is available; this is useful notably for
 503               ;; mirror://cpan/ URLs where the directory may change as a
 504               ;; function of the person who uploads the package.  Note that
 505               ;; package definitions usually concatenate fragments of the URL,
 506               ;; which is why we only attempt to replace a subset of the URL.
 507               (let ((properties (assq-set! (location->source-properties loc)
 508                                            'filename file))
 509                     (replacements `((,old-version . ,version)
 510                                     (,old-hash . ,hash)
 511                                     ,@(if (and old-url new-url)
 512                                           `((,(dirname old-url) .
 513                                              ,(dirname new-url)))
 514                                           '()))))
 515                 (and (edit-expression properties
 516                                       (cut update-expression <> replacements))
 517                      version))
 518               (begin
 519                 (warning (G_ "~a: could not locate source file")
 520                          (location-file loc))
 521                 #f)))
 522         (warning (package-location package)
 523                  (G_ "~a: no `version' field in source; skipping~%")
 524                  name))))
 525
 526 ;;; upstream.scm ends here