diff options
author | Mark H Weaver <mhw@netris.org> | 2016-02-27 08:52:23 -0500 |
---|---|---|
committer | Mark H Weaver <mhw@netris.org> | 2016-02-27 08:52:23 -0500 |
commit | 048ec1a8b092a87de08bfe410be65642522b63ed (patch) | |
tree | 1279c4fa3fd09805dbfe06be3514879aa38d503e /guix | |
parent | fe5f687284889eeff3c1b73edab0aa26e58c3bc5 (diff) | |
parent | b35461748b20d0172744974b39e7d9d033400c51 (diff) | |
download | gnu-guix-048ec1a8b092a87de08bfe410be65642522b63ed.tar gnu-guix-048ec1a8b092a87de08bfe410be65642522b63ed.tar.gz |
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
-rw-r--r-- | guix/derivations.scm | 98 | ||||
-rw-r--r-- | guix/download.scm | 29 | ||||
-rw-r--r-- | guix/gexp.scm | 3 | ||||
-rw-r--r-- | guix/gnu-maintenance.scm | 37 | ||||
-rw-r--r-- | guix/grafts.scm | 146 | ||||
-rw-r--r-- | guix/http-client.scm | 18 | ||||
-rw-r--r-- | guix/import/gem.scm | 63 | ||||
-rw-r--r-- | guix/import/github.scm | 198 | ||||
-rw-r--r-- | guix/licenses.scm | 26 | ||||
-rw-r--r-- | guix/packages.scm | 7 | ||||
-rw-r--r-- | guix/profiles.scm | 10 | ||||
-rw-r--r-- | guix/scripts/build.scm | 1 | ||||
-rw-r--r-- | guix/scripts/environment.scm | 239 | ||||
-rw-r--r-- | guix/scripts/package.scm | 12 | ||||
-rw-r--r-- | guix/scripts/publish.scm | 31 | ||||
-rw-r--r-- | guix/scripts/refresh.scm | 10 | ||||
-rw-r--r-- | guix/scripts/system.scm | 23 | ||||
-rw-r--r-- | guix/store.scm | 29 |
18 files changed, 725 insertions, 255 deletions
diff --git a/guix/derivations.scm b/guix/derivations.scm index 5db739a97d..1164774009 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -85,21 +85,11 @@ derivation-path->output-paths derivation - graft - graft? - graft-origin - graft-replacement - graft-origin-output - graft-replacement-output - graft-derivation - map-derivation build-derivations built-derivations - %graft? - set-grafting build-expression->derivation) @@ -1111,81 +1101,6 @@ they can refer to each other." #:guile-for-build guile #:local-build? #t))) -(define-record-type* <graft> graft make-graft - graft? - (origin graft-origin) ;derivation | store item - (origin-output graft-origin-output ;string | #f - (default "out")) - (replacement graft-replacement) ;derivation | store item - (replacement-output graft-replacement-output ;string | #f - (default "out"))) - -(define* (graft-derivation store name drv grafts - #:key (guile (%guile-for-build)) - (system (%current-system))) - "Return a derivation called NAME, based on DRV but with all the GRAFTS -applied." - ;; XXX: Someday rewrite using gexps. - (define mapping - ;; List of store item pairs. - (map (match-lambda - (($ <graft> source source-output target target-output) - (cons (if (derivation? source) - (derivation->output-path source source-output) - source) - (if (derivation? target) - (derivation->output-path target target-output) - target)))) - grafts)) - - (define outputs - (match (derivation-outputs drv) - (((names . outputs) ...) - (map derivation-output-path outputs)))) - - (define output-names - (match (derivation-outputs drv) - (((names . outputs) ...) - names))) - - (define build - `(begin - (use-modules (guix build graft) - (guix build utils) - (ice-9 match)) - - (let ((mapping ',mapping)) - (for-each (lambda (input output) - (format #t "grafting '~a' -> '~a'...~%" input output) - (force-output) - (rewrite-directory input output - `((,input . ,output) - ,@mapping))) - ',outputs - (match %outputs - (((names . files) ...) - files)))))) - - (define add-label - (cut cons "x" <>)) - - (match grafts - ((($ <graft> sources source-outputs targets target-outputs) ...) - (let ((sources (zip sources source-outputs)) - (targets (zip targets target-outputs))) - (build-expression->derivation store name build - #:system system - #:guile-for-build guile - #:modules '((guix build graft) - (guix build utils)) - #:inputs `(,@(map (lambda (out) - `("x" ,drv ,out)) - output-names) - ,@(append (map add-label sources) - (map add-label targets))) - #:outputs output-names - #:local-build? #t))))) - (define* (build-expression->derivation store name exp ;deprecated #:key (system (%current-system)) @@ -1353,16 +1268,3 @@ ALLOWED-REFERENCES, LOCAL-BUILD?, and SUBSTITUTABLE?." (define built-derivations (store-lift build-derivations)) - -;; The following might feel more at home in (guix packages) but since (guix -;; gexp), which is a lower level, needs them, we put them here. - -(define %graft? - ;; Whether to honor package grafts by default. - (make-parameter #t)) - -(define (set-grafting enable?) - "This monadic procedure enables grafting when ENABLE? is true, and disables -it otherwise. It returns the previous setting." - (lambda (store) - (values (%graft? enable?) store))) diff --git a/guix/download.scm b/guix/download.scm index 204cfc0826..88f285dc0a 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2014, 2015 Andreas Enge <andreas@enge.fr> +;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> ;;; ;;; This file is part of GNU Guix. ;;; @@ -31,6 +32,7 @@ #:use-module (srfi srfi-26) #:export (%mirrors url-fetch + url-fetch/tarbomb download-to-store)) ;;; Commentary: @@ -294,6 +296,31 @@ in the store." ;; <https://bugs.gnu.org/18747>.) #:local-build? #t))))) +(define* (url-fetch/tarbomb url hash-algo hash + #:optional name + #:key (system (%current-system)) + (guile (default-guile))) + "Similar to 'url-fetch' but unpack the file from URL in a directory of its +own. This helper makes it easier to deal with \"tar bombs\"." + (define gzip + (module-ref (resolve-interface '(gnu packages compression)) 'gzip)) + (define tar + (module-ref (resolve-interface '(gnu packages base)) 'tar)) + + (mlet %store-monad ((drv (url-fetch url hash-algo hash + (string-append "tarbomb-" name) + #:system system + #:guile guile))) + ;; Take the tar bomb, and simply unpack it as a directory. + (gexp->derivation name + #~(begin + (mkdir #$output) + (setenv "PATH" (string-append #$gzip "/bin")) + (chdir #$output) + (zero? (system* (string-append #$tar "/bin/tar") + "xf" #$drv))) + #:local-build? #t))) + (define* (download-to-store store url #:optional (name (basename url)) #:key (log (current-error-port)) recursive?) "Download from URL to STORE, either under NAME or URL's basename if diff --git a/guix/gexp.scm b/guix/gexp.scm index 35adc179a1..87bc316f97 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +20,7 @@ #:use-module (guix store) #:use-module (guix monads) #:use-module (guix derivations) + #:use-module (guix grafts) #:use-module (guix utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 96fbfb76b4..9d720ca030 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -33,6 +33,7 @@ #:use-module (guix records) #:use-module (guix upstream) #:use-module (guix packages) + #:use-module (gnu packages) #:export (gnu-package-name gnu-package-mundane-name gnu-package-copyright-holder @@ -57,7 +58,8 @@ gnu-package-name->name+version %gnu-updater - %gnome-updater)) + %gnome-updater + %xorg-updater)) ;;; Commentary: ;;; @@ -508,6 +510,32 @@ elpa.gnu.org, and all the GNOME packages." ;; checksums. #:file->signature (const #f)))) +(define (xorg-package? package) + "Return true if PACKAGE is an X.org package, developed by X.org." + (define xorg-uri? + (match-lambda + ((? string? uri) + (string-prefix? "mirror://xorg/" uri)) + (_ + #f))) + + (match (package-source package) + ((? origin? origin) + (match (origin-uri origin) + ((? xorg-uri?) #t) + (_ #f))) + (_ #f))) + +(define (latest-xorg-release package) + "Return the latest release of PACKAGE, the name of an X.org package." + (let ((uri (string->uri (origin-uri (package-source (specification->package package)))))) + (false-if-ftp-error + (latest-ftp-release + package + #:server "ftp.freedesktop.org" + #:directory + (string-append "/pub/xorg/" (dirname (uri-path uri))))))) + (define %gnu-updater (upstream-updater (name 'gnu) @@ -522,4 +550,11 @@ elpa.gnu.org, and all the GNOME packages." (pred gnome-package?) (latest latest-gnome-release))) +(define %xorg-updater + (upstream-updater + (name 'xorg) + (description "Updater for X.org packages") + (pred xorg-package?) + (latest latest-xorg-release))) + ;;; gnu-maintenance.scm ends here diff --git a/guix/grafts.scm b/guix/grafts.scm new file mode 100644 index 0000000000..a1f7d8801a --- /dev/null +++ b/guix/grafts.scm @@ -0,0 +1,146 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014, 2015, 2016 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 grafts) + #:use-module (guix records) + #:use-module (guix derivations) + #:use-module ((guix utils) #:select (%current-system)) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:export (graft? + graft + graft-origin + graft-replacement + graft-origin-output + graft-replacement-output + + graft-derivation + + %graft? + set-grafting)) + +(define-record-type* <graft> graft make-graft + graft? + (origin graft-origin) ;derivation | store item + (origin-output graft-origin-output ;string | #f + (default "out")) + (replacement graft-replacement) ;derivation | store item + (replacement-output graft-replacement-output ;string | #f + (default "out"))) + +(define (write-graft graft port) + "Write a concise representation of GRAFT to PORT." + (define (->string thing output) + (if (derivation? thing) + (derivation->output-path thing output) + thing)) + + (match graft + (($ <graft> origin origin-output replacement replacement-output) + (format port "#<graft ~a ==> ~a ~a>" + (->string origin origin-output) + (->string replacement replacement-output) + (number->string (object-address graft) 16))))) + +(set-record-type-printer! <graft> write-graft) + +(define* (graft-derivation store drv grafts + #:key + (name (derivation-name drv)) + (guile (%guile-for-build)) + (system (%current-system))) + "Return a derivation called NAME, based on DRV but with all the GRAFTS +applied." + ;; XXX: Someday rewrite using gexps. + (define mapping + ;; List of store item pairs. + (map (match-lambda + (($ <graft> source source-output target target-output) + (cons (if (derivation? source) + (derivation->output-path source source-output) + source) + (if (derivation? target) + (derivation->output-path target target-output) + target)))) + grafts)) + + (define outputs + (match (derivation-outputs drv) + (((names . outputs) ...) + (map derivation-output-path outputs)))) + + (define output-names + (match (derivation-outputs drv) + (((names . outputs) ...) + names))) + + (define build + `(begin + (use-modules (guix build graft) + (guix build utils) + (ice-9 match)) + + (let ((mapping ',mapping)) + (for-each (lambda (input output) + (format #t "grafting '~a' -> '~a'...~%" input output) + (force-output) + (rewrite-directory input output + `((,input . ,output) + ,@mapping))) + ',outputs + (match %outputs + (((names . files) ...) + files)))))) + + (define add-label + (cut cons "x" <>)) + + (match grafts + ((($ <graft> sources source-outputs targets target-outputs) ...) + (let ((sources (zip sources source-outputs)) + (targets (zip targets target-outputs))) + (build-expression->derivation store name build + #:system system + #:guile-for-build guile + #:modules '((guix build graft) + (guix build utils)) + #:inputs `(,@(map (lambda (out) + `("x" ,drv ,out)) + output-names) + ,@(append (map add-label sources) + (map add-label targets))) + #:outputs output-names + #:local-build? #t))))) + + +;; The following might feel more at home in (guix packages) but since (guix +;; gexp), which is a lower level, needs them, we put them here. + +(define %graft? + ;; Whether to honor package grafts by default. + (make-parameter #t)) + +(define (set-grafting enable?) + "This monadic procedure enables grafting when ENABLE? is true, and disables +it otherwise. It returns the previous setting." + (lambda (store) + (values (%graft? enable?) store))) + +;;; grafts.scm ends here diff --git a/guix/http-client.scm b/guix/http-client.scm index 31b511eb1c..2161856c63 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -33,6 +33,7 @@ #:use-module (guix ui) #:use-module (guix utils) #:use-module (guix base64) + #:autoload (guix hash) (sha256) #:use-module ((guix build utils) #:select (mkdir-p dump-port)) #:use-module ((guix build download) @@ -280,18 +281,23 @@ Raise an '&http-get-error' condition if downloading fails." string->number*) 36)))) +(define (cache-file-for-uri uri) + "Return the name of the file in the cache corresponding to URI." + (let ((digest (sha256 (string->utf8 (uri->string uri))))) + ;; Use the "URL" alphabet because it does not contain "/". + (string-append (cache-directory) "/http/" + (base64-encode digest 0 (bytevector-length digest) + #f #f base64url-alphabet)))) + (define* (http-fetch/cached uri #:key (ttl (%http-cache-ttl)) text?) "Like 'http-fetch', return an input port, but cache its contents in ~/.cache/guix. The cache remains valid for TTL seconds." - (let* ((directory (string-append (cache-directory) "/http/" - (uri-host uri))) - (file (string-append directory "/" - (basename (uri-path uri))))) + (let ((file (cache-file-for-uri uri))) (define (update-cache) ;; Update the cache and return an input port. (let ((port (http-fetch uri #:text? text?))) - (mkdir-p directory) - (call-with-output-file file + (mkdir-p (dirname file)) + (with-atomic-file-output file (cut dump-port port <>)) (close-port port) (open-input-file file))) diff --git a/guix/import/gem.scm b/guix/import/gem.scm index 4b2a253130..b46622f00d 100644 --- a/guix/import/gem.scm +++ b/guix/import/gem.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson <davet@gnu.org> +;;; Copryight © 2016 Ben Woodcroft <donttrustben@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,21 +20,33 @@ (define-module (guix import gem) #:use-module (ice-9 match) #:use-module (ice-9 pretty-print) + #:use-module (srfi srfi-1) #:use-module (rnrs bytevectors) #:use-module (json) #:use-module (web uri) + #:use-module ((guix download) #:prefix download:) #:use-module (guix import utils) #:use-module (guix import json) #:use-module (guix packages) + #:use-module (guix upstream) #:use-module (guix licenses) #:use-module (guix base32) - #:export (gem->guix-package)) + #:use-module (guix build-system ruby) + #:use-module (gnu packages) + #:export (gem->guix-package + %gem-updater)) (define (rubygems-fetch name) "Return an alist representation of the RubyGems metadata for the package NAME, or #f on failure." - (json-fetch - (string-append "https://rubygems.org/api/v1/gems/" name ".json"))) + ;; XXX: We want to silence the download progress report, which is especially + ;; annoying for 'guix refresh', but we have to use a file port. + (call-with-output-file "/dev/null" + (lambda (null) + (with-error-to-port null + (lambda () + (json-fetch + (string-append "https://rubygems.org/api/v1/gems/" name ".json"))))))) (define (ruby-package-name name) "Given the NAME of a package on RubyGems, return a Guix-compliant name for @@ -132,3 +145,47 @@ VERSION, HASH, HOME-PAGE, DESCRIPTION, DEPENDENCIES, and LICENSES." (assoc-ref package "licenses")))) (make-gem-sexp name version hash home-page synopsis description dependencies licenses))))) + +(define (guix-package->gem-name package) + "Given a PACKAGE built from rubygems.org, return the name of the +package on RubyGems." + (let ((source-url (and=> (package-source package) origin-uri))) + ;; The URL has the form: + ;; 'https://rubygems.org/downloads/' + + ;; package name + '-' + version + '.gem' + ;; e.g. "https://rubygems.org/downloads/hashery-2.1.1.gem" + (substring source-url 31 (string-rindex source-url #\-)))) + +(define (gem-package? package) + "Return true if PACKAGE is a gem package from RubyGems." + + (define (rubygems-url? url) + (string-prefix? "https://rubygems.org/downloads/" url)) + + (let ((source-url (and=> (package-source package) origin-uri)) + (fetch-method (and=> (package-source package) origin-method))) + (and (eq? fetch-method download:url-fetch) + (match source-url + ((? string?) + (rubygems-url? source-url)) + ((source-url ...) + (any rubygems-url? source-url)))))) + +(define (latest-release guix-package) + "Return an <upstream-source> for the latest release of GUIX-PACKAGE." + (let* ((gem-name (guix-package->gem-name + (specification->package guix-package))) + (metadata (rubygems-fetch gem-name)) + (version (assoc-ref metadata "version")) + (url (rubygems-uri gem-name version))) + (upstream-source + (package guix-package) + (version version) + (urls (list url))))) + +(define %gem-updater + (upstream-updater + (name 'gem) + (description "Updater for RubyGem packages") + (pred gem-package?) + (latest latest-release))) diff --git a/guix/import/github.scm b/guix/import/github.scm new file mode 100644 index 0000000000..c696dcb363 --- /dev/null +++ b/guix/import/github.scm @@ -0,0 +1,198 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Ben Woodcroft <donttrustben@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 import github) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (json) + #:use-module (guix utils) + #:use-module ((guix download) #:prefix download:) + #:use-module (guix import utils) + #:use-module (guix packages) + #:use-module (guix upstream) + #:use-module (gnu packages) + #:use-module (web uri) + #:export (%github-updater)) + +(define (json-fetch* url) + "Return a list/hash representation of the JSON resource URL, or #f on +failure." + (call-with-output-file "/dev/null" + (lambda (null) + (with-error-to-port null + (lambda () + (call-with-temporary-output-file + (lambda (temp port) + (and (url-fetch url temp) + (call-with-input-file temp json->scm))))))))) + +(define (find-extension url) + "Return the extension of the archive e.g. '.tar.gz' given a URL, or +false if none is recognized" + (find (lambda x (string-suffix? (first x) url)) + (list ".tar.gz" ".tar.bz2" ".tar.xz" ".zip" ".tar"))) + +(define (updated-github-url old-package new-version) + ;; Return a url for the OLD-PACKAGE with NEW-VERSION. If no source url in + ;; the OLD-PACKAGE is a GitHub url, then return false. + + (define (updated-url url) + (if (string-prefix? "https://github.com/" url) + (let ((ext (find-extension url)) + (name (package-name old-package)) + (version (package-version old-package)) + (prefix (string-append "https://github.com/" + (github-user-slash-repository url))) + (repo (github-repository url))) + (cond + ((string-suffix? (string-append "/tarball/v" version) url) + (string-append prefix "/tarball/v" new-version)) + ((string-suffix? (string-append "/tarball/" version) url) + (string-append prefix "/tarball/" new-version)) + ((string-suffix? (string-append "/archive/v" version ext) url) + (string-append prefix "/archive/v" new-version ext)) + ((string-suffix? (string-append "/archive/" version ext) url) + (string-append prefix "/archive/" new-version ext)) + ((string-suffix? (string-append "/archive/" name "-" version ext) + url) + (string-append prefix "/archive/" name "-" new-version ext)) + ((string-suffix? (string-append "/releases/download/v" version "/" + name "-" version ext) + url) + (string-append prefix "/releases/download/v" new-version "/" name + "-" new-version ext)) + ((string-suffix? (string-append "/releases/download/" version "/" + name "-" version ext) + url) + (string-append prefix "/releases/download/" new-version "/" name + "-" new-version ext)) + ((string-suffix? (string-append "/releases/download/" version "/" + repo "-" version ext) + url) + (string-append prefix "/releases/download/" new-version "/" repo + "-" new-version ext)) + ((string-suffix? (string-append "/releases/download/" repo "-" + version "/" repo "-" version ext) + url) + (string-append "/releases/download/" repo "-" version "/" repo "-" + version ext)) + (#t #f))) ; Some URLs are not recognised. + #f)) + + (let ((source-url (and=> (package-source old-package) origin-uri)) + (fetch-method (and=> (package-source old-package) origin-method))) + (if (eq? fetch-method download:url-fetch) + (match source-url + ((? string?) + (updated-url source-url)) + ((source-url ...) + (find updated-url source-url))) + #f))) + +(define (github-package? package) + "Return true if PACKAGE is a package from GitHub, else false." + (not (eq? #f (updated-github-url package "dummy")))) + +(define (github-repository url) + "Return a string e.g. bedtools2 of the name of the repository, from a string +URL of the form 'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz'" + (match (string-split (uri-path (string->uri url)) #\/) + ((_ owner project . rest) + (string-append project)))) + +(define (github-user-slash-repository url) + "Return a string e.g. arq5x/bedtools2 of the owner and the name of the +repository separated by a forward slash, from a string URL of the form +'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz'" + (match (string-split (uri-path (string->uri url)) #\/) + ((_ owner project . rest) + (string-append owner "/" project)))) + +(define %github-token + ;; Token to be passed to Github.com to avoid the 60-request per hour + ;; limit, or #f. + (make-parameter (getenv "GUIX_GITHUB_TOKEN"))) + +(define (latest-released-version url package-name) + "Return a string of the newest released version name given a string URL like +'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz' and the name of +the package e.g. 'bedtools2'. Return #f if there is no releases" + (let* ((token (%github-token)) + (api-url (string-append + "https://api.github.com/repos/" + (github-user-slash-repository url) + "/releases")) + (json (json-fetch* + (if token + (string-append api-url "?access_token=" token) + api-url)))) + (if (eq? json #f) + (if token + (error "Error downloading release information through the GitHub +API when using a GitHub token") + (error "Error downloading release information through the GitHub +API. This may be fixed by using an access token and setting the environment +variable GUIX_GITHUB_TOKEN, for instance one procured from +https://github.com/settings/tokens")) + (let ((proper-releases + (filter + (lambda (x) + ;; example pre-release: + ;; https://github.com/wwood/OrfM/releases/tag/v0.5.1 + ;; or an all-prerelease set + ;; https://github.com/powertab/powertabeditor/releases + (not (hash-ref x "prerelease"))) + json))) + (match proper-releases + (() ;empty release list + #f) + ((release . rest) ;one or more releases + (let ((tag (hash-ref release "tag_name")) + (name-length (string-length package-name))) + ;; some tags include the name of the package e.g. "fdupes-1.51" + ;; so remove these + (if (and (< name-length (string-length tag)) + (string=? (string-append package-name "-") + (substring tag 0 (+ name-length 1)))) + (substring tag (+ name-length 1)) + ;; some tags start with a "v" e.g. "v0.25.0" + ;; where some are just the version number + (if (eq? (string-ref tag 0) #\v) + (substring tag 1) tag))))))))) + +(define (latest-release guix-package) + "Return an <upstream-source> for the latest release of GUIX-PACKAGE." + (let* ((pkg (specification->package guix-package)) + (source-uri (origin-uri (package-source pkg))) + (name (package-name pkg)) + (newest-version (latest-released-version source-uri name))) + (if newest-version + (upstream-source + (package pkg) + (version newest-version) + (urls (list (updated-github-url pkg newest-version)))) + #f))) ; On GitHub but no proper releases + +(define %github-updater + (upstream-updater + (name 'github) + (description "Updater for GitHub packages") + (pred github-package?) + (latest latest-release))) + + diff --git a/guix/licenses.scm b/guix/licenses.scm index a43ab438f1..61e679358a 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -7,6 +7,7 @@ ;;; Copyright © 2016 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2016 Leo Famulari <leo@famulari.name> ;;; Copyright © 2016 Fabian Harfert <fhmgufs@web.de> +;;; Copyright © 2016 Rene Saavedra <rennes@openmailbox.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,7 +34,7 @@ non-copyleft bsd-style ;deprecated! cc0 - cc-by-sa4.0 cc-by-sa3.0 cc-by3.0 + cc-by2.0 cc-by3.0 cc-by-sa2.0 cc-by-sa3.0 cc-by-sa4.0 cddl1.0 cecill-c artistic2.0 clarified-artistic @@ -59,10 +60,12 @@ openldap2.8 openssl psfl public-domain qpl + repoze ruby sgifreeb2.0 silofl1.1 sleepycat + tcl/tk unlicense vim x11 x11-style @@ -154,11 +157,21 @@ at URI, which may be a file:// URI pointing the package's tree." "http://creativecommons.org/licenses/by-sa/3.0/" "Creative Commons Attribution-ShareAlike 3.0 Unported")) +(define cc-by-sa2.0 + (license "CC-BY-SA 2.0" + "http://creativecommons.org/licenses/by-sa/2.0/" + "Creative Commons Attribution-ShareAlike 2.0 Generic")) + (define cc-by3.0 (license "CC-BY 3.0" "http://creativecommons.org/licenses/by/3.0/" "Creative Commons Attribution 3.0 Unported")) +(define cc-by2.0 + (license "CC-BY 2.0" + "http://creativecommons.org/licenses/by/2.0/" + "Creative Commons Attribution 2.0 Generic")) + (define cddl1.0 (license "CDDL 1.0" "http://directory.fsf.org/wiki/License:CDDLv1.0" @@ -368,6 +381,12 @@ at URI, which may be a file:// URI pointing the package's tree." "http://directory.fsf.org/wiki/License:QPLv1.0" "http://www.gnu.org/licenses/license-list.html#QPL")) +(define repoze + (license "Repoze" + "http://repoze.org/LICENSE.txt" + "A BSD-like license with a clause requiring all changes to be + attributed by author and date.")) + (define ruby (license "Ruby License" "http://directory.fsf.org/wiki/License:Ruby" @@ -388,6 +407,11 @@ at URI, which may be a file:// URI pointing the package's tree." "http://directory.fsf.org/wiki/License:Sleepycat" "https://www.gnu.org/licenses/license-list#BerkeleyDB")) +(define tcl/tk + (license "Tcl/Tk" + "http://www.tcl.tk/software/tcltk/license.html" + "A non-copyleft free software license from the Tcl/Tk project")) + (define vim (license "Vim" "http://directory.fsf.org/wiki/License:Vim7.2" diff --git a/guix/packages.scm b/guix/packages.scm index 6ec168c204..f6afaeb510 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org> ;;; @@ -25,6 +25,7 @@ #:use-module (guix monads) #:use-module (guix gexp) #:use-module (guix base32) + #:use-module (guix grafts) #:use-module (guix derivations) #:use-module (guix build-system) #:use-module (guix search-paths) @@ -984,7 +985,7 @@ This is an internal procedure." (grafts (let ((guile (package-derivation store (default-guile) system #:graft? #f))) - (graft-derivation store (bag-name bag) drv grafts + (graft-derivation store drv grafts #:system system #:guile guile)))) drv)))) @@ -1002,7 +1003,7 @@ system identifying string)." (() drv) (grafts - (graft-derivation store (bag-name bag) drv grafts + (graft-derivation store drv grafts #:system system #:guile (package-derivation store (default-guile) diff --git a/guix/profiles.scm b/guix/profiles.scm index ce86ff8e0a..1c53c8047a 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> @@ -694,11 +694,15 @@ creates the GTK+ 'icon-theme.cache' file for each theme." (define* (profile-derivation manifest #:key - (hooks %default-profile-hooks)) + (hooks %default-profile-hooks) + system) "Return a derivation that builds a profile (aka. 'user environment') with the given MANIFEST. The profile includes additional derivations returned by the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc." - (mlet %store-monad ((extras (if (null? (manifest-entries manifest)) + (mlet %store-monad ((system (if system + (return system) + (current-system))) + (extras (if (null? (manifest-entries manifest)) (return '()) (sequence %store-monad (map (lambda (hook) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index aa9c105f58..8725ddad88 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -23,6 +23,7 @@ #:use-module (guix store) #:use-module (guix derivations) #:use-module (guix packages) + #:use-module (guix grafts) #:use-module (guix utils) #:use-module (guix monads) #:use-module (guix gexp) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 2cc5f366a7..0e462de4bf 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -35,6 +35,9 @@ #:use-module (gnu system file-systems) #:use-module (gnu packages) #:use-module (gnu packages bash) + #:use-module (gnu packages commencement) + #:use-module (gnu packages guile) + #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) @@ -45,19 +48,10 @@ #:use-module (srfi srfi-98) #:export (guix-environment)) -(define (evaluate-input-search-paths inputs search-paths) +(define (evaluate-profile-search-paths profile search-paths) "Evaluate SEARCH-PATHS, a list of search-path specifications, for the -directories corresponding to INPUTS, a list of (DERIVATION) or (DERIVATION -OUTPUT) tuples." - (let ((directories (map (match-lambda - (((? derivation? drv)) - (derivation->output-path drv)) - (((? derivation? drv) output) - (derivation->output-path drv output)) - (((? string? item)) - item)) - inputs))) - (evaluate-search-paths search-paths directories))) +directories in PROFILE, the store path of a profile." + (evaluate-search-paths search-paths (list profile))) ;; Protect some env vars from purification. Borrowed from nix-shell. (define %precious-variables @@ -81,11 +75,10 @@ as 'HOME' and 'USER' are left untouched." (((names . _) ...) names))))) -(define (create-environment inputs paths pure?) - "Set the environment variables specified by PATHS for all the packages -within INPUTS. When PURE? is #t, unset the variables in the current -environment. Otherwise, augment existing enviroment variables with additional -search paths." +(define (create-environment profile paths pure?) + "Set the environment variables specified by PATHS for PROFILE. When PURE? +is #t, unset the variables in the current environment. Otherwise, augment +existing enviroment variables with additional search paths." (when pure? (purify-environment)) (for-each (match-lambda ((($ <search-path-specification> variable _ separator) . value) @@ -94,15 +87,14 @@ search paths." (if (and current (not pure?)) (string-append value separator current) value))))) - (evaluate-input-search-paths inputs paths)) + (evaluate-profile-search-paths profile paths)) ;; Give users a way to know that they're in 'guix environment', so they can ;; adjust 'PS1' accordingly, for instance. (setenv "GUIX_ENVIRONMENT" "t")) -(define (show-search-paths inputs search-paths pure?) - "Display SEARCH-PATHS applied to the packages specified by INPUTS, a list of - (DERIVATION) or (DERIVATION OUTPUT) tuples. When PURE? is #t, do not augment +(define (show-search-paths profile search-paths pure?) + "Display SEARCH-PATHS applied to PROFILE. When PURE? is #t, do not augment existing environment variables with additional search paths." (for-each (match-lambda ((search-path . value) @@ -110,12 +102,37 @@ existing environment variables with additional search paths." (search-path-definition search-path value #:kind (if pure? 'exact 'prefix))) (newline))) - (evaluate-input-search-paths inputs search-paths))) + (evaluate-profile-search-paths profile search-paths))) + +(define (strip-input-name input) + "Remove the name element from the tuple INPUT." + (match input + ((_ package) package) + ((_ package output) + (list package output)))) (define (package+propagated-inputs package output) "Return the union of PACKAGE's OUTPUT and its transitive propagated inputs." - `((,(package-name package) ,package ,output) - ,@(package-transitive-propagated-inputs package))) + (cons (list package output) + (map strip-input-name + (package-transitive-propagated-inputs package)))) + +(define (package-or-package+output? expr) + "Return #t if EXPR is a package or a 2 element list consisting of a package +and an output string." + (match expr + ((or (? package?) ; bare package object + ((? package?) (? string?))) ; package+output tuple + #t) + (_ #f))) + +(define (package-environment-inputs package) + "Return a list of the transitive input packages for PACKAGE." + ;; Remove non-package inputs such as origin records. + (filter package-or-package+output? + (map strip-input-name + (bag-transitive-inputs + (package->bag package))))) (define (show-help) (display (_ "Usage: guix environment [OPTION]... PACKAGE... [-- COMMAND...] @@ -252,17 +269,19 @@ COMMAND or an interactive shell in that environment.\n")) (define (options/resolve-packages opts) "Return OPTS with package specification strings replaced by actual packages." - (define (package->outputs package mode) - (map (lambda (output) - (list mode package output)) - (package-outputs package))) + (define (package->output package mode) + (match package + ((? package?) + (list mode package "out")) + (((? package? package) (? string? output)) + (list mode package output)))) (define (packages->outputs packages mode) (match packages - ((? package? package) - (package->outputs package mode)) - (((? package? packages) ...) - (append-map (cut package->outputs <> mode) packages)))) + ((? package-or-package+output? package) ; single package + (list (package->output package mode))) + (((? package-or-package+output?) ...) ; many packages + (map (cut package->output <> mode) packages)))) (compact (append-map (match-lambda @@ -280,22 +299,30 @@ packages." (_ '(#f))) opts))) -(define (build-inputs inputs opts) - "Build the derivations in INPUTS, a list of (DERIVATION) or (DERIVATION -OUTPUT) tuples, using the build options in OPTS." +(define* (build-environment derivations opts) + "Build the DERIVATIONS required by the environment using the build options +in OPTS." (let ((substitutes? (assoc-ref opts 'substitutes?)) (dry-run? (assoc-ref opts 'dry-run?))) - (match inputs - (((derivations _ ...) ...) - (mbegin %store-monad - (show-what-to-build* derivations - #:use-substitutes? substitutes? - #:dry-run? dry-run?) - (if dry-run? - (return #f) - (mbegin %store-monad - (built-derivations derivations) - (return derivations)))))))) + (mbegin %store-monad + (show-what-to-build* derivations + #:use-substitutes? substitutes? + #:dry-run? dry-run?) + (if dry-run? + (return #f) + (mbegin %store-monad + (set-build-options-from-command-line* opts) + (built-derivations derivations)))))) + +(define (inputs->profile-derivation inputs system bootstrap?) + "Return the derivation for a profile consisting of INPUTS for SYSTEM. +BOOTSTRAP? specifies whether to use the bootstrap Guile to build the +profile." + (profile-derivation (packages->manifest inputs) + #:system system + #:hooks (if bootstrap? + '() + %default-profile-hooks))) (define requisites* (store-lift requisites)) @@ -334,16 +361,15 @@ variables are cleared before setting the new ones." (apply system* command)) (define* (launch-environment/container #:key command bash user-mappings - inputs paths network?) - "Run COMMAND within a Linux container. The environment features INPUTS, a -list of derivations to be shared from the host system. Environment variables -are set according to PATHS, a list of native search paths. The global shell -is BASH, a file name for a GNU Bash binary in the store. When NETWORK?, -access to the host system network is permitted. USER-MAPPINGS, a list of file -system mappings, contains the user-specified host file systems to mount inside -the container." + profile paths network?) + "Run COMMAND within a container that features the software in PROFILE. +Environment variables are set according to PATHS, a list of native search +paths. The global shell is BASH, a file name for a GNU Bash binary in the +store. When NETWORK?, access to the host system network is permitted. +USER-MAPPINGS, a list of file system mappings, contains the user-specified +host file systems to mount inside the container." (mlet %store-monad ((reqs (inputs->requisites - (cons (direct-store-path bash) inputs)))) + (list (direct-store-path bash) profile)))) (return (let* ((cwd (getcwd)) ;; Bind-mount all requisite store items, user-specified mappings, @@ -408,7 +434,7 @@ the container." (primitive-exit/status ;; A container's environment is already purified, so no need to ;; request it be purified again. - (launch-environment command inputs paths #f))) + (launch-environment command profile paths #f))) #:namespaces (if network? (delq 'net %namespaces) ; share host network %namespaces))))))) @@ -482,64 +508,65 @@ message if any test fails." (('ad-hoc-package package output) (package+propagated-inputs package output)) - (('package package output) - (bag-transitive-inputs - (package->bag package)))) + (('package package _) + (package-environment-inputs package))) packages))) (paths (delete-duplicates (cons $PATH (append-map (match-lambda - ((label (? package? p) _ ...) - (package-native-search-paths p)) - (_ - '())) + ((or ((? package? p) _ ...) + (? package? p)) + (package-native-search-paths p)) + (_ '())) inputs)) eq?))) (when container? (assert-container-features)) (with-store store - (set-build-options-from-command-line store opts) - (run-with-store store - (mlet* %store-monad ((inputs (lower-inputs - (map (match-lambda - ((label item) - (list item)) - ((label item output) - (list item output))) - inputs) - #:system system)) - ;; Containers need a Bourne shell at /bin/sh. - (bash (environment-bash container? - bootstrap? - system))) - (mbegin %store-monad + ;; Use the bootstrap Guile when requested. + (parameterize ((%guile-for-build + (package-derivation + store + (if bootstrap? + %bootstrap-guile + (canonical-package guile-2.0))))) + (set-build-options-from-command-line store opts) + (run-with-store store + ;; Containers need a Bourne shell at /bin/sh. + (mlet* %store-monad ((bash (environment-bash container? + bootstrap? + system)) + (prof-drv (inputs->profile-derivation + inputs system bootstrap?)) + (profile -> (derivation->output-path prof-drv))) ;; First build the inputs. This is necessary even for - ;; --search-paths. Additionally, we might need to build bash - ;; for a container. - (build-inputs (if (derivation? bash) - `((,bash "out") ,@inputs) - inputs) - opts) - (cond - ((assoc-ref opts 'dry-run?) - (return #t)) - ((assoc-ref opts 'search-paths) - (show-search-paths inputs paths pure?) - (return #t)) - (container? - (let ((bash-binary - (if bootstrap? - bash - (string-append (derivation->output-path bash) - "/bin/sh")))) - (launch-environment/container #:command command - #:bash bash-binary - #:user-mappings mappings - #:inputs inputs - #:paths paths - #:network? network?))) - (else - (return - (exit/status - (launch-environment command inputs paths pure?)))))))))))) + ;; --search-paths. Additionally, we might need to build bash for + ;; a container. + (mbegin %store-monad + (build-environment (if (derivation? bash) + (list prof-drv bash) + (list prof-drv)) + opts) + (cond + ((assoc-ref opts 'dry-run?) + (return #t)) + ((assoc-ref opts 'search-paths) + (show-search-paths profile paths pure?) + (return #t)) + (container? + (let ((bash-binary + (if bootstrap? + bash + (string-append (derivation->output-path bash) + "/bin/sh")))) + (launch-environment/container #:command command + #:bash bash-binary + #:user-mappings mappings + #:profile profile + #:paths paths + #:network? network?))) + (else + (return + (exit/status + (launch-environment command profile paths pure?))))))))))))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index b93ffb0b6b..f65834386b 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org> -;;; Copyright © 2014 Alex Kost <alezost@gmail.com> +;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -551,10 +551,6 @@ upgrading, #f otherwise." (define (options->installable opts manifest) "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold', return the new list of manifest entries." - (define (package->manifest-entry* package output) - (check-package-freshness package) - (package->manifest-entry package output)) - (define upgrade? (options->upgrade-predicate opts)) @@ -567,7 +563,7 @@ return the new list of manifest entries." (call-with-values (lambda () (specification->package+output name output)) - package->manifest-entry*)))) + package->manifest-entry)))) (_ #f)) (manifest-entries manifest))) @@ -576,13 +572,13 @@ return the new list of manifest entries." (('install . (? package? p)) ;; When given a package via `-e', install the first of its ;; outputs (XXX). - (package->manifest-entry* p "out")) + (package->manifest-entry p "out")) (('install . (? string? spec)) (if (store-path? spec) (store-item->manifest-entry spec) (let-values (((package output) (specification->package+output spec))) - (package->manifest-entry* package output)))) + (package->manifest-entry package output)))) (_ #f)) opts)) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index fb7b4218e0..46292131d7 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson <davet@gnu.org> -;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -142,10 +142,11 @@ Publish ~a over HTTP.\n") %store-directory) (define base64-encode-string (compose base64-encode string->utf8)) -(define (narinfo-string store-path path-info key) - "Generate a narinfo key/value string for STORE-PATH using the details in -PATH-INFO. The narinfo is signed with KEY." - (let* ((url (string-append "nar/" (basename store-path))) +(define (narinfo-string store store-path key) + "Generate a narinfo key/value string for STORE-PATH; an exception is raised +if STORE-PATH is invalid. The narinfo is signed with KEY." + (let* ((path-info (query-path-info store store-path)) + (url (string-append "nar/" (basename store-path))) (hash (bytevector->nix-base32-string (path-info-hash path-info))) (size (path-info-nar-size path-info)) @@ -163,7 +164,7 @@ References: ~a~%" store-path url hash size references)) ;; Do not render a "Deriver" or "System" line if we are rendering ;; info for a derivation. - (info (if (string-null? deriver) + (info (if (not deriver) base-info (catch 'system-error (lambda () @@ -199,23 +200,21 @@ References: ~a~%" (define (render-narinfo store request hash) "Render metadata for the store path corresponding to HASH." - (let* ((store-path (hash-part->path store hash)) - (path-info (and (not (string-null? store-path)) - (query-path-info store store-path)))) - (if path-info + (let ((store-path (hash-part->path store hash))) + (if (string-null? store-path) + (not-found request) (values '((content-type . (application/x-nix-narinfo))) (cut display - (narinfo-string store-path path-info (force %private-key)) - <>)) - (not-found request)))) + (narinfo-string store store-path (force %private-key)) + <>))))) -(define (render-nar request store-item) +(define (render-nar store request store-item) "Render archive of the store path corresponding to STORE-ITEM." (let ((store-path (string-append %store-directory "/" store-item))) ;; The ISO-8859-1 charset *must* be used otherwise HTTP clients will ;; interpret the byte stream as UTF-8 and arbitrarily change invalid byte ;; sequences. - (if (file-exists? store-path) + (if (valid-path? store store-path) (values '((content-type . (application/x-nix-archive (charset . "ISO-8859-1")))) ;; XXX: We're not returning the actual contents, deferring @@ -315,7 +314,7 @@ blocking." (render-narinfo store request hash)) ;; /nar/<store-item> (("nar" store-item) - (render-nar request store-item)) + (render-nar store request store-item)) (_ (not-found request))) (not-found request)))) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index f9e3f31a03..e541138682 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -1,8 +1,9 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> +;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -31,7 +32,7 @@ #:use-module (guix scripts graph) #:use-module (guix monads) #:use-module ((guix gnu-maintenance) - #:select (%gnu-updater %gnome-updater)) + #:select (%gnu-updater %gnome-updater %xorg-updater)) #:use-module (guix import elpa) #:use-module (guix import cran) #:use-module (guix gnupg) @@ -193,10 +194,13 @@ unavailable optional dependencies such as Guile-JSON." ;; List of "updaters" used by default. They are consulted in this order. (list-updaters %gnu-updater %gnome-updater + %xorg-updater %elpa-updater %cran-updater %bioconductor-updater - ((guix import pypi) => %pypi-updater))) + ((guix import pypi) => %pypi-updater) + ((guix import gem) => %gem-updater) + ((guix import github) => %github-updater))) (define (lookup-updater name) "Return the updater called NAME." diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 7279be0c43..401aa8b60a 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -211,6 +211,19 @@ the ownership of '~a' may be incorrect!~%") (lambda () (environ env))))) +(define-syntax-rule (save-load-path-excursion body ...) + "Save the current values of '%load-path' and '%load-compiled-path', run +BODY..., and restore them." + (let ((path %load-path) + (cpath %load-compiled-path)) + (dynamic-wind + (const #t) + (lambda () + body ...) + (lambda () + (set! %load-path path) + (set! %load-compiled-path cpath))))) + (define-syntax-rule (warn-on-system-error body ...) (catch 'system-error (lambda () @@ -273,6 +286,9 @@ bring the system down." (info (_ "loading new services:~{ ~a~}...~%") to-load-names) (mlet %store-monad ((files (mapm %store-monad shepherd-service-file to-load))) + ;; Here we assume that FILES are exactly those that were computed + ;; as part of the derivation that built OS, which is normally the + ;; case. (load-services (map derivation->output-path files)) (for-each start-service @@ -299,7 +315,12 @@ it atomically, and then run OS's activation script." ;; Tell 'activate-current-system' what the new system is. (setenv "GUIX_NEW_SYSTEM" system) - (primitive-load (derivation->output-path script))) + ;; The activation script may modify '%load-path' & co., so protect + ;; against that. This is necessary to ensure that + ;; 'upgrade-shepherd-services' gets to see the right modules when it + ;; computes derivations with (gexp->derivation #:modules …). + (save-load-path-excursion + (primitive-load (derivation->output-path script)))) ;; Finally, try to update system services. (upgrade-shepherd-services os)))) diff --git a/guix/store.scm b/guix/store.scm index 3c4d1c0058..8746d3c2d6 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -118,6 +118,8 @@ store-lower run-with-store %guile-for-build + current-system + set-current-system text-file interned-file @@ -240,14 +242,16 @@ (define-record-type <path-info> (path-info deriver hash references registration-time nar-size) path-info? - (deriver path-info-deriver) + (deriver path-info-deriver) ;string | #f (hash path-info-hash) (references path-info-references) (registration-time path-info-registration-time) (nar-size path-info-nar-size)) (define (read-path-info p) - (let ((deriver (read-store-path p)) + (let ((deriver (match (read-store-path p) + ("" #f) + (x x))) (hash (base16-string->bytevector (read-string p))) (refs (read-store-path-list p)) (registration-time (read-int p)) @@ -580,7 +584,12 @@ encoding conversion errors." (operation (name args ...) docstring return ...))) (define-operation (valid-path? (string path)) - "Return #t when PATH is a valid store path." + "Return #t when PATH designates a valid store item and #f otherwise (an +invalid item may exist on disk but still be invalid, for instance because it +is the result of an aborted or failed build.) + +A '&nix-protocol-error' condition is raised if PATH is not prefixed by the +store directory (/gnu/store)." boolean) (define-operation (query-path-hash (store-path path)) @@ -1040,6 +1049,18 @@ permission bits are kept." (define set-build-options* (store-lift set-build-options)) +(define-inlinable (current-system) + ;; Consult the %CURRENT-SYSTEM fluid at bind time. This is equivalent to + ;; (lift0 %current-system %store-monad), but inlinable, thus avoiding + ;; closure allocation in some cases. + (lambda (state) + (values (%current-system) state))) + +(define-inlinable (set-current-system system) + ;; Set the %CURRENT-SYSTEM fluid at bind time. + (lambda (state) + (values (%current-system system) state))) + (define %guile-for-build ;; The derivation of the Guile to be used within the build environment, ;; when using 'gexp->derivation' and co. |