guix/upstream.scm

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