gnu: emacs-doom-themes: Only disable breaking compilations.
[jackhill/guix/guix.git] / guix / upstream.scm
index 02c50c0..c11de0b 100644 (file)
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
 (define-module (guix upstream)
   #:use-module (guix records)
   #:use-module (guix utils)
+  #:use-module (guix discovery)
   #:use-module ((guix download)
-                #:select (download-to-store))
+                #:select (download-to-store url-fetch))
   #:use-module (guix gnupg)
   #:use-module (guix packages)
   #:use-module (guix ui)
   #:use-module (guix base32)
+  #:use-module (guix gexp)
+  #:use-module (guix store)
+  #:use-module ((guix derivations)
+                #:select (built-derivations derivation->output-path))
+  #:use-module (guix monads)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:export (upstream-source
@@ -39,7 +49,9 @@
             upstream-source-urls
             upstream-source-signature-urls
             upstream-source-archive-types
+            upstream-source-input-changes
 
+            url-prefix-predicate
             coalesce-sources
 
             upstream-updater
             upstream-updater-predicate
             upstream-updater-latest
 
+            upstream-input-change?
+            upstream-input-change-name
+            upstream-input-change-type
+            upstream-input-change-action
+            changed-inputs
+
+            %updaters
+            lookup-updater
+
             download-tarball
-            package-update-path
+            package-latest-release
+            package-latest-release*
             package-update
             update-package-source))
 
   (version        upstream-source-version)        ;string
   (urls           upstream-source-urls)           ;list of strings
   (signature-urls upstream-source-signature-urls  ;#f | list of strings
-                  (default #f)))
+                  (default #f))
+  (input-changes  upstream-source-input-changes
+                  (default '()) (thunked)))
+
+;; Representation of an upstream input change.
+(define-record-type* <upstream-input-change>
+  upstream-input-change make-upstream-input-change
+  upstream-input-change?
+  (name    upstream-input-change-name)    ;string
+  (type    upstream-input-change-type)    ;symbol: regular | native | propagated
+  (action  upstream-input-change-action)) ;symbol: add | remove
+
+(define (changed-inputs package package-sexp)
+  "Return a list of input changes for PACKAGE based on the newly imported
+S-expression PACKAGE-SEXP."
+  (match package-sexp
+    ((and expr ('package fields ...))
+     (let* ((input->name (match-lambda ((name pkg . out) name)))
+            (new-regular
+             (match expr
+               ((path *** ('inputs
+                           ('quasiquote ((label ('unquote sym)) ...)))) label)
+               (_ '())))
+            (new-native
+             (match expr
+               ((path *** ('native-inputs
+                           ('quasiquote ((label ('unquote sym)) ...)))) label)
+               (_ '())))
+            (new-propagated
+             (match expr
+               ((path *** ('propagated-inputs
+                           ('quasiquote ((label ('unquote sym)) ...)))) label)
+               (_ '())))
+            (current-regular
+             (map input->name (package-inputs package)))
+            (current-native
+             (map input->name (package-native-inputs package)))
+            (current-propagated
+             (map input->name (package-propagated-inputs package))))
+       (append-map
+        (match-lambda
+          ((action type names)
+           (map (lambda (name)
+                  (upstream-input-change
+                   (name name)
+                   (type type)
+                   (action action)))
+                names)))
+        `((add regular
+           ,(lset-difference equal?
+                             new-regular current-regular))
+          (remove regular
+           ,(lset-difference equal?
+                             current-regular new-regular))
+          (add native
+           ,(lset-difference equal?
+                             new-native current-native))
+          (remove native
+           ,(lset-difference equal?
+                             current-native new-native))
+          (add propagated
+           ,(lset-difference equal?
+                             new-propagated current-propagated))
+          (remove propagated
+           ,(lset-difference equal?
+                             current-propagated new-propagated))))))
+    (_ '())))
+
+(define (url-prefix-predicate prefix)
+  "Return a predicate that returns true when passed a package where one of its
+source URLs starts with PREFIX."
+  (lambda (package)
+    (define matching-uri?
+      (match-lambda
+        ((? string? uri)
+         (string-prefix? prefix uri))
+        (_
+         #f)))
+
+    (match (package-source package)
+      ((? origin? origin)
+       (match (origin-uri origin)
+         ((? matching-uri?) #t)
+         (_                 #f)))
+      (_ #f))))
 
 (define (upstream-source-archive-types release)
   "Return the available types of archives for RELEASE---a list of strings such
@@ -119,44 +225,113 @@ correspond to the same version."
   (pred        upstream-updater-predicate)
   (latest      upstream-updater-latest))
 
+(define (importer-modules)
+  "Return the list of importer modules."
+  (cons (resolve-interface '(guix gnu-maintenance))
+        (all-modules (map (lambda (entry)
+                            `(,entry . "guix/import"))
+                          %load-path)
+                     #:warn warn-about-load-error)))
+
+(define %updaters
+  ;; The list of publically-known updaters.
+  (delay (fold-module-public-variables (lambda (obj result)
+                                         (if (upstream-updater? obj)
+                                             (cons obj result)
+                                             result))
+                                       '()
+                                       (importer-modules))))
+
 (define (lookup-updater package updaters)
   "Return an updater among UPDATERS that matches PACKAGE, or #f if none of
 them matches."
-  (any (match-lambda
-         (($ <upstream-updater> _ _ pred latest)
-          (and (pred package) latest)))
-       updaters))
-
-(define (package-update-path package updaters)
-  "Return an upstream source to update PACKAGE to, or #f if no update is
-needed or known."
+  (find (match-lambda
+          (($ <upstream-updater> name description pred latest)
+           (pred package)))
+        updaters))
+
+(define (package-latest-release package updaters)
+  "Return an upstream source to update PACKAGE, a <package> object, or #f if
+none of UPDATERS matches PACKAGE.  It is the caller's responsibility to ensure
+that the returned source is newer than the current one."
   (match (lookup-updater package updaters)
-    ((? procedure? latest-release)
-     (match (latest-release (package-name package))
-       ((and source ($ <upstream-source> name version))
-        (and (version>? version (package-version package))
-             source))
-       (_ #f)))
-    (#f #f)))
+    ((? upstream-updater? updater)
+     ((upstream-updater-latest updater) package))
+    (_ #f)))
+
+(define (package-latest-release* package updaters)
+  "Like 'package-latest-release', but ensure that the return source is newer
+than that of PACKAGE."
+  (match (package-latest-release package updaters)
+    ((and source ($ <upstream-source> name version))
+     (and (version>? version (package-version package))
+          source))
+    (_
+     #f)))
+
+(define (uncompressed-tarball name tarball)
+  "Return a derivation that decompresses TARBALL."
+  (define (ref package)
+    (module-ref (resolve-interface '(gnu packages compression))
+                package))
+
+  (define compressor
+    (cond ((or (string-suffix? ".gz" tarball)
+               (string-suffix? ".tgz" tarball))
+           (file-append (ref 'gzip) "/bin/gzip"))
+          ((string-suffix? ".bz2" tarball)
+           (file-append (ref 'bzip2) "/bin/bzip2"))
+          ((string-suffix? ".xz" tarball)
+           (file-append (ref 'xz) "/bin/xz"))
+          ((string-suffix? ".lz" tarball)
+           (file-append (ref 'lzip) "/bin/lzip"))
+          (else
+           (error "unknown archive type" tarball))))
+
+  (gexp->derivation (file-sans-extension name)
+                    #~(begin
+                        (copy-file #+tarball #+name)
+                        (and (zero? (system* #+compressor "-d" #+name))
+                             (copy-file #+(file-sans-extension name)
+                                        #$output)))))
 
 (define* (download-tarball store url signature-url
                            #:key (key-download 'interactive))
   "Download the tarball at URL to the store; check its OpenPGP signature at
 SIGNATURE-URL, unless SIGNATURE-URL is false.  On success, return the tarball
-file name.  KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys;
-allowed values: 'interactive' (default), 'always', and 'never'."
+file name; return #f on failure (network failure or authentication failure).
+KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
+values: 'interactive' (default), 'always', and 'never'."
   (let ((tarball (download-to-store store url)))
     (if (not signature-url)
         tarball
-        (let* ((sig (download-to-store store signature-url))
-               (ret (gnupg-verify* sig tarball #:key-download key-download)))
-          (if ret
-              tarball
-              (begin
-                (warning (_ "signature verification failed for `~a'~%")
-                         url)
-                (warning (_ "(could be because the public key is not in your keyring)~%"))
-                #f))))))
+        (let* ((sig  (download-to-store store signature-url))
+
+               ;; Sometimes we get a signature over the uncompressed tarball.
+               ;; In that case, decompress the tarball in the store so that we
+               ;; can check the signature.
+               (data (if (string-prefix? (basename url)
+                                         (basename signature-url))
+                         tarball
+                         (run-with-store store
+                           (mlet %store-monad ((drv (uncompressed-tarball
+                                                     (basename url) tarball)))
+                             (mbegin %store-monad
+                               (built-derivations (list drv))
+                               (return (derivation->output-path drv))))))))
+          (let-values (((status data)
+                        (gnupg-verify* sig data #:key-download key-download)))
+            (match status
+              ('valid-signature
+               tarball)
+              ('invalid-signature
+               (warning (G_ "signature verification failed for '~a' (key: ~a)~%")
+                        url data)
+               #f)
+              ('missing-key
+               (warning (G_ "missing public key ~a for '~a'~%")
+                        data url)
+               #f)))))))
 
 (define (find2 pred lst1 lst2)
   "Like 'find', but operate on items from both LST1 and LST2.  Return two
@@ -172,70 +347,133 @@ values: the item from LST1 and the item from LST2 that match PRED."
       (()
        (values #f #f)))))
 
-(define* (package-update store package updaters
-                         #:key (key-download 'interactive))
-  "Return the new version and the file name of the new version tarball for
-PACKAGE, or #f and #f when PACKAGE is up-to-date.  KEY-DOWNLOAD specifies a
-download policy for missing OpenPGP keys; allowed values: 'always', 'never',
-and 'interactive' (default)."
-  (match (package-update-path package updaters)
+(define* (package-update/url-fetch store package source
+                                   #:key key-download)
+  "Return the version, tarball, and SOURCE, to update PACKAGE to
+SOURCE, an <upstream-source>."
+  (match source
     (($ <upstream-source> _ version urls signature-urls)
-     (let*-values (((name)
-                    (package-name package))
-                   ((archive-type)
+     (let*-values (((archive-type)
                     (match (and=> (package-source package) origin-uri)
                       ((? string? uri)
-                       (or (file-extension uri) "gz"))
+                       (let ((type (file-extension (basename uri))))
+                         ;; Sometimes we have URLs such as
+                         ;; "https://github.com/…/tarball/v0.1", in which case
+                         ;; we must not consider "1" as the extension.
+                         (and (or (string-contains type "z")
+                                  (string=? type "tar"))
+                              type)))
                       (_
                        "gz")))
                    ((url signature-url)
+                    ;; Try to find a URL that matches ARCHIVE-TYPE.
                     (find2 (lambda (url sig-url)
-                             (string-suffix? archive-type url))
+                             ;; Some URIs lack a file extension, like
+                             ;; 'https://crates.io/???/0.1/download'.  In that
+                             ;; case, pick the first URL.
+                             (or (not archive-type)
+                                 (string-suffix? archive-type url)))
                            urls
                            (or signature-urls (circular-list #f)))))
-       (let ((tarball (download-tarball store url signature-url
+       ;; If none of URLS matches ARCHIVE-TYPE, then URL is #f; in that case,
+       ;; pick up the first element of URLS.
+       (let ((tarball (download-tarball store
+                                        (or url (first urls))
+                                        (and (pair? signature-urls)
+                                             (or signature-url
+                                                 (first signature-urls)))
                                         #:key-download key-download)))
-         (values version tarball))))
+         (values version tarball source))))))
+
+(define %method-updates
+  ;; Mapping of origin methods to source update procedures.
+  `((,url-fetch . ,package-update/url-fetch)))
+
+(define* (package-update store package updaters
+                         #:key (key-download 'interactive))
+  "Return the new version, the file name of the new version tarball, and input
+changes for PACKAGE; return #f (three values) when PACKAGE is up-to-date.
+KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
+values: 'always', 'never', and 'interactive' (default)."
+  (match (package-latest-release* package updaters)
+    ((? upstream-source? source)
+     (let ((method (match (package-source package)
+                     ((? origin? origin)
+                      (origin-method origin))
+                     (_
+                      #f))))
+       (match (assq method %method-updates)
+         (#f
+          (raise (condition (&message
+                             (message (format #f (G_ "cannot download for \
+this method: ~s")
+                                              method)))
+                            (&error-location
+                             (location (package-location package))))))
+         ((_ . update)
+          (update store package source
+                  #:key-download key-download)))))
     (#f
-     (values #f #f))))
-
-(define (update-package-source package version hash)
-  "Modify the source file that defines PACKAGE to refer to VERSION,
-whose tarball has SHA256 HASH (a bytevector).  Return the new version string
-if an update was made, and #f otherwise."
-  (define (update-expression expr old-version version old-hash hash)
-    ;; Update package expression EXPR, replacing occurrences OLD-VERSION by
-    ;; VERSION and occurrences of OLD-HASH by HASH (base32 representation
-    ;; thereof).
-    (let ((old-hash (bytevector->nix-base32-string old-hash))
-          (hash     (bytevector->nix-base32-string hash)))
-      (string-replace-substring
-       (string-replace-substring expr old-hash hash)
-       old-version version)))
+     (values #f #f #f))))
+
+(define* (update-package-source package source hash)
+  "Modify the source file that defines PACKAGE to refer to SOURCE, an
+<upstream-source> whose tarball has SHA256 HASH (a bytevector).  Return the
+new version string if an update was made, and #f otherwise."
+  (define (update-expression expr replacements)
+    ;; Apply REPLACEMENTS to package expression EXPR, a string.  REPLACEMENTS
+    ;; must be a list of replacement pairs, either bytevectors or strings.
+    (fold (lambda (replacement str)
+            (match replacement
+              (((? bytevector? old-bv) . (? bytevector? new-bv))
+               (string-replace-substring
+                str
+                (bytevector->nix-base32-string old-bv)
+                (bytevector->nix-base32-string new-bv)))
+              ((old . new)
+               (string-replace-substring str old new))))
+          expr
+          replacements))
 
   (let ((name        (package-name package))
+        (version     (upstream-source-version source))
         (version-loc (package-field-location package 'version)))
     (if version-loc
         (let* ((loc         (package-location package))
                (old-version (package-version package))
                (old-hash    (origin-sha256 (package-source package)))
+               (old-url     (match (origin-uri (package-source package))
+                              ((? string? url) url)
+                              (_ #f)))
+               (new-url     (match (upstream-source-urls source)
+                              ((first _ ...) first)))
                (file        (and=> (location-file loc)
                                    (cut search-path %load-path <>))))
           (if file
-              (and (edit-expression
-                    ;; Be sure to use absolute filename.
-                    (assq-set! (location->source-properties loc)
-                               'filename file)
-                    (cut update-expression <>
-                         old-version version old-hash hash))
-                   version)
+              ;; Be sure to use absolute filename.  Replace the URL directory
+              ;; when OLD-URL is available; this is useful notably for
+              ;; mirror://cpan/ URLs where the directory may change as a
+              ;; function of the person who uploads the package.  Note that
+              ;; package definitions usually concatenate fragments of the URL,
+              ;; which is why we only attempt to replace a subset of the URL.
+              (let ((properties (assq-set! (location->source-properties loc)
+                                           'filename file))
+                    (replacements `((,old-version . ,version)
+                                    (,old-hash . ,hash)
+                                    ,@(if (and old-url new-url)
+                                          `((,(dirname old-url) .
+                                             ,(dirname new-url)))
+                                          '()))))
+                (and (edit-expression properties
+                                      (cut update-expression <> replacements))
+                     version))
               (begin
-                (warning (_ "~a: could not locate source file")
+                (warning (G_ "~a: could not locate source file")
                          (location-file loc))
                 #f)))
         (begin
           (format (current-error-port)
-                  (_ "~a: ~a: no `version' field in source; skipping~%")
+                  (G_ "~a: ~a: no `version' field in source; skipping~%")
                   (location->string (package-location package))
                   name)))))