[jackhill/guix/guix.git] / guix / upstream.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 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.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix upstream)
  #:use-module (guix records)
  #:use-module (guix utils)
  #:use-module (guix discovery)
  #:use-module ((guix download)
                #:select (download-to-store))
  #: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 (ice-9 match)
  #:use-module (ice-9 regex)
  #:export (upstream-source
            upstream-source?
            upstream-source-package
            upstream-source-version
            upstream-source-urls
            upstream-source-signature-urls
            upstream-source-archive-types
            upstream-source-input-changes

            url-prefix-predicate
            coalesce-sources

            upstream-updater
            upstream-updater?
            upstream-updater-name
            upstream-updater-description
            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-latest-release
            package-latest-release*
            package-update
            update-package-source))

;;; Commentary:
;;;
;;; This module provides tools to represent and manipulate a upstream source
;;; code, and to auto-update package recipes.
;;;
;;; Code:

;; Representation of upstream's source.  There can be several URLs--e.g.,
;; tar.gz, tar.gz, etc.  There can be correspond signature URLs, one per
;; source URL.
(define-record-type* <upstream-source>
  upstream-source make-upstream-source
  upstream-source?
  (package        upstream-source-package)        ;string
  (version        upstream-source-version)        ;string
  (urls           upstream-source-urls)           ;list of strings
  (signature-urls upstream-source-signature-urls  ;#f | list of strings
                  (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
as \"gz\" or \"xz\"."
  (map file-extension (upstream-source-urls release)))

(define (coalesce-sources sources)
  "Coalesce the elements of SOURCES, a list of <upstream-source>, that
correspond to the same version."
  (define (same-version? r1 r2)
    (string=? (upstream-source-version r1) (upstream-source-version r2)))

  (define (release>? r1 r2)
    (version>? (upstream-source-version r1) (upstream-source-version r2)))

  (fold (lambda (release result)
          (match result
            ((head . tail)
             (if (same-version? release head)
                 (cons (upstream-source
                        (inherit release)
                        (urls (append (upstream-source-urls release)
                                      (upstream-source-urls head)))
                        (signature-urls
                         (let ((one (upstream-source-signature-urls release))
                               (two (upstream-source-signature-urls head)))
                           (and one two (append one two)))))
                       tail)
                 (cons release result)))
            (()
             (list release))))
        '()
        (sort sources release>?)))

\f
;;;
;;; Auto-update.
;;;

(define-record-type* <upstream-updater>
  upstream-updater make-upstream-updater
  upstream-updater?
  (name        upstream-updater-name)
  (description upstream-updater-description)
  (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> name description pred latest)
          (and (pred package) latest)))
       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)
     (latest-release 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; 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))

               ;; 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)))))))

               (ret  (gnupg-verify* sig data #:key-download key-download)))
          (if ret
              tarball
              (begin
                (warning (G_ "signature verification failed for `~a'~%")
                         url)
                (warning (G_ "(could be because the public key is not in your keyring)~%"))
                #f))))))

(define (find2 pred lst1 lst2)
  "Like 'find', but operate on items from both LST1 and LST2.  Return two
values: the item from LST1 and the item from LST2 that match PRED."
  (let loop ((lst1 lst1) (lst2 lst2))
    (match lst1
      ((head1 . tail1)
       (match lst2
         ((head2 . tail2)
          (if (pred head1 head2)
              (values head1 head2)
              (loop tail1 tail2)))))
      (()
       (values #f #f)))))

(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> _ version urls signature-urls changes)
     (let*-values (((name)
                    (package-name package))
                   ((archive-type)
                    (match (and=> (package-source package) origin-uri)
                      ((? string? uri)
                       (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)
                    (find2 (lambda (url sig-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
                                        #:key-download key-download)))
         (values version tarball changes))))
    (#f
     (values #f #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)))

  (let ((name        (package-name package))
        (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)))
               (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)
              (begin
                (warning (G_ "~a: could not locate source file")
                         (location-file loc))
                #f)))
        (begin
          (format (current-error-port)
                  (G_ "~a: ~a: no `version' field in source; skipping~%")
                  (location->string (package-location package))
                  name)))))

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