guix/upstream.scm

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