summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/r.scm9
-rw-r--r--guix/gexp.scm66
-rw-r--r--guix/http-client.scm15
-rw-r--r--guix/import/cran.scm9
-rw-r--r--guix/licenses.scm7
-rw-r--r--guix/packages.scm12
-rw-r--r--guix/profiles.scm4
-rw-r--r--guix/scripts/build.scm17
-rw-r--r--guix/scripts/graph.scm8
-rw-r--r--guix/scripts/lint.scm1
-rw-r--r--guix/scripts/package.scm2
11 files changed, 118 insertions, 32 deletions
diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm
index da06cb1358..a8ca354227 100644
--- a/guix/build-system/r.scm
+++ b/guix/build-system/r.scm
@@ -29,7 +29,8 @@
#:export (%r-build-system-modules
r-build
r-build-system
- cran-uri))
+ cran-uri
+ bioconductor-uri))
;; Commentary:
;;
@@ -46,6 +47,12 @@ available via the first URI, the second URI points to the archived version."
(string-append "mirror://cran/src/contrib/Archive/"
name "/" name "_" version ".tar.gz")))
+(define (bioconductor-uri name version)
+ "Return a URI string for the R package archive on Bioconductor for the
+release corresponding to NAME and VERSION."
+ (string-append "http://bioconductor.org/packages/release/bioc/src/contrib/"
+ name "_" version ".tar.gz"))
+
(define %r-build-system-modules
;; Build-side modules imported by default.
`((guix build r-build-system)
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 14ced747b2..35adc179a1 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -35,6 +35,7 @@
local-file
local-file?
local-file-file
+ local-file-absolute-file-name
local-file-name
local-file-recursive?
@@ -182,35 +183,76 @@ cross-compiling.)"
;;; File declarations.
;;;
+;; A local file name. FILE is the file name the user entered, which can be a
+;; relative file name, and ABSOLUTE is a promise that computes its canonical
+;; absolute file name. We keep it in a promise to compute it lazily and avoid
+;; repeated 'stat' calls.
(define-record-type <local-file>
- (%local-file file name recursive?)
+ (%%local-file file absolute name recursive?)
local-file?
(file local-file-file) ;string
+ (absolute %local-file-absolute-file-name) ;promise string
(name local-file-name) ;string
(recursive? local-file-recursive?)) ;Boolean
-(define* (local-file file #:optional (name (basename file))
- #:key recursive?)
+(define* (%local-file file promise #:optional (name (basename file))
+ #:key recursive?)
+ ;; This intermediate procedure is part of our ABI, but the underlying
+ ;; %%LOCAL-FILE is not.
+ (%%local-file file promise name recursive?))
+
+(define (extract-directory properties)
+ "Extract the directory name from source location PROPERTIES."
+ (match (assq 'filename properties)
+ (('filename . (? string? file-name))
+ (dirname file-name))
+ (_
+ #f)))
+
+(define-syntax-rule (current-source-directory)
+ "Expand to the directory of the current source file or #f if it could not
+be determined."
+ (extract-directory (current-source-location)))
+
+(define (absolute-file-name file directory)
+ "Return the canonical absolute file name for FILE, which lives in the
+vicinity of DIRECTORY."
+ (canonicalize-path
+ (cond ((string-prefix? "/" file) file)
+ ((not directory) file)
+ ((string-prefix? "/" directory)
+ (string-append directory "/" file))
+ (else file))))
+
+(define-syntax-rule (local-file file rest ...)
"Return an object representing local file FILE to add to the store; this
-object can be used in a gexp. FILE will be added to the store under NAME--by
-default the base name of FILE.
+object can be used in a gexp. If FILE is a relative file name, it is looked
+up relative to the source file where this form appears. FILE will be added to
+the store under NAME--by default the base name of FILE.
When RECURSIVE? is true, the contents of FILE are added recursively; if FILE
designates a flat file and RECURSIVE? is true, its contents are added, and its
permission bits are kept.
This is the declarative counterpart of the 'interned-file' monadic procedure."
- ;; Canonicalize FILE so that if it's a symlink, it is resolved. Failing to
- ;; do that, when RECURSIVE? is #t, we could end up creating a dangling
- ;; symlink in the store, and when RECURSIVE? is #f 'add-to-store' would just
- ;; throw an error, both of which are inconvenient.
- (%local-file (canonicalize-path file) name recursive?))
+ (%local-file file
+ (delay (absolute-file-name file (current-source-directory)))
+ rest ...))
+
+(define (local-file-absolute-file-name file)
+ "Return the absolute file name for FILE, a <local-file> instance. A
+'system-error' exception is raised if FILE could not be found."
+ (force (%local-file-absolute-file-name file)))
(define-gexp-compiler (local-file-compiler (file local-file?) system target)
;; "Compile" FILE by adding it to the store.
(match file
- (($ <local-file> file name recursive?)
- (interned-file file name #:recursive? recursive?))))
+ (($ <local-file> file (= force absolute) name recursive?)
+ ;; Canonicalize FILE so that if it's a symlink, it is resolved. Failing
+ ;; to do that, when RECURSIVE? is #t, we could end up creating a dangling
+ ;; symlink in the store, and when RECURSIVE? is #f 'add-to-store' would
+ ;; just throw an error, both of which are inconvenient.
+ (interned-file absolute name #:recursive? recursive?))))
(define-record-type <plain-file>
(%plain-file name content references)
diff --git a/guix/http-client.scm b/guix/http-client.scm
index eb2c3f4d5f..c7cbc82aac 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -32,6 +32,7 @@
#:use-module (rnrs bytevectors)
#:use-module (guix ui)
#:use-module (guix utils)
+ #:use-module (guix base64)
#:use-module ((guix build utils)
#:select (mkdir-p dump-port))
#:use-module ((guix build download)
@@ -210,15 +211,23 @@ Raise an '&http-get-error' condition if downloading fails."
(let loop ((uri (if (string? uri)
(string->uri uri)
uri)))
- (let ((port (or port (open-connection-for-uri uri))))
+ (let ((port (or port (open-connection-for-uri uri)))
+ (auth-header (match (uri-userinfo uri)
+ ((? string? str)
+ (list (cons 'Authorization
+ (string-append "Basic "
+ (base64-encode
+ (string->utf8 str))))))
+ (_ '()))))
(unless buffered?
(setvbuf port _IONBF))
(let*-values (((resp data)
;; Try hard to use the API du jour to get an input port.
(if (guile-version>? "2.0.7")
- (http-get uri #:streaming? #t #:port port) ; 2.0.9+
+ (http-get uri #:streaming? #t #:port port
+ #:headers auth-header) ; 2.0.9+
(http-get* uri #:decode-body? text? ; 2.0.7
- #:port port)))
+ #:port port #:headers auth-header)))
((code)
(response-code resp)))
(case code
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index 845ecb5832..45c679cbe2 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -128,9 +128,12 @@ empty list when the FIELD cannot be found."
#f "( *\\([^\\)]+\\)) *"
value 'pre 'post)
#\,)))
- ;; When there is whitespace inside of items it is probably because
- ;; this was not an actual list to begin with.
- (remove (cut string-any char-set:whitespace <>)
+ (remove (lambda (item)
+ (or (string-null? item)
+ ;; When there is whitespace inside of items it is
+ ;; probably because this was not an actual list to
+ ;; begin with.
+ (string-any char-set:whitespace item)))
(map string-trim-both items))))))
(define (beautify-description description)
diff --git a/guix/licenses.scm b/guix/licenses.scm
index 7e05b32993..9ace7f543b 100644
--- a/guix/licenses.scm
+++ b/guix/licenses.scm
@@ -30,7 +30,7 @@
non-copyleft
bsd-style ;deprecated!
cc0
- cc-by-sa4.0 cc-by3.0
+ cc-by-sa4.0 cc-by-sa3.0 cc-by3.0
cddl1.0
cecill-c
artistic2.0 clarified-artistic
@@ -144,6 +144,11 @@ at URI, which may be a file:// URI pointing the package's tree."
"http://creativecommons.org/licenses/by-sa/4.0/"
"Creative Commons Attribution-ShareAlike 4.0 International"))
+(define cc-by-sa3.0
+ (license "CC-BY-SA 3.0"
+ "http://creativecommons.org/licenses/by-sa/3.0/"
+ "Creative Commons Attribution-ShareAlike 3.0 Unported"))
+
(define cc-by3.0
(license "CC-BY 3.0"
"http://creativecommons.org/licenses/by/3.0/"
diff --git a/guix/packages.scm b/guix/packages.scm
index 68fb0916d8..41f3e20c41 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -89,6 +89,7 @@
package-transitive-target-inputs
package-transitive-native-inputs
package-transitive-propagated-inputs
+ package-transitive-native-search-paths
package-transitive-supported-systems
package-source-derivation
package-derivation
@@ -632,6 +633,17 @@ for the host system (\"native inputs\"), and not target inputs."
recursively."
(transitive-inputs (package-propagated-inputs package)))
+(define (package-transitive-native-search-paths package)
+ "Return the list of search paths for PACKAGE and its propagated inputs,
+recursively."
+ (append (package-native-search-paths package)
+ (append-map (match-lambda
+ ((label (? package? p) _ ...)
+ (package-native-search-paths p))
+ (_
+ '()))
+ (package-transitive-propagated-inputs package))))
+
(define (transitive-input-references alist inputs)
"Return a list of (assoc-ref ALIST <label>) for each (<label> <package> . _)
in INPUTS and their transitive propagated inputs."
diff --git a/guix/profiles.scm b/guix/profiles.scm
index c222f4115d..ce86ff8e0a 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -176,7 +176,7 @@ omitted or #f, use the first output of PACKAGE."
(output (or output (car (package-outputs package))))
(item package)
(dependencies (delete-duplicates deps))
- (search-paths (package-native-search-paths package)))))
+ (search-paths (package-transitive-native-search-paths package)))))
(define (packages->manifest packages)
"Return a list of manifest entries, one for each item listed in PACKAGES.
@@ -469,7 +469,7 @@ MANIFEST."
(define (install-info info)
(setenv "PATH" (string-append #+gzip "/bin")) ;for info.gz files
(zero?
- (system* (string-append #+texinfo "/bin/install-info")
+ (system* (string-append #+texinfo "/bin/install-info") "--silent"
info (string-append #$output "/share/info/dir"))))
(mkdir-p (string-append #$output "/share/info"))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 8ecd9560ed..9193ad32b2 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -204,6 +204,7 @@ options handled by 'set-build-options-from-command-line', and listed in
(lambda (opt name arg result . rest)
;; XXX: Imperatively modify the search paths.
(%package-module-path (cons arg (%package-module-path)))
+ (%patch-path (cons arg (%patch-path)))
(set! %load-path (cons arg %load-path))
(set! %load-compiled-path (cons arg %load-compiled-path))
@@ -404,10 +405,16 @@ must be one of 'package', 'all', or 'transitive'~%")
(define (options->things-to-build opts)
"Read the arguments from OPTS and return a list of high-level objects to
build---packages, gexps, derivations, and so on."
- (define ensure-list
- (match-lambda
- ((x ...) x)
- (x (list x))))
+ (define (validate-type x)
+ (unless (or (package? x) (derivation? x) (gexp? x) (procedure? x))
+ (leave (_ "~s: not something we can build~%") x)))
+
+ (define (ensure-list x)
+ (let ((lst (match x
+ ((x ...) x)
+ (x (list x)))))
+ (for-each validate-type lst)
+ lst))
(append-map (match-lambda
(('argument . (? string? spec))
@@ -424,8 +431,6 @@ build---packages, gexps, derivations, and so on."
(ensure-list (read/eval str)))
(('argument . (? derivation? drv))
drv)
- (('argument . (? derivation-path? drv))
- (list ))
(_ '()))
opts))
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 9255f0018a..dcc4701779 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -113,7 +113,7 @@ Dependencies may include packages, origin, and file names."
(((labels things . outputs) ...)
things)))
((origin? thing)
- (cons (origin-patch-guile thing)
+ (cons (or (origin-patch-guile thing) (default-guile))
(if (or (pair? (origin-patches thing))
(origin-snippet thing))
(match (origin-patch-inputs thing)
@@ -171,7 +171,9 @@ GNU-BUILD-SYSTEM have zero dependencies."
(description "same as 'bag', but without the bootstrap nodes")
(identifier bag-node-identifier)
(label node-full-name)
- (edges (lift1 bag-node-edges-sans-bootstrap %store-monad))))
+ (edges (lift1 (compose (cut filter package? <>)
+ bag-node-edges-sans-bootstrap)
+ %store-monad))))
;;;
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 338c7e827d..f296f8a00e 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -587,6 +587,7 @@ be determined."
Common Platform Enumeration (CPE) name."
(match name
("icecat" "firefox") ;or "firefox_esr"
+ ("grub" "grub2")
;; TODO: Add more.
(_ name)))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index c62daee9a7..d0b5abd0e2 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -151,7 +151,7 @@ GENERATIONS is a list of generation numbers."
"Delete from PROFILE all the generations matching PATTERN. PATTERN must be
a string denoting a set of generations: the empty list means \"all generations
but the current one\", a number designates a generation, and other patterns
-denote ranges as interpreted by 'matching-derivations'."
+denote ranges as interpreted by 'matching-generations'."
(let ((current (generation-number profile)))
(cond ((not (file-exists? profile)) ; XXX: race condition
(raise (condition (&profile-not-found-error
generated by cgit v1.2.3 (git 2.46.2) at 2024-11-11 23:45:50 +0000