guix/upstream.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 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)
  35                 #:select (built-derivations derivation->output-path))
  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 (define (lookup-updater package updaters)
 252   "Return an updater among UPDATERS that matches PACKAGE, or #f if none of
 253 them matches."
 254   (find (match-lambda
 255           (($ <upstream-updater> name description pred latest)
 256            (pred package)))
 257         updaters))
 258
 259 (define (package-latest-release package updaters)
 260   "Return an upstream source to update PACKAGE, a <package> object, or #f if
 261 none of UPDATERS matches PACKAGE.  It is the caller's responsibility to ensure
 262 that the returned source is newer than the current one."
 263   (match (lookup-updater package updaters)
 264     ((? upstream-updater? updater)
 265      ((upstream-updater-latest updater) package))
 266     (_ #f)))
 267
 268 (define (package-latest-release* package updaters)
 269   "Like 'package-latest-release', but ensure that the return source is newer
 270 than that of PACKAGE."
 271   (match (package-latest-release package updaters)
 272     ((and source ($ <upstream-source> name version))
 273      (and (version>? version (package-version package))
 274           source))
 275     (_
 276      #f)))
 277
 278 (define (uncompressed-tarball name tarball)
 279   "Return a derivation that decompresses TARBALL."
 280   (define (ref package)
 281     (module-ref (resolve-interface '(gnu packages compression))
 282                 package))
 283
 284   (define compressor
 285     (cond ((or (string-suffix? ".gz" tarball)
 286                (string-suffix? ".tgz" tarball))
 287            (file-append (ref 'gzip) "/bin/gzip"))
 288           ((string-suffix? ".bz2" tarball)
 289            (file-append (ref 'bzip2) "/bin/bzip2"))
 290           ((string-suffix? ".xz" tarball)
 291            (file-append (ref 'xz) "/bin/xz"))
 292           ((string-suffix? ".lz" tarball)
 293            (file-append (ref 'lzip) "/bin/lzip"))
 294           (else
 295            (error "unknown archive type" tarball))))
 296
 297   (gexp->derivation (file-sans-extension name)
 298                     #~(begin
 299                         (copy-file #+tarball #+name)
 300                         (and (zero? (system* #+compressor "-d" #+name))
 301                              (copy-file #+(file-sans-extension name)
 302                                         #$output)))))
 303
 304 (define* (download-tarball store url signature-url
 305                            #:key (key-download 'interactive))
 306   "Download the tarball at URL to the store; check its OpenPGP signature at
 307 SIGNATURE-URL, unless SIGNATURE-URL is false.  On success, return the tarball
 308 file name; return #f on failure (network failure or authentication failure).
 309 KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
 310 values: 'interactive' (default), 'always', and 'never'."
 311   (let ((tarball (download-to-store store url)))
 312     (if (not signature-url)
 313         tarball
 314         (let* ((sig  (download-to-store store signature-url))
 315
 316                ;; Sometimes we get a signature over the uncompressed tarball.
 317                ;; In that case, decompress the tarball in the store so that we
 318                ;; can check the signature.
 319                (data (if (string-prefix? (basename url)
 320                                          (basename signature-url))
 321                          tarball
 322                          (run-with-store store
 323                            (mlet %store-monad ((drv (uncompressed-tarball
 324                                                      (basename url) tarball)))
 325                              (mbegin %store-monad
 326                                (built-derivations (list drv))
 327                                (return (derivation->output-path drv))))))))
 328           (let-values (((status data)
 329                         (if sig
 330                             (gnupg-verify* sig data
 331                                            #:key-download key-download)
 332                             (values 'missing-signature data))))
 333             (match status
 334               ('valid-signature
 335                tarball)
 336               ('missing-signature
 337                (warning (G_ "failed to download detached signature from ~a~%")
 338                         signature-url)
 339                #f)
 340               ('invalid-signature
 341                (warning (G_ "signature verification failed for '~a' (key: ~a)~%")
 342                         url data)
 343                #f)
 344               ('missing-key
 345                (warning (G_ "missing public key ~a for '~a'~%")
 346                         data url)
 347                #f)))))))
 348
 349 (define (find2 pred lst1 lst2)
 350   "Like 'find', but operate on items from both LST1 and LST2.  Return two
 351 values: the item from LST1 and the item from LST2 that match PRED."
 352   (let loop ((lst1 lst1) (lst2 lst2))
 353     (match lst1
 354       ((head1 . tail1)
 355        (match lst2
 356          ((head2 . tail2)
 357           (if (pred head1 head2)
 358               (values head1 head2)
 359               (loop tail1 tail2)))))
 360       (()
 361        (values #f #f)))))
 362
 363 (define* (package-update/url-fetch store package source
 364                                    #:key key-download)
 365   "Return the version, tarball, and SOURCE, to update PACKAGE to
 366 SOURCE, an <upstream-source>."
 367   (match source
 368     (($ <upstream-source> _ version urls signature-urls)
 369      (let*-values (((archive-type)
 370                     (match (and=> (package-source package) origin-uri)
 371                       ((? string? uri)
 372                        (let ((type (or (file-extension (basename uri)) "")))
 373                          ;; Sometimes we have URLs such as
 374                          ;; "https://github.com/…/tarball/v0.1", in which case
 375                          ;; we must not consider "1" as the extension.
 376                          (and (or (string-contains type "z")
 377                                   (string=? type "tar"))
 378                               type)))
 379                       (_
 380                        "gz")))
 381                    ((url signature-url)
 382                     ;; Try to find a URL that matches ARCHIVE-TYPE.
 383                     (find2 (lambda (url sig-url)
 384                              ;; Some URIs lack a file extension, like
 385                              ;; 'https://crates.io/???/0.1/download'.  In that
 386                              ;; case, pick the first URL.
 387                              (or (not archive-type)
 388                                  (string-suffix? archive-type url)))
 389                            urls
 390                            (or signature-urls (circular-list #f)))))
 391        ;; If none of URLS matches ARCHIVE-TYPE, then URL is #f; in that case,
 392        ;; pick up the first element of URLS.
 393        (let ((tarball (download-tarball store
 394                                         (or url (first urls))
 395                                         (and (pair? signature-urls)
 396                                              (or signature-url
 397                                                  (first signature-urls)))
 398                                         #:key-download key-download)))
 399          (values version tarball source))))))
 400
 401 (define %method-updates
 402   ;; Mapping of origin methods to source update procedures.
 403   `((,url-fetch . ,package-update/url-fetch)))
 404
 405 (define* (package-update store package updaters
 406                          #:key (key-download 'interactive))
 407   "Return the new version, the file name of the new version tarball, and input
 408 changes for PACKAGE; return #f (three values) when PACKAGE is up-to-date.
 409 KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
 410 values: 'always', 'never', and 'interactive' (default)."
 411   (match (package-latest-release* package updaters)
 412     ((? upstream-source? source)
 413      (let ((method (match (package-source package)
 414                      ((? origin? origin)
 415                       (origin-method origin))
 416                      (_
 417                       #f))))
 418        (match (assq method %method-updates)
 419          (#f
 420           (raise (make-compound-condition
 421                   (formatted-message (G_ "cannot download for \
 422 this method: ~s")
 423                                      method)
 424                   (condition
 425                    (&error-location
 426                     (location (package-location package)))))))
 427          ((_ . update)
 428           (update store package source
 429                   #:key-download key-download)))))
 430     (#f
 431      (values #f #f #f))))
 432
 433 (define* (update-package-source package source hash)
 434   "Modify the source file that defines PACKAGE to refer to SOURCE, an
 435 <upstream-source> whose tarball has SHA256 HASH (a bytevector).  Return the
 436 new version string if an update was made, and #f otherwise."
 437   (define (update-expression expr replacements)
 438     ;; Apply REPLACEMENTS to package expression EXPR, a string.  REPLACEMENTS
 439     ;; must be a list of replacement pairs, either bytevectors or strings.
 440     (fold (lambda (replacement str)
 441             (match replacement
 442               (((? bytevector? old-bv) . (? bytevector? new-bv))
 443                (string-replace-substring
 444                 str
 445                 (bytevector->nix-base32-string old-bv)
 446                 (bytevector->nix-base32-string new-bv)))
 447               ((old . new)
 448                (string-replace-substring str old new))))
 449           expr
 450           replacements))
 451
 452   (let ((name        (package-name package))
 453         (version     (upstream-source-version source))
 454         (version-loc (package-field-location package 'version)))
 455     (if version-loc
 456         (let* ((loc         (package-location package))
 457                (old-version (package-version package))
 458                (old-hash    (content-hash-value
 459                              (origin-hash (package-source package))))
 460                (old-url     (match (origin-uri (package-source package))
 461                               ((? string? url) url)
 462                               (_ #f)))
 463                (new-url     (match (upstream-source-urls source)
 464                               ((first _ ...) first)))
 465                (file        (and=> (location-file loc)
 466                                    (cut search-path %load-path <>))))
 467           (if file
 468               ;; Be sure to use absolute filename.  Replace the URL directory
 469               ;; when OLD-URL is available; this is useful notably for
 470               ;; mirror://cpan/ URLs where the directory may change as a
 471               ;; function of the person who uploads the package.  Note that
 472               ;; package definitions usually concatenate fragments of the URL,
 473               ;; which is why we only attempt to replace a subset of the URL.
 474               (let ((properties (assq-set! (location->source-properties loc)
 475                                            'filename file))
 476                     (replacements `((,old-version . ,version)
 477                                     (,old-hash . ,hash)
 478                                     ,@(if (and old-url new-url)
 479                                           `((,(dirname old-url) .
 480                                              ,(dirname new-url)))
 481                                           '()))))
 482                 (and (edit-expression properties
 483                                       (cut update-expression <> replacements))
 484                      version))
 485               (begin
 486                 (warning (G_ "~a: could not locate source file")
 487                          (location-file loc))
 488                 #f)))
 489         (warning (package-location package)
 490                  (G_ "~a: no `version' field in source; skipping~%")
 491                  name))))
 492
 493 ;;; upstream.scm ends here