guix/upstream.scm

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