guix/upstream.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 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                      #:warn warn-about-load-error)))
 158
 159 (define %updaters
 160   ;; The list of publically-known updaters.
 161   (delay (fold-module-public-variables (lambda (obj result)
 162                                          (if (upstream-updater? obj)
 163                                              (cons obj result)
 164                                              result))
 165                                        '()
 166                                        (importer-modules))))
 167
 168 (define (lookup-updater package updaters)
 169   "Return an updater among UPDATERS that matches PACKAGE, or #f if none of
 170 them matches."
 171   (any (match-lambda
 172          (($ <upstream-updater> name description pred latest)
 173           (and (pred package) latest)))
 174        updaters))
 175
 176 (define (package-latest-release package updaters)
 177   "Return an upstream source to update PACKAGE, a <package> object, or #f if
 178 none of UPDATERS matches PACKAGE.  It is the caller's responsibility to ensure
 179 that the returned source is newer than the current one."
 180   (match (lookup-updater package updaters)
 181     ((? procedure? latest-release)
 182      (latest-release package))
 183     (_ #f)))
 184
 185 (define (package-latest-release* package updaters)
 186   "Like 'package-latest-release', but ensure that the return source is newer
 187 than that of PACKAGE."
 188   (match (package-latest-release package updaters)
 189     ((and source ($ <upstream-source> name version))
 190      (and (version>? version (package-version package))
 191           source))
 192     (_
 193      #f)))
 194
 195 (define (uncompressed-tarball name tarball)
 196   "Return a derivation that decompresses TARBALL."
 197   (define (ref package)
 198     (module-ref (resolve-interface '(gnu packages compression))
 199                 package))
 200
 201   (define compressor
 202     (cond ((or (string-suffix? ".gz" tarball)
 203                (string-suffix? ".tgz" tarball))
 204            (file-append (ref 'gzip) "/bin/gzip"))
 205           ((string-suffix? ".bz2" tarball)
 206            (file-append (ref 'bzip2) "/bin/bzip2"))
 207           ((string-suffix? ".xz" tarball)
 208            (file-append (ref 'xz) "/bin/xz"))
 209           ((string-suffix? ".lz" tarball)
 210            (file-append (ref 'lzip) "/bin/lzip"))
 211           (else
 212            (error "unknown archive type" tarball))))
 213
 214   (gexp->derivation (file-sans-extension name)
 215                     #~(begin
 216                         (copy-file #+tarball #+name)
 217                         (and (zero? (system* #+compressor "-d" #+name))
 218                              (copy-file #+(file-sans-extension name)
 219                                         #$output)))))
 220
 221 (define* (download-tarball store url signature-url
 222                            #:key (key-download 'interactive))
 223   "Download the tarball at URL to the store; check its OpenPGP signature at
 224 SIGNATURE-URL, unless SIGNATURE-URL is false.  On success, return the tarball
 225 file name; return #f on failure (network failure or authentication failure).
 226 KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
 227 values: 'interactive' (default), 'always', and 'never'."
 228   (let ((tarball (download-to-store store url)))
 229     (if (not signature-url)
 230         tarball
 231         (let* ((sig  (download-to-store store signature-url))
 232
 233                ;; Sometimes we get a signature over the uncompressed tarball.
 234                ;; In that case, decompress the tarball in the store so that we
 235                ;; can check the signature.
 236                (data (if (string-prefix? (basename url)
 237                                          (basename signature-url))
 238                          tarball
 239                          (run-with-store store
 240                            (mlet %store-monad ((drv (uncompressed-tarball
 241                                                      (basename url) tarball)))
 242                              (mbegin %store-monad
 243                                (built-derivations (list drv))
 244                                (return (derivation->output-path drv)))))))
 245
 246                (ret  (gnupg-verify* sig data #:key-download key-download)))
 247           (if ret
 248               tarball
 249               (begin
 250                 (warning (G_ "signature verification failed for `~a'~%")
 251                          url)
 252                 (warning (G_ "(could be because the public key is not in your keyring)~%"))
 253                 #f))))))
 254
 255 (define (find2 pred lst1 lst2)
 256   "Like 'find', but operate on items from both LST1 and LST2.  Return two
 257 values: the item from LST1 and the item from LST2 that match PRED."
 258   (let loop ((lst1 lst1) (lst2 lst2))
 259     (match lst1
 260       ((head1 . tail1)
 261        (match lst2
 262          ((head2 . tail2)
 263           (if (pred head1 head2)
 264               (values head1 head2)
 265               (loop tail1 tail2)))))
 266       (()
 267        (values #f #f)))))
 268
 269 (define* (package-update store package updaters
 270                          #:key (key-download 'interactive))
 271   "Return the new version and the file name of the new version tarball for
 272 PACKAGE, or #f and #f when PACKAGE is up-to-date.  KEY-DOWNLOAD specifies a
 273 download policy for missing OpenPGP keys; allowed values: 'always', 'never',
 274 and 'interactive' (default)."
 275   (match (package-latest-release* package updaters)
 276     (($ <upstream-source> _ version urls signature-urls)
 277      (let*-values (((name)
 278                     (package-name package))
 279                    ((archive-type)
 280                     (match (and=> (package-source package) origin-uri)
 281                       ((? string? uri)
 282                        (let ((type (file-extension (basename uri))))
 283                          ;; Sometimes we have URLs such as
 284                          ;; "https://github.com/…/tarball/v0.1", in which case
 285                          ;; we must not consider "1" as the extension.
 286                          (and (or (string-contains type "z")
 287                                   (string=? type "tar"))
 288                               type)))
 289                       (_
 290                        "gz")))
 291                    ((url signature-url)
 292                     (find2 (lambda (url sig-url)
 293                              ;; Some URIs lack a file extension, like
 294                              ;; 'https://crates.io/???/0.1/download'.  In that
 295                              ;; case, pick the first URL.
 296                              (or (not archive-type)
 297                                  (string-suffix? archive-type url)))
 298                            urls
 299                            (or signature-urls (circular-list #f)))))
 300        (let ((tarball (download-tarball store url signature-url
 301                                         #:key-download key-download)))
 302          (values version tarball))))
 303     (#f
 304      (values #f #f))))
 305
 306 (define (update-package-source package version hash)
 307   "Modify the source file that defines PACKAGE to refer to VERSION,
 308 whose tarball has SHA256 HASH (a bytevector).  Return the new version string
 309 if an update was made, and #f otherwise."
 310   (define (update-expression expr old-version version old-hash hash)
 311     ;; Update package expression EXPR, replacing occurrences OLD-VERSION by
 312     ;; VERSION and occurrences of OLD-HASH by HASH (base32 representation
 313     ;; thereof).
 314     (let ((old-hash (bytevector->nix-base32-string old-hash))
 315           (hash     (bytevector->nix-base32-string hash)))
 316       (string-replace-substring
 317        (string-replace-substring expr old-hash hash)
 318        old-version version)))
 319
 320   (let ((name        (package-name package))
 321         (version-loc (package-field-location package 'version)))
 322     (if version-loc
 323         (let* ((loc         (package-location package))
 324                (old-version (package-version package))
 325                (old-hash    (origin-sha256 (package-source package)))
 326                (file        (and=> (location-file loc)
 327                                    (cut search-path %load-path <>))))
 328           (if file
 329               (and (edit-expression
 330                     ;; Be sure to use absolute filename.
 331                     (assq-set! (location->source-properties loc)
 332                                'filename file)
 333                     (cut update-expression <>
 334                          old-version version old-hash hash))
 335                    version)
 336               (begin
 337                 (warning (G_ "~a: could not locate source file")
 338                          (location-file loc))
 339                 #f)))
 340         (begin
 341           (format (current-error-port)
 342                   (G_ "~a: ~a: no `version' field in source; skipping~%")
 343                   (location->string (package-location package))
 344                   name)))))
 345
 346 ;;; upstream.scm ends here