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

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
;;;
;;; 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 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

            url-prefix-predicate
            coalesce-sources

            upstream-updater
            upstream-updater?
            upstream-updater-name
            upstream-updater-description
            upstream-updater-predicate
            upstream-updater-latest

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

(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 (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 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-latest-release* package updaters)
    (($ <upstream-source> _ version urls signature-urls)
     (let*-values (((name)
                    (package-name package))
                   ((archive-type)
                    (match (and=> (package-source package) origin-uri)
                      ((? string? uri)
                       (file-extension (basename uri)))
                      (_
                       "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))))
    (#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)))

  (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
3b2dc9ed	2	;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
7e6b490d	3	;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
0a7c5a09 LC	4	;;;
	5	;;; This file is part of GNU Guix.
	6	;;;
	7	;;; GNU Guix is free software; you can redistribute it and/or modify it
	8	;;; under the terms of the GNU General Public License as published by
	9	;;; the Free Software Foundation; either version 3 of the License, or (at
	10	;;; your option) any later version.
	11	;;;
	12	;;; GNU Guix is distributed in the hope that it will be useful, but
	13	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	14	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	15	;;; GNU General Public License for more details.
	16	;;;
	17	;;; You should have received a copy of the GNU General Public License
	18	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	19
	20	(define-module (guix upstream)
	21	#:use-module (guix records)
	22	#:use-module (guix utils)
	23	#:use-module ((guix download)
	24	#:select (download-to-store))
0a7c5a09 LC	25	#:use-module (guix gnupg)
	26	#:use-module (guix packages)
	27	#:use-module (guix ui)
	28	#:use-module (guix base32)
8d5d0628 LC	29	#:use-module (guix gexp)
	30	#:use-module (guix store)
	31	#:use-module ((guix derivations)
	32	#:select (built-derivations derivation->output-path))
	33	#:use-module (guix monads)
0a7c5a09 LC	34	#:use-module (srfi srfi-1)
	35	#:use-module (srfi srfi-9)
	36	#:use-module (srfi srfi-11)
	37	#:use-module (srfi srfi-26)
	38	#:use-module (ice-9 match)
	39	#:use-module (ice-9 regex)
	40	#:export (upstream-source
	41	upstream-source?
	42	upstream-source-package
	43	upstream-source-version
	44	upstream-source-urls
	45	upstream-source-signature-urls
3195e19d	46	upstream-source-archive-types
0a7c5a09	47
97abc907	48	url-prefix-predicate
0a7c5a09 LC	49	coalesce-sources
	50
	51	upstream-updater
	52	upstream-updater?
	53	upstream-updater-name
7e6b490d	54	upstream-updater-description
0a7c5a09 LC	55	upstream-updater-predicate
	56	upstream-updater-latest
	57
e9c72306 LC	58	lookup-updater
e9c72306 LC	59
0a7c5a09	60	download-tarball
e9c72306 LC	61	package-latest-release
e9c72306 LC	62	package-latest-release*
0a7c5a09 LC	63	package-update
	64	update-package-source))
	65
	66	;;; Commentary:
	67	;;;
	68	;;; This module provides tools to represent and manipulate a upstream source
	69	;;; code, and to auto-update package recipes.
	70	;;;
	71	;;; Code:
	72
	73	;; Representation of upstream's source. There can be several URLs--e.g.,
	74	;; tar.gz, tar.gz, etc. There can be correspond signature URLs, one per
	75	;; source URL.
	76	(define-record-type* <upstream-source>
	77	upstream-source make-upstream-source
	78	upstream-source?
	79	(package upstream-source-package) ;string
	80	(version upstream-source-version) ;string
	81	(urls upstream-source-urls) ;list of strings
	82	(signature-urls upstream-source-signature-urls ;#f \| list of strings
	83	(default #f)))
	84
97abc907 LC	85	(define (url-prefix-predicate prefix)
	86	"Return a predicate that returns true when passed a package where one of its
	87	source URLs starts with PREFIX."
	88	(lambda (package)
	89	(define matching-uri?
	90	(match-lambda
	91	((? string? uri)
	92	(string-prefix? prefix uri))
	93	(_
	94	#f)))
	95
	96	(match (package-source package)
	97	((? origin? origin)
	98	(match (origin-uri origin)
	99	((? matching-uri?) #t)
	100	(_ #f)))
	101	(_ #f))))
	102
0a7c5a09 LC	103	(define (upstream-source-archive-types release)
	104	"Return the available types of archives for RELEASE---a list of strings such
	105	as \"gz\" or \"xz\"."
	106	(map file-extension (upstream-source-urls release)))
	107
	108	(define (coalesce-sources sources)
	109	"Coalesce the elements of SOURCES, a list of <upstream-source>, that
	110	correspond to the same version."
	111	(define (same-version? r1 r2)
	112	(string=? (upstream-source-version r1) (upstream-source-version r2)))
	113
	114	(define (release>? r1 r2)
	115	(version>? (upstream-source-version r1) (upstream-source-version r2)))
	116
	117	(fold (lambda (release result)
	118	(match result
	119	((head . tail)
	120	(if (same-version? release head)
	121	(cons (upstream-source
	122	(inherit release)
	123	(urls (append (upstream-source-urls release)
	124	(upstream-source-urls head)))
	125	(signature-urls
6efa6f76	126	(let ((one (upstream-source-signature-urls release))
f1eacbaf	127	(two (upstream-source-signature-urls head)))
6efa6f76	128	(and one two (append one two)))))
0a7c5a09 LC	129	tail)
	130	(cons release result)))
	131	(()
	132	(list release))))
	133	'()
	134	(sort sources release>?)))
	135
	136	\f
	137	;;;
	138	;;; Auto-update.
	139	;;;
	140
7e6b490d AK	141	(define-record-type* <upstream-updater>
7e6b490d AK	142	upstream-updater make-upstream-updater
0a7c5a09	143	upstream-updater?
7e6b490d AK	144	(name upstream-updater-name)
	145	(description upstream-updater-description)
	146	(pred upstream-updater-predicate)
	147	(latest upstream-updater-latest))
0a7c5a09 LC	148
	149	(define (lookup-updater package updaters)
	150	"Return an updater among UPDATERS that matches PACKAGE, or #f if none of
	151	them matches."
	152	(any (match-lambda
3b2dc9ed	153	(($ <upstream-updater> name description pred latest)
0a7c5a09 LC	154	(and (pred package) latest)))
	155	updaters))
	156
e9c72306	157	(define (package-latest-release package updaters)
7d27a025	158	"Return an upstream source to update PACKAGE, a <package> object, or #f if
e9c72306 LC	159	none of UPDATERS matches PACKAGE. It is the caller's responsibility to ensure
e9c72306 LC	160	that the returned source is newer than the current one."
0a7c5a09 LC	161	(match (lookup-updater package updaters)
0a7c5a09 LC	162	((? procedure? latest-release)
e9c72306 LC	163	(latest-release package))
	164	(_ #f)))
	165
	166	(define (package-latest-release* package updaters)
	167	"Like 'package-latest-release', but ensure that the return source is newer
	168	than that of PACKAGE."
	169	(match (package-latest-release package updaters)
	170	((and source ($ <upstream-source> name version))
	171	(and (version>? version (package-version package))
	172	source))
	173	(_
	174	#f)))
0a7c5a09	175
8d5d0628 LC	176	(define (uncompressed-tarball name tarball)
	177	"Return a derivation that decompresses TARBALL."
	178	(define (ref package)
	179	(module-ref (resolve-interface '(gnu packages compression))
	180	package))
	181
	182	(define compressor
	183	(cond ((or (string-suffix? ".gz" tarball)
	184	(string-suffix? ".tgz" tarball))
	185	(file-append (ref 'gzip) "/bin/gzip"))
	186	((string-suffix? ".bz2" tarball)
	187	(file-append (ref 'bzip2) "/bin/bzip2"))
	188	((string-suffix? ".xz" tarball)
	189	(file-append (ref 'xz) "/bin/xz"))
	190	((string-suffix? ".lz" tarball)
	191	(file-append (ref 'lzip) "/bin/lzip"))
	192	(else
	193	(error "unknown archive type" tarball))))
	194
	195	(gexp->derivation (file-sans-extension name)
	196	#~(begin
	197	(copy-file #+tarball #+name)
	198	(and (zero? (system* #+compressor "-d" #+name))
	199	(copy-file #+(file-sans-extension name)
	200	#$output)))))
	201
0a7c5a09 LC	202	(define* (download-tarball store url signature-url
	203	#:key (key-download 'interactive))
	204	"Download the tarball at URL to the store; check its OpenPGP signature at
	205	SIGNATURE-URL, unless SIGNATURE-URL is false. On success, return the tarball
14959038 LC	206	file name; return #f on failure (network failure or authentication failure).
	207	KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
	208	values: 'interactive' (default), 'always', and 'never'."
0a7c5a09 LC	209	(let ((tarball (download-to-store store url)))
	210	(if (not signature-url)
	211	tarball
8d5d0628 LC	212	(let* ((sig (download-to-store store signature-url))
	213
	214	;; Sometimes we get a signature over the uncompressed tarball.
	215	;; In that case, decompress the tarball in the store so that we
	216	;; can check the signature.
	217	(data (if (string-prefix? (basename url)
	218	(basename signature-url))
	219	tarball
	220	(run-with-store store
	221	(mlet %store-monad ((drv (uncompressed-tarball
	222	(basename url) tarball)))
	223	(mbegin %store-monad
	224	(built-derivations (list drv))
	225	(return (derivation->output-path drv)))))))
	226
	227	(ret (gnupg-verify* sig data #:key-download key-download)))
0a7c5a09 LC	228	(if ret
	229	tarball
	230	(begin
69daee23	231	(warning (G_ "signature verification failed for `~a'~%")
0a7c5a09	232	url)
69daee23	233	(warning (G_ "(could be because the public key is not in your keyring)~%"))
0a7c5a09 LC	234	#f))))))
	235
	236	(define (find2 pred lst1 lst2)
	237	"Like 'find', but operate on items from both LST1 and LST2. Return two
	238	values: the item from LST1 and the item from LST2 that match PRED."
	239	(let loop ((lst1 lst1) (lst2 lst2))
	240	(match lst1
	241	((head1 . tail1)
	242	(match lst2
	243	((head2 . tail2)
	244	(if (pred head1 head2)
	245	(values head1 head2)
	246	(loop tail1 tail2)))))
	247	(()
	248	(values #f #f)))))
	249
	250	(define* (package-update store package updaters
	251	#:key (key-download 'interactive))
	252	"Return the new version and the file name of the new version tarball for
	253	PACKAGE, or #f and #f when PACKAGE is up-to-date. KEY-DOWNLOAD specifies a
	254	download policy for missing OpenPGP keys; allowed values: 'always', 'never',
	255	and 'interactive' (default)."
e9c72306	256	(match (package-latest-release* package updaters)
0a7c5a09 LC	257	(($ <upstream-source> _ version urls signature-urls)
	258	(let*-values (((name)
	259	(package-name package))
	260	((archive-type)
	261	(match (and=> (package-source package) origin-uri)
	262	((? string? uri)
6976c681	263	(file-extension (basename uri)))
0a7c5a09 LC	264	(_
	265	"gz")))
	266	((url signature-url)
	267	(find2 (lambda (url sig-url)
af72a21a LC	268	;; Some URIs lack a file extension, like
	269	;; 'https://crates.io/???/0.1/download'. In that
	270	;; case, pick the first URL.
	271	(or (not archive-type)
	272	(string-suffix? archive-type url)))
0a7c5a09 LC	273	urls
	274	(or signature-urls (circular-list #f)))))
	275	(let ((tarball (download-tarball store url signature-url
	276	#:key-download key-download)))
	277	(values version tarball))))
	278	(#f
	279	(values #f #f))))
	280
	281	(define (update-package-source package version hash)
	282	"Modify the source file that defines PACKAGE to refer to VERSION,
	283	whose tarball has SHA256 HASH (a bytevector). Return the new version string
	284	if an update was made, and #f otherwise."
2b8e9d9e SB	285	(define (update-expression expr old-version version old-hash hash)
	286	;; Update package expression EXPR, replacing occurrences OLD-VERSION by
	287	;; VERSION and occurrences of OLD-HASH by HASH (base32 representation
	288	;; thereof).
0a7c5a09 LC	289	(let ((old-hash (bytevector->nix-base32-string old-hash))
0a7c5a09 LC	290	(hash (bytevector->nix-base32-string hash)))
2b8e9d9e SB	291	(string-replace-substring
	292	(string-replace-substring expr old-hash hash)
	293	old-version version)))
	294
	295	(let ((name (package-name package))
	296	(version-loc (package-field-location package 'version)))
	297	(if version-loc
	298	(let* ((loc (package-location package))
	299	(old-version (package-version package))
	300	(old-hash (origin-sha256 (package-source package)))
	301	(file (and=> (location-file loc)
	302	(cut search-path %load-path <>))))
0a7c5a09	303	(if file
2b8e9d9e SB	304	(and (edit-expression
	305	;; Be sure to use absolute filename.
	306	(assq-set! (location->source-properties loc)
	307	'filename file)
	308	(cut update-expression <>
	309	old-version version old-hash hash))
	310	version)
0a7c5a09	311	(begin
69daee23	312	(warning (G_ "~a: could not locate source file")
0a7c5a09 LC	313	(location-file loc))
	314	#f)))
	315	(begin
	316	(format (current-error-port)
69daee23	317	(G_ "~a: ~a: no `version' field in source; skipping~%")
0a7c5a09 LC	318	(location->string (package-location package))
	319	name)))))
	320
	321	;;; upstream.scm ends here