diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/gnu-maintenance.scm | 253 | ||||
| -rw-r--r-- | guix/http-client.scm | 2 | ||||
| -rw-r--r-- | guix/import/cran.scm | 85 | ||||
| -rw-r--r-- | guix/import/elpa.scm | 63 | ||||
| -rw-r--r-- | guix/import/hackage.scm | 40 | ||||
| -rw-r--r-- | guix/scripts/import/hackage.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 94 | ||||
| -rw-r--r-- | guix/upstream.scm | 259 |
8 files changed, 530 insertions, 268 deletions
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index e09df4b3ef..5af1b884ce 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -29,16 +29,10 @@ #:use-module (system foreign) #:use-module (guix http-client) #:use-module (guix ftp-client) - #:use-module (guix ui) #:use-module (guix utils) #:use-module (guix records) + #:use-module (guix upstream) #:use-module (guix packages) - #:use-module ((guix download) #:select (download-to-store)) - #:use-module (guix gnupg) - #:use-module (rnrs io ports) - #:use-module (guix base32) - #:use-module ((guix build utils) - #:select (substitute)) #:export (gnu-package-name gnu-package-mundane-name gnu-package-copyright-holder @@ -56,21 +50,12 @@ find-packages gnu-package? - gnu-release? - gnu-release-package - gnu-release-version - gnu-release-directory - gnu-release-files - releases latest-release gnu-release-archive-types gnu-package-name->name+version - download-tarball - package-update-path - package-update - update-package-source)) + %gnu-updater)) ;;; Commentary: ;;; @@ -218,13 +203,6 @@ network to check in GNU's database." ;;; Latest release. ;;; -(define-record-type* <gnu-release> gnu-release make-gnu-release - gnu-release? - (package gnu-release-package) - (version gnu-release-version) - (directory gnu-release-directory) - (files gnu-release-files)) - (define (ftp-server/directory project) "Return the FTP server and directory where PROJECT's tarball are stored." @@ -284,29 +262,6 @@ true." (gnu-package-name->name+version (sans-extension tarball)))) version)) -(define (coalesce-releases releases) - "Coalesce the elements of RELEASES that correspond to the same version." - (define (same-version? r1 r2) - (string=? (gnu-release-version r1) (gnu-release-version r2))) - - (define (release>? r1 r2) - (version>? (gnu-release-version r1) (gnu-release-version r2))) - - (fold (lambda (release result) - (match result - ((head . tail) - (if (same-version? release head) - (cons (gnu-release - (inherit release) - (files (append (gnu-release-files release) - (gnu-release-files head)))) - tail) - (cons release result))) - (() - (list release)))) - '() - (sort releases release>?))) - (define (releases project) "Return the list of releases of PROJECT as a list of release name/directory pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). " @@ -319,13 +274,24 @@ pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). (match directories (() (ftp-close conn) - (coalesce-releases result)) + (coalesce-sources result)) ((directory rest ...) (let* ((files (ftp-list conn directory)) (subdirs (filter-map (match-lambda - ((name 'directory . _) name) - (_ #f)) + ((name 'directory . _) name) + (_ #f)) files))) + (define (file->url file) + (string-append "ftp://" server directory "/" file)) + + (define (file->source file) + (let ((url (file->url file))) + (upstream-source + (package project) + (version (tarball->version file)) + (urls (list url)) + (signature-urls (list (string-append url ".sig")))))) + (loop (append (map (cut string-append directory "/" <>) subdirs) rest) @@ -335,15 +301,10 @@ pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). ;; in /gnu/guile, filter out guile-oops and ;; guile-www; in mit-scheme, filter out binaries. (filter-map (match-lambda - ((file 'file . _) - (if (release-file? project file) - (gnu-release - (package project) - (version (tarball->version file)) - (directory directory) - (files (list file))) - #f)) - (_ #f)) + ((file 'file . _) + (and (release-file? project file) + (file->source file))) + (_ #f)) files) result)))))))) @@ -355,7 +316,7 @@ open (resp. close) FTP connections; this can be useful to reuse connections." (if (version>? a b) a b)) (define (latest-release a b) - (if (version>? (gnu-release-version a) (gnu-release-version b)) + (if (version>? (upstream-source-version a) (upstream-source-version b)) a b)) (define contains-digit? @@ -368,6 +329,17 @@ open (resp. close) FTP connections; this can be useful to reuse connections." (let-values (((server directory) (ftp-server/directory project))) (define conn (ftp-open server)) + (define (file->url file) + (string-append "ftp://" server directory "/" file)) + + (define (file->source file) + (let ((url (file->url file))) + (upstream-source + (package project) + (version (tarball->version file)) + (urls (list url)) + (signature-urls (list (string-append url ".sig")))))) + (let loop ((directory directory) (result #f)) (let* ((entries (ftp-list conn directory)) @@ -375,12 +347,12 @@ open (resp. close) FTP connections; this can be useful to reuse connections." ;; Filter out sub-directories that do not contain digits---e.g., ;; /gnuzilla/lang and /gnupg/patches. (subdirs (filter-map (match-lambda - (((? patch-directory-name? dir) - 'directory . _) - #f) - (((? contains-digit? dir) 'directory . _) - dir) - (_ #f)) + (((? patch-directory-name? dir) + 'directory . _) + #f) + (((? contains-digit? dir) 'directory . _) + dir) + (_ #f)) entries)) ;; Whether or not SUBDIRS is empty, compute the latest releases @@ -390,19 +362,14 @@ open (resp. close) FTP connections; this can be useful to reuse connections." (releases (filter-map (match-lambda ((file 'file . _) (and (release-file? project file) - (gnu-release - (package project) - (version - (tarball->version file)) - (directory directory) - (files (list file))))) + (file->source file))) (_ #f)) entries))) ;; Assume that SUBDIRS correspond to versions, and jump into the ;; one with the highest version number. (let* ((release (reduce latest-release #f - (coalesce-releases releases))) + (coalesce-sources releases))) (result (if (and result release) (latest-release release result) (or release result))) @@ -414,10 +381,18 @@ open (resp. close) FTP connections; this can be useful to reuse connections." (ftp-close conn) result))))))) -(define (gnu-release-archive-types release) - "Return the available types of archives for RELEASE---a list of strings such -as \"gz\" or \"xz\"." - (map file-extension (gnu-release-files release))) +(define (latest-release* package) + "Like 'latest-release', but ignore FTP errors that might occur when PACKAGE +is not actually a GNU package, or not hosted on ftp.gnu.org, or not under that +name (this is the case for \"emacs-auctex\", for instance.)" + (catch 'ftp-error + (lambda () + (latest-release package)) + (lambda (key port . rest) + (if (ftp-connection? port) + (ftp-close port) + (close-port port)) + #f))) (define %package-name-rx ;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses @@ -431,121 +406,15 @@ as \"gz\" or \"xz\"." (values name+version #f) (values (match:substring match 1) (match:substring match 2))))) - -;;; -;;; Auto-update. -;;; - -(define (package-update-path package) - "Return an update path for PACKAGE, or #f if no update is needed." - (and (gnu-package? package) - (match (latest-release (package-name package)) - (($ <gnu-release> name version directory) - (and (version>? version (package-version package)) - `(,version . ,directory))) - (_ #f)))) - -(define* (download-tarball store project directory version - #:key (archive-type "gz") - (key-download 'interactive)) - "Download PROJECT's tarball over FTP and check its OpenPGP signature. On -success, return the tarball file name. KEY-DOWNLOAD specifies a download -policy for missing OpenPGP keys; allowed values: 'interactive' (default), -'always', and 'never'." - (let* ((server (ftp-server/directory project)) - (base (string-append project "-" version ".tar." archive-type)) - (url (string-append "ftp://" server "/" directory "/" base)) - (sig-url (string-append url ".sig")) - (tarball (download-to-store store url)) - (sig (download-to-store store sig-url))) - (let ((ret (gnupg-verify* sig tarball #:key-download key-download))) - (if ret - tarball - (begin - (warning (_ "signature verification failed for `~a'~%") - base) - (warning (_ "(could be because the public key is not in your keyring)~%")) - #f))))) - -(define* (package-update store package #: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) - ((version . directory) - (let-values (((name) - (package-name package)) - ((archive-type) - (let ((source (package-source package))) - (or (and (origin? source) - (file-extension (origin-uri source))) - "gz")))) - (let ((tarball (download-tarball store name directory version - #:archive-type archive-type - #:key-download key-download))) - (values version tarball)))) - (_ - (values #f #f)))) +(define (non-emacs-gnu-package? package) + "Return true if PACKAGE is a non-Emacs GNU package. This excludes AucTeX, +for instance, whose releases are now uploaded to elpa.gnu.org." + (and (not (string-prefix? "emacs-" (package-name package))) + (gnu-package? package))) -(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 (new-line line matches replacement) - ;; Iterate over MATCHES and return the modified line based on LINE. - ;; Replace each match with REPLACEMENT. - (let loop ((m* matches) ; matches - (o 0) ; offset in L - (r '())) ; result - (match m* - (() - (let ((r (cons (substring line o) r))) - (string-concatenate-reverse r))) - ((m . rest) - (loop rest - (match:end m) - (cons* replacement - (substring line o (match:start m)) - r)))))) - - (define (update-source file old-version version - old-hash hash) - ;; Update source file FILE, replacing occurrences OLD-VERSION by VERSION - ;; and occurrences of OLD-HASH by HASH (base32 representation thereof). - - ;; TODO: Currently this is a bit of a sledgehammer: if VERSION occurs in - ;; different unrelated places, we may modify it more than needed, for - ;; instance. We should try to make changes only within the sexp that - ;; corresponds to the definition of PACKAGE. - (let ((old-hash (bytevector->nix-base32-string old-hash)) - (hash (bytevector->nix-base32-string hash))) - (substitute file - `((,(regexp-quote old-version) - . ,(cut new-line <> <> version)) - (,(regexp-quote old-hash) - . ,(cut new-line <> <> hash)))) - version)) - - (let ((name (package-name package)) - (loc (package-field-location package 'version))) - (if loc - (let ((old-version (package-version package)) - (old-hash (origin-sha256 (package-source package))) - (file (and=> (location-file loc) - (cut search-path %load-path <>)))) - (if file - (update-source file - old-version version - old-hash hash) - (begin - (warning (_ "~a: could not locate source file") - (location-file loc)) - #f))) - (begin - (format (current-error-port) - (_ "~a: ~a: no `version' field in source; skipping~%") - (location->string (package-location package)) - name))))) +(define %gnu-updater + (upstream-updater 'gnu + non-emacs-gnu-package? + latest-release*)) ;;; gnu-maintenance.scm ends here diff --git a/guix/http-client.scm b/guix/http-client.scm index 8d1cc9b8f3..bee8cdc834 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -241,7 +241,7 @@ Raise an '&http-get-error' condition if downloading fails." ;;; Caching. ;;; -(define (%http-cache-ttl) +(define %http-cache-ttl ;; Time-to-live in seconds of the HTTP cache of in ~/.cache/guix. (make-parameter (* 3600 (or (and=> (getenv "GUIX_HTTP_CACHE_TTL") diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 585cb9fec2..6284c9eef3 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +21,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (sxml simple) #:use-module (sxml match) #:use-module (sxml xpath) @@ -29,7 +31,10 @@ #:use-module (guix base32) #:use-module ((guix download) #:select (download-to-store)) #:use-module (guix import utils) - #:export (cran->guix-package)) + #:use-module (guix upstream) + #:use-module (guix packages) + #:export (cran->guix-package + %cran-updater)) ;;; Commentary: ;;; @@ -89,7 +94,7 @@ first cell of a table row is considered a label cell." "Return an sxml representation of the CRAN page for the R package NAME, or #f on failure. NAME is case-sensitive." ;; This API always returns the latest release of the module. - (let ((cran-url (string-append %cran-url name))) + (let ((cran-url (string-append %cran-url name "/"))) (false-if-exception (xml->sxml (http-fetch cran-url) #:trim-whitespace? #t @@ -108,12 +113,25 @@ or #f on failure. NAME is case-sensitive." name) (symbol->string name)))))))) +(define (downloads->url downloads) + "Extract from DOWNLOADS, the downloads item of the CRAN sxml tree, the +download URL." + (string-append "mirror://cran/" + ;; Remove double dots, because we want an + ;; absolute path. + (regexp-substitute/global + #f "\\.\\./" + (string-join ((sxpath '((xhtml:a 1) @ href *text*)) + (table-datum downloads " Package source: "))) + 'pre 'post))) + +(define (nodes->text nodeset) + "Return the concatenation of the text nodes among NODESET." + (string-join ((sxpath '(// *text*)) nodeset) " ")) + (define (cran-sxml->sexp sxml) "Return the `package' s-expression for a CRAN package from the SXML representation of the package page." - (define (nodes->text nodeset) - (string-join ((sxpath '(// *text*)) nodeset) " ")) - (define (guix-name name) (if (string-prefix? "r-" name) (string-downcase name) @@ -136,16 +154,7 @@ representation of the package page." (table-datum summary "License:"))) (home-page (nodes->text ((sxpath '((xhtml:a 1))) (table-datum summary "URL:")))) - (source-url (string-append "mirror://cran/" - ;; Remove double dots, because we want an - ;; absolute path. - (regexp-substitute/global - #f "\\.\\./" - (string-join - ((sxpath '((xhtml:a 1) @ href *text*)) - (table-datum downloads - " Package source: "))) - 'pre 'post))) + (source-url (downloads->url downloads)) (tarball (with-store store (download-to-store store source-url))) (sysdepends (map match:substring (list-matches @@ -186,3 +195,49 @@ representation of the package page." `package' s-expression corresponding to that package, or #f on failure." (let ((module-meta (cran-fetch package-name))) (and=> module-meta cran-sxml->sexp))) + + +;;; +;;; Updater. +;;; + +(define (latest-release package) + "Return an <upstream-source> for the latest release of PACKAGE." + (define name + (if (string-prefix? "r-" package) + (string-drop package 2) + package)) + + (define sxml + (cran-fetch name)) + + (and sxml + (sxml-match-let* + (((*TOP* (xhtml:html + ,head + (xhtml:body + (xhtml:h2 ,name-and-synopsis) + (xhtml:p ,description) + ,summary + (xhtml:h4 "Downloads:") ,downloads + . ,rest))) + sxml)) + (let ((version (nodes->text (table-datum summary "Version:"))) + (url (downloads->url downloads))) + ;; CRAN does not provide signatures. + (upstream-source + (package package) + (version version) + (urls (list url))))))) + +(define (cran-package? package) + "Return true if PACKAGE is an R package from CRAN." + ;; Assume all R packages are available on CRAN. + (string-prefix? "r-" (package-name package))) + +(define %cran-updater + (upstream-updater 'cran + cran-package? + latest-release)) + +;;; cran.scm ends here diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index b3a3a963a6..37fc2b80fe 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> +;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,6 +20,7 @@ (define-module (guix import elpa) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) + #:use-module (web uri) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) @@ -26,13 +28,17 @@ #:use-module (srfi srfi-26) #:use-module ((guix download) #:select (download-to-store)) #:use-module (guix import utils) + #:use-module (guix http-client) #:use-module (guix store) #:use-module (guix ui) #:use-module (guix hash) #:use-module (guix base32) + #:use-module (guix upstream) + #:use-module (guix packages) #:use-module ((guix utils) #:select (call-with-temporary-output-file memoize)) - #:export (elpa->guix-package)) + #:export (elpa->guix-package + %elpa-updater)) (define (elpa-dependencies->names deps) "Convert DEPS, a list of symbol/version pairs à la ELPA, to a list of @@ -74,20 +80,16 @@ NAMES (strings)." (let ((url (and=> (elpa-url repo) (cut string-append <> "/archive-contents")))) (if url - (call-with-downloaded-file url read) + ;; Use a relatively small TTL for the archive itself. + (parameterize ((%http-cache-ttl (* 6 3600))) + (call-with-downloaded-file url read)) (leave (_ "~A: currently not supported~%") repo)))) (define* (call-with-downloaded-file url proc #:optional (error-thunk #f)) "Fetch URL, store the content in a temporary file and call PROC with that file. Returns the value returned by PROC. On error call ERROR-THUNK and return its value or leave if it's false." - (call-with-temporary-output-file - (lambda (temp port) - (or (and (url-fetch url temp) - (call-with-input-file temp proc)) - (if error-thunk - (error-thunk) - (leave (_ "~A: download failed~%") url)))))) + (proc (http-fetch/cached (string->uri url)))) (define (is-elpa-package? name elpa-pkg-spec) "Return true if the string NAME corresponds to the name of the package @@ -231,4 +233,47 @@ type '<elpa-package>'." (let ((pkg (fetch-elpa-package name repo))) (and=> pkg elpa-package->sexp))) + +;;; +;;; Updates. +;;; + +(define (latest-release package) + "Return an <upstream-release> for the latest release of PACKAGE. PACKAGE +may be a Guix package name such as \"emacs-debbugs\" or an upstream name such +as \"debbugs\"." + (define name + (if (string-prefix? "emacs-" package) + (string-drop package 6) + package)) + + (let* ((repo 'gnu) + (info (elpa-package-info name repo)) + (version (match info + ((name raw-version . _) + (elpa-version->string raw-version)))) + (url (match info + ((_ raw-version reqs synopsis kind . rest) + (package-source-url kind name version repo))))) + (upstream-source + (package package) + (version version) + (urls (list url)) + (signature-urls (list (string-append url ".sig")))))) + +(define (package-from-gnu.org? package) + "Return true if PACKAGE is from elpa.gnu.org." + (match (and=> (package-source package) origin-uri) + ((? string? uri) + (let ((uri (string->uri uri))) + (and uri (string=? (uri-host uri) "elpa.gnu.org")))) + (_ #f))) + +(define %elpa-updater + ;; The ELPA updater. We restrict it to packages hosted on elpa.gnu.org + ;; because for other repositories, we typically grab the source elsewhere. + (upstream-updater 'elpa + package-from-gnu.org? + latest-release)) + ;;; elpa.scm ends here diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index b5574a8d9f..3baa514aa1 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -32,37 +32,35 @@ #:export (hackage->guix-package)) (define ghc-standard-libraries - ;; List of libraries distributed with ghc (7.8.4). We include GHC itself as + ;; List of libraries distributed with ghc (7.10.2). We include GHC itself as ;; some packages list it. - '("ghc" - "haskell98" - "hoopl" + '("array" "base" - "transformers" - "deepseq" - "array" + "bin-package-db" "binary" "bytestring" + "cabal" ;; in the output of `ghc-pkg list` Cabal is uppercased, but + ;; hackage-name->package-name takes this into account. "containers" - "time" - "cabal" - "bin-package-db" + "deepseq" + "directory" + "filepath" + "ghc" "ghc-prim" + "haskeline" + "hoopl" + "hpc" "integer-gmp" - "integer-simple" - "win32" - "template-haskell" + "pretty" "process" - "haskeline" + "rts" + "template-haskell" "terminfo" - "directory" - "filepath" - "old-locale" + "time" + "transformers" "unix" - "old-time" - "pretty" - "xhtml" - "hpc")) + "win32" + "xhtml")) (define package-name-prefix "ghc-") diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm index 8d31128c47..8c4e640bf3 100644 --- a/guix/scripts/import/hackage.scm +++ b/guix/scripts/import/hackage.scm @@ -55,7 +55,7 @@ version.\n")) (display (_ " -s, --stdin read from standard input")) (display (_ " - -t, --no-test-dependencies don't include test only dependencies")) + -t, --no-test-dependencies don't include test-only dependencies")) (display (_ " -V, --version display version information and exit")) (newline) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 097059e372..6f7ca4a41b 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -25,7 +25,10 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix packages) - #:use-module (guix gnu-maintenance) + #:use-module (guix upstream) + #:use-module ((guix gnu-maintenance) #:select (%gnu-updater)) + #:use-module (guix import elpa) + #:use-module (guix import cran) #:use-module (guix gnupg) #:use-module (gnu packages) #:use-module ((gnu packages commencement) #:select (%final-inputs)) @@ -63,6 +66,9 @@ (x (leave (_ "~a: invalid selection; expected `core' or `non-core'~%") arg))))) + (option '(#\t "type") #t #f + (lambda (opt name arg result) + (alist-cons 'updater (string->symbol arg) result))) (option '(#\l "list-dependent") #f #f (lambda (opt name arg result) (alist-cons 'list-dependent? #t result))) @@ -104,6 +110,8 @@ specified with `--select'.\n")) -s, --select=SUBSET select all the packages in SUBSET, one of `core' or `non-core'")) (display (_ " + -t, --type=UPDATER restrict to updates from UPDATER--e.g., 'gnu'")) + (display (_ " -l, --list-dependent list top-level dependent packages that would need to be rebuilt as a result of upgrading PACKAGE...")) (newline) @@ -124,19 +132,33 @@ specified with `--select'.\n")) (newline) (show-bug-report-information)) -(define* (update-package store package #:key (key-download 'interactive)) + +;;; +;;; Updates. +;;; + +(define %updaters + ;; List of "updaters" used by default. They are consulted in this order. + (list %gnu-updater + %elpa-updater + %cran-updater)) + +(define (lookup-updater name) + "Return the updater called NAME." + (find (lambda (updater) + (eq? name (upstream-updater-name updater))) + %updaters)) + +(define* (update-package store package updaters + #:key (key-download 'interactive)) "Update the source file that defines PACKAGE with the new version. KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed values: 'interactive' (default), 'always', and 'never'." (let-values (((version tarball) - (catch #t - (lambda () - (package-update store package #:key-download key-download)) - (lambda _ - (values #f #f)))) + (package-update store package updaters + #:key-download key-download)) ((loc) - (or (package-field-location package - 'version) + (or (package-field-location package 'version) (package-location package)))) (when version (if (and=> tarball file-exists?) @@ -153,7 +175,6 @@ values: 'interactive' (default), 'always', and 'never'." downloaded and authenticated; not updating~%") (package-name package) version))))) - ;;; ;;; Entry point. @@ -169,6 +190,19 @@ downloaded and authenticated; not updating~%") (alist-cons 'argument arg result)) %default-options)) + (define (options->updaters opts) + ;; Return the list of updaters to use. + (match (filter-map (match-lambda + (('updater . name) + (lookup-updater name)) + (_ #f)) + opts) + (() + ;; Use the default updaters. + %updaters) + (lst + lst))) + (define (keep-newest package lst) ;; If a newer version of PACKAGE is already in LST, return LST; otherwise ;; return LST minus the other version of PACKAGE in it, plus PACKAGE. @@ -185,8 +219,8 @@ downloaded and authenticated; not updating~%") (define core-package? (let* ((input->package (match-lambda - ((name (? package? package) _ ...) package) - (_ #f))) + ((name (? package? package) _ ...) package) + (_ #f))) (final-inputs (map input->package %final-inputs)) (core (append final-inputs (append-map (compose (cut filter-map input->package <>) @@ -205,6 +239,7 @@ update would trigger a complete rebuild." (let* ((opts (parse-options)) (update? (assoc-ref opts 'update?)) + (updaters (options->updaters opts)) (list-dependent? (assoc-ref opts 'list-dependent?)) (key-download (assoc-ref opts 'key-download)) (packages @@ -215,18 +250,18 @@ update would trigger a complete rebuild." (specification->package spec)) (_ #f)) opts) - (() ; default to all packages - (let ((select? (match (assoc-ref opts 'select) - ('core core-package?) - ('non-core (negate core-package?)) - (_ (const #t))))) - (fold-packages (lambda (package result) - (if (select? package) - (keep-newest package result) - result)) - '()))) - (some ; user-specified packages - some)))) + (() ; default to all packages + (let ((select? (match (assoc-ref opts 'select) + ('core core-package?) + ('non-core (negate core-package?)) + (_ (const #t))))) + (fold-packages (lambda (package result) + (if (select? package) + (keep-newest package result) + result)) + '()))) + (some ; user-specified packages + some)))) (with-error-handling (cond (list-dependent? @@ -258,18 +293,19 @@ dependent packages are rebuilt: ~{~a~^ ~}~%" (or (assoc-ref opts 'gpg-command) (%gpg-command)))) (for-each - (cut update-package store <> #:key-download key-download) + (cut update-package store <> updaters + #:key-download key-download) packages)))) (else (for-each (lambda (package) - (match (false-if-exception (package-update-path package)) - ((new-version . directory) + (match (package-update-path package updaters) + ((? upstream-source? source) (let ((loc (or (package-field-location package 'version) (package-location package)))) (format (current-error-port) (_ "~a: ~a would be upgraded from ~a to ~a~%") (location->string loc) (package-name package) (package-version package) - new-version))) - (_ #f))) + (upstream-source-version source)))) + (#f #f))) packages)))))) diff --git a/guix/upstream.scm b/guix/upstream.scm new file mode 100644 index 0000000000..9300113ac6 --- /dev/null +++ b/guix/upstream.scm @@ -0,0 +1,259 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; +;;; 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 build utils) + #:select (substitute)) + #:use-module (guix gnupg) + #:use-module (guix packages) + #:use-module (guix ui) + #:use-module (guix base32) + #: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 + + coalesce-sources + + upstream-updater + upstream-updater? + upstream-updater-name + upstream-updater-predicate + upstream-updater-latest + + download-tarball + package-update-path + 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 (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 + (append (upstream-source-signature-urls release) + (upstream-source-signature-urls head)))) + tail) + (cons release result))) + (() + (list release)))) + '() + (sort sources release>?))) + + +;;; +;;; Auto-update. +;;; + +(define-record-type <upstream-updater> + (upstream-updater name pred latest) + upstream-updater? + (name upstream-updater-name) + (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> _ 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." + (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))) + +(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'." + (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)))))) + +(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-update-path 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) + (or (file-extension uri) "gz")) + (_ + "gz"))) + ((url signature-url) + (find2 (lambda (url sig-url) + (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 (new-line line matches replacement) + ;; Iterate over MATCHES and return the modified line based on LINE. + ;; Replace each match with REPLACEMENT. + (let loop ((m* matches) ; matches + (o 0) ; offset in L + (r '())) ; result + (match m* + (() + (let ((r (cons (substring line o) r))) + (string-concatenate-reverse r))) + ((m . rest) + (loop rest + (match:end m) + (cons* replacement + (substring line o (match:start m)) + r)))))) + + (define (update-source file old-version version + old-hash hash) + ;; Update source file FILE, replacing occurrences OLD-VERSION by VERSION + ;; and occurrences of OLD-HASH by HASH (base32 representation thereof). + + ;; TODO: Currently this is a bit of a sledgehammer: if VERSION occurs in + ;; different unrelated places, we may modify it more than needed, for + ;; instance. We should try to make changes only within the sexp that + ;; corresponds to the definition of PACKAGE. + (let ((old-hash (bytevector->nix-base32-string old-hash)) + (hash (bytevector->nix-base32-string hash))) + (substitute file + `((,(regexp-quote old-version) + . ,(cut new-line <> <> version)) + (,(regexp-quote old-hash) + . ,(cut new-line <> <> hash)))) + version)) + + (let ((name (package-name package)) + (loc (package-field-location package 'version))) + (if loc + (let ((old-version (package-version package)) + (old-hash (origin-sha256 (package-source package))) + (file (and=> (location-file loc) + (cut search-path %load-path <>)))) + (if file + (update-source file + old-version version + old-hash hash) + (begin + (warning (_ "~a: could not locate source file") + (location-file loc)) + #f))) + (begin + (format (current-error-port) + (_ "~a: ~a: no `version' field in source; skipping~%") + (location->string (package-location package)) + name))))) + +;;; upstream.scm ends here |