From 35a6dabcf1386fa33539a4d022dc3a46b536de64 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 Jan 2016 22:10:03 +0100 Subject: git-download: Correctly implement recursive checkouts. Previously, the 'git checkout' invocation would remove sub-modules that had been initialized by 'git clone --recursive'. * guix/build/git.scm (git-fetch): Never use "git clone --recursive". Invoke "git submodule update --init --recursive" after "git checkout". Remove '.git' directories as the last step. --- guix/build/git.scm | 43 ++++++++++++++++++++++++------------------- 1 file changed, 24 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/guix/build/git.scm b/guix/build/git.scm index 121f07a7fa..c1af545a76 100644 --- a/guix/build/git.scm +++ b/guix/build/git.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014 Ludovic Courtès +;;; Copyright © 2014, 2016 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -37,23 +37,28 @@ recursively. Return #t on success, #f otherwise." ;; in advance anyway. (setenv "GIT_SSL_NO_VERIFY" "true") - (let ((args `("clone" ,@(if recursive? '("--recursive") '()) - ,url ,directory))) - (and (zero? (apply system* git-command args)) - (with-directory-excursion directory - (system* git-command "tag" "-l") - (and (zero? (system* git-command "checkout" commit)) - (begin - ;; The contents of '.git' vary as a function of the current - ;; status of the Git repo. Since we want a fixed output, this - ;; directory needs to be taken out. - (delete-file-recursively ".git") - - (when recursive? - ;; In sub-modules, '.git' is a flat file, not a directory, - ;; so we can use 'find-files' here. - (for-each delete-file-recursively - (find-files directory "^\\.git$"))) - #t)))))) + ;; We cannot use "git clone --recursive" since the following "git checkout" + ;; effectively removes sub-module checkouts as of Git 2.6.3. + (and (zero? (system* git-command "clone" url directory)) + (with-directory-excursion directory + (system* git-command "tag" "-l") + (and (zero? (system* git-command "checkout" commit)) + (begin + (when recursive? + ;; Now is the time to fetch sub-modules. + (unless (zero? (system* git-command "submodule" "update" + "--init" "--recursive")) + (error "failed to fetch sub-modules" url)) + + ;; In sub-modules, '.git' is a flat file, not a directory, + ;; so we can use 'find-files' here. + (for-each delete-file-recursively + (find-files directory "^\\.git$"))) + + ;; The contents of '.git' vary as a function of the current + ;; status of the Git repo. Since we want a fixed output, this + ;; directory needs to be taken out. + (delete-file-recursively ".git") + #t))))) ;;; git.scm ends here -- cgit v1.2.3 From d28ef4393719692371aee085d5723f5779cb6049 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 Jan 2016 22:11:57 +0100 Subject: ui: Update copyright year in '--version' output. * guix/ui.scm (show-version-and-exit): Increment copyright year. --- guix/ui.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 35a6671a07..6fd16bb9cc 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2013 Mark H Weaver ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2014 Cyril Roelandt @@ -301,7 +301,7 @@ exiting. ARGS is the list of arguments received by the 'throw' handler." "Display version information for COMMAND and `(exit 0)'." (simple-format #t "~a (~a) ~a~%" command %guix-package-name %guix-version) - (display (_ "Copyright (C) 2015 the Guix authors + (display (_ "Copyright (C) 2016 the Guix authors License GPLv3+: GNU GPL version 3 or later This is free software: you are free to change and redistribute it. There is NO WARRANTY, to the extent permitted by law. -- cgit v1.2.3 From db5a94445f3b21b307c73ea72ed495bda891ef28 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 Jan 2016 22:27:38 +0100 Subject: guix package: Allow multiple '--search' flags. * guix/scripts/package.scm (find-packages-by-description): Change 'rx' parameter to 'regexps'. [matches-all?, matches-one?]: New procedures. Use them. (process-query): Collect regexps from all 'search' queries, and pass them to 'find-packages-by-description'. * tests/guix-package.sh: Add tests. * doc/guix.texi (Invoking guix package): Document it. --- doc/guix.texi | 17 ++++++++++++++++- guix/scripts/package.scm | 33 ++++++++++++++++++++------------- tests/guix-package.sh | 20 +++++++++++++++++--- 3 files changed, 53 insertions(+), 17 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index f155fbe818..a07bf824d6 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -10,7 +10,7 @@ @include version.texi @copying -Copyright @copyright{} 2012, 2013, 2014, 2015 Ludovic Courtès@* +Copyright @copyright{} 2012, 2013, 2014, 2015, 2016 Ludovic Courtès@* Copyright @copyright{} 2013, 2014 Andreas Enge@* Copyright @copyright{} 2013 Nikita Karetnikov@* Copyright @copyright{} 2015 Mathieu Lirzin@* @@ -1462,6 +1462,21 @@ name: gmp @dots{} @end example +It is also possible to refine search results using several @code{-s} +flags. For example, the following command returns a list of board +games: + +@example +$ guix package -s '\' -s game | recsel -p name +name: gnubg +@dots{} +@end example + +If we were to omit @code{-s game}, we would also get software packages +that deal with printed circuit boards; removing the angle brackets +around @code{board} would further add packages that have to do with +keyboards. + @item --show=@var{package} Show details about @var{package}, taken from the list of available packages, in @code{recutils} format (@pxref{Top, GNU recutils databases,, recutils, GNU diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index d0b5abd0e2..02eb600c43 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2013, 2015 Mark H Weaver ;;; Copyright © 2014 Alex Kost @@ -230,21 +230,24 @@ specified in MANIFEST, a manifest object." ;;; Package specifications. ;;; -(define (find-packages-by-description rx) - "Return the list of packages whose name, synopsis, or description matches -RX." +(define (find-packages-by-description regexps) + "Return the list of packages whose name matches one of REGEXPS, or whose +synopsis or description matches all of REGEXPS." (define version=?)) + (define (matches-all? str) + (every (cut regexp-exec <> str) regexps)) + + (define (matches-one? str) + (find (cut regexp-exec <> str) regexps)) + (sort (fold-packages (lambda (package result) - (define matches? - (cut regexp-exec rx <>)) - - (if (or (matches? (package-name package)) + (if (or (matches-one? (package-name package)) (and=> (package-synopsis package) - (compose matches? P_)) + (compose matches-all? P_)) (and=> (package-description package) - (compose matches? P_))) + (compose matches-all? P_))) (cons package result) result)) '()) @@ -696,11 +699,15 @@ processed, #f otherwise." (package-name p2)))))) #t)) - (('search regexp) - (let ((regexp (make-regexp* regexp regexp/icase))) + (('search _) + (let* ((patterns (filter-map (match-lambda + (('query 'search rx) rx) + (_ #f)) + opts)) + (regexps (map (cut make-regexp* <> regexp/icase) patterns))) (leave-on-EPIPE (for-each (cute package->recutils <> (current-output-port)) - (find-packages-by-description regexp))) + (find-packages-by-description regexps))) #t)) (('show requested-name) diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 5e6ff8b012..cf1a185590 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès +# Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès # Copyright © 2013 Nikita Karetnikov # # This file is part of GNU Guix. @@ -30,9 +30,10 @@ readlink_base () module_dir="t-guix-package-$$" profile="t-profile-$$" -rm -f "$profile" +tmpfile="t-guix-package-file-$$" +rm -f "$profile" "$tmpfile" -trap 'rm -f "$profile" "$profile-"[0-9]* ; rm -rf "$module_dir" t-home-'"$$" EXIT +trap 'rm -f "$profile" "$profile-"[0-9]* "$tmpfile"; rm -rf "$module_dir" t-home-'"$$" EXIT # Use `-e' with a non-package expression. if guix package --bootstrap -e +; @@ -96,6 +97,19 @@ test "`guix package -s "An example GNU package" | grep ^name:`" = \ "name: hello" test -z "`guix package -s "n0t4r341p4ck4g3"`" +# Search with one and then two regexps. +# First we get printed circuit boards *and* board games. +guix package -s '\' > "$tmpfile" +grep '^name: pcb' "$tmpfile" +grep '^name: gnubg' "$tmpfile" + +# Second we get only board games. +guix package -s '\' -s game > "$tmpfile" +grep -v '^name: pcb' "$tmpfile" > /dev/null +grep '^name: gnubg' "$tmpfile" + +rm -f "$tmpfile" + # Make sure `--search' can display all the packages. guix package --search="" > /dev/null -- cgit v1.2.3 From f07041f7d25badb7d74b8fad6ee446a12af04f63 Mon Sep 17 00:00:00 2001 From: Taylan Ulrich Bayırlı/Kammer Date: Fri, 27 Nov 2015 09:27:55 +0100 Subject: build: pull: Compile .scm files in one process. * guix/build/pull.scm (call-with-process, report-build-progress) (p-for-each): Remove. (build-guix): Load and compile files in one process. --- guix/build/pull.scm | 149 +++++++++++++++++++--------------------------------- 1 file changed, 55 insertions(+), 94 deletions(-) (limited to 'guix') diff --git a/guix/build/pull.scm b/guix/build/pull.scm index 281be23aa8..4ddb12ac04 100644 --- a/guix/build/pull.scm +++ b/guix/build/pull.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014 Ludovic Courtès +;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +23,7 @@ #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:use-module (ice-9 format) + #:use-module (ice-9 threads) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -33,75 +35,10 @@ ;;; ;;; Code: -(define (call-with-process thunk) - "Run THUNK in a separate process that will return 0 if THUNK terminates -normally, and 1 if an exception is raised." - (match (primitive-fork) - (0 - (catch #t - (lambda () - (thunk) - (primitive-exit 0)) - (lambda (key . args) - (print-exception (current-error-port) #f key args) - (primitive-exit 1)))) - (pid - #t))) - -(define* (report-build-progress total completed cont - #:optional (log-port (current-error-port))) - "Report that COMPLETED out of TOTAL files have been completed, and call -CONT." - (display #\cr log-port) - (format log-port "compiling...\t~5,1f% of ~d files" ;FIXME: i18n - (* 100. (/ completed total)) total) - (force-output log-port) - (cont)) - -(define* (p-for-each proc lst - #:optional (max-processes (current-processor-count)) - #:key (progress report-build-progress)) - "Invoke PROC for each element of LST in a separate process, using up to -MAX-PROCESSES processes in parallel. Call PROGRESS at each step, passing it -the continuation. Raise an error if one of the processes exit with non-zero." - (define total - (length lst)) - - (define (wait-for-one-process) - (match (waitpid WAIT_ANY) - ((_ . status) - (unless (zero? (status:exit-val status)) - (error "process failed" proc status))))) - - (let loop ((lst lst) - (running 0) - (completed 0)) - (match lst - (() - (or (zero? running) - (let ((running (- running 1)) - (completed (+ completed 1))) - (wait-for-one-process) - (progress total completed - (lambda () - (loop lst running completed)))))) - ((head . tail) - (if (< running max-processes) - (let ((running (+ 1 running))) - (call-with-process (cut proc head)) - (progress total completed - (lambda () - (loop tail running completed)))) - (let ((running (- running 1)) - (completed (+ completed 1))) - (wait-for-one-process) - (progress total completed - (lambda () - (loop lst running completed))))))))) - (define* (build-guix out source #:key gcrypt - (debug-port (%make-void-port "w"))) + (debug-port (%make-void-port "w")) + (log-port (current-error-port))) "Build and install Guix in directory OUT using SOURCE, a directory containing the source code. Write any debugging output to DEBUG-PORT." (setvbuf (current-output-port) _IOLBF) @@ -130,33 +67,57 @@ containing the source code. Write any debugging output to DEBUG-PORT." (set! %load-path (cons out %load-path)) (set! %load-compiled-path (cons out %load-compiled-path)) - ;; Compile the .scm files. Do that in independent processes, à la - ;; 'make -j', to work around (FIXME). - ;; This ensures correctness, but is overly conservative and slow. - ;; The solution initially implemented (and described in the bug - ;; above) was slightly faster but consumed memory proportional to the - ;; number of modules, which quickly became unacceptable. - (p-for-each (lambda (file) - (let ((go (string-append (string-drop-right file 4) - ".go"))) - (format debug-port "~%compiling '~a'...~%" file) - (parameterize ((current-warning-port debug-port)) - (compile-file file - #:output-file go - #:opts - %auto-compilation-options)))) - - (filter (cut string-suffix? ".scm" <>) - - ;; Build guix/*.scm before gnu/*.scm to speed - ;; things up. - (sort (find-files out "\\.scm") - (let ((guix (string-append out "/guix")) - (gnu (string-append out "/gnu"))) - (lambda (a b) - (or (and (string-prefix? guix a) - (string-prefix? gnu b)) - (string (FIXME). + (let* ((files + ;; Load guix/ modules before gnu/ modules to get somewhat steadier + ;; progress reporting. + (sort (filter (cut string-suffix? ".scm" <>) + (find-files out "\\.scm")) + (let ((guix (string-append out "/guix")) + (gnu (string-append out "/gnu"))) + (lambda (a b) + (or (and (string-prefix? guix a) + (string-prefix? gnu b)) + (string/foo/bar.scm" into (foo bar). + (let* ((relative-file (string-drop file (+ (string-length out) 1))) + (module-path (string-drop-right relative-file 4)) + (module-name (map string->symbol + (string-split module-path #\/)))) + (parameterize ((current-warning-port debug-port)) + (resolve-interface module-name))) + (loop files (+ 1 completed))))) + (newline) + (let ((mutex (make-mutex)) + (completed 0)) + (par-for-each + (lambda (file) + (with-mutex mutex + (display #\cr log-port) + (format log-port "compiling...\t~5,1f% of ~d files" ;FIXME: i18n + (* 100. (/ completed total)) total) + (force-output log-port) + (format debug-port "~%compiling '~a'...~%" file)) + (let ((go (string-append (string-drop-right file 4) ".go"))) + (parameterize ((current-warning-port (%make-void-port "w"))) + (compile-file file + #:output-file go + #:opts %auto-compilation-options))) + (with-mutex mutex + (set! completed (+ 1 completed)))) + files)))) ;; Remove the "fake" (guix config). (delete-file (string-append out "/guix/config.scm")) -- cgit v1.2.3 From 7266848ace1da9b43c3a06bf4c942c56d4ba3d6a Mon Sep 17 00:00:00 2001 From: Ben Woodcroft Date: Wed, 30 Dec 2015 10:27:33 +1000 Subject: build: ruby: Remove cached gem after install. The .gem file stored in GEM_HOME after install is both redundant and an archive that stores timestamped files which makes builds non-deterministic, so delete it after 'gem install'. * guix/build/ruby-build-system.scm (install): Remove cached gem after install. --- guix/build/ruby-build-system.scm | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm index 2685da1a72..6439bf69eb 100644 --- a/guix/build/ruby-build-system.scm +++ b/guix/build/ruby-build-system.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson ;;; Copyright © 2015 Pjotr Prins +;;; Copyright © 2015 Ben Woodcroft ;;; ;;; This file is part of GNU Guix. ;;; @@ -115,15 +116,19 @@ GEM-FLAGS are passed to the 'gem' invokation, if present." (assoc-ref inputs "ruby")) 1)) (out (assoc-ref outputs "out")) - (gem-home (string-append out "/lib/ruby/gems/" ruby-version ".0"))) - + (gem-home (string-append out "/lib/ruby/gems/" ruby-version ".0")) + (gem-name (first-matching-file "\\.gem$"))) (setenv "GEM_HOME" gem-home) (mkdir-p gem-home) - (zero? (apply system* "gem" "install" (first-matching-file "\\.gem$") - "--local" "--ignore-dependencies" - ;; Executables should go into /bin, not /lib/ruby/gems. - "--bindir" (string-append out "/bin") - gem-flags)))) + (and (apply system* "gem" "install" gem-name + "--local" "--ignore-dependencies" + ;; Executables should go into /bin, not /lib/ruby/gems. + "--bindir" (string-append out "/bin") + gem-flags) + ;; Remove the cached gem file as this is unnecessary and contains + ;; timestamped files rendering builds not reproducible. + (begin (delete-file (string-append gem-home "/cache/" gem-name)) + #t)))) (define %standard-phases (modify-phases gnu:%standard-phases -- cgit v1.2.3 From f888c0b1207a92b0d7af4dcf7fb73cecd1f0b34f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 Jan 2016 15:53:20 +0100 Subject: lint: cve: Catch host name lookup errors. * guix/scripts/lint.scm (package-vulnerabilities): Catch 'getaddrinfo-error'. --- guix/scripts/lint.scm | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index f296f8a00e..e2cc965951 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Cyril Roelandt ;;; Copyright © 2014, 2015 Eric Bavier -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2015 Mathieu Lirzin ;;; ;;; This file is part of GNU Guix. @@ -593,7 +593,16 @@ Common Platform Enumeration (CPE) name." (define package-vulnerabilities (let ((lookup (delay (vulnerabilities->lookup-proc - (current-vulnerabilities))))) + ;; Catch networking errors to allow network-less + ;; operation. + (catch 'getaddrinfo-error + (lambda () + (current-vulnerabilities)) + (lambda (key errcode) + (warn (_ "failed to lookup NIST host: ~a~%") + (gai-strerror errcode)) + (warn (_ "assuming no CVE vulnerabilities~%")) + '())))))) (lambda (package) "Return a list of vulnerabilities affecting PACKAGE." ((force lookup) -- cgit v1.2.3 From 1c63dafce60cb362f80986eed7ce823a3f3500a9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 Jan 2016 18:04:36 +0100 Subject: http-client: Fix erroneous comment. * guix/http-client.scm: Fix Guile version number in comment for Guile commit 5a10e41. --- guix/http-client.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/http-client.scm b/guix/http-client.scm index c7cbc82aac..b0aae52658 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2012, 2015 Free Software Foundation, Inc. ;;; @@ -191,7 +191,7 @@ closes PORT, unless KEEP-ALIVE? is true." (unless (guile-version>? "2.0.11") ;; Guile <= 2.0.9 had a bug whereby 'response-body-port' would read more ;; than what 'content-length' says. See Guile commit 802a25b. - ;; Guile <= 2.0.12 had a bug whereby the 'close' method of the response + ;; Guile <= 2.0.11 had a bug whereby the 'close' method of the response ;; body port would fail with wrong-arg-num. See Guile commit 5a10e41. (module-set! (resolve-module '(web response)) 'make-delimited-input-port make-delimited-input-port))) -- cgit v1.2.3 From 793a43f4099c94a74fa3374b0ed732cb14e120e9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 Jan 2016 21:36:15 +0100 Subject: http-client: Work around . * guix/http-client.scm (read-header-line): New procedure. Use it. --- guix/http-client.scm | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/http-client.scm b/guix/http-client.scm index b0aae52658..31b511eb1c 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -188,13 +188,33 @@ closes PORT, unless KEEP-ALIVE? is true." (make-custom-binary-input-port "delimited input port" read! #f #f close)) + (define (read-header-line port) + "Read an HTTP header line and return it without its final CRLF or LF. +Raise a 'bad-header' exception if the line does not end in CRLF or LF, +or if EOF is reached." + (match (%read-line port) + (((? string? line) . #\newline) + ;; '%read-line' does not consider #\return a delimiter; so if it's + ;; there, remove it. We are more tolerant than the RFC in that we + ;; tolerate LF-only endings. + (if (string-suffix? "\r" line) + (string-drop-right line 1) + line)) + ((line . _) ;EOF or missing delimiter + ((@@ (web http) bad-header) 'read-header-line line)))) + (unless (guile-version>? "2.0.11") ;; Guile <= 2.0.9 had a bug whereby 'response-body-port' would read more ;; than what 'content-length' says. See Guile commit 802a25b. ;; Guile <= 2.0.11 had a bug whereby the 'close' method of the response ;; body port would fail with wrong-arg-num. See Guile commit 5a10e41. (module-set! (resolve-module '(web response)) - 'make-delimited-input-port make-delimited-input-port))) + 'make-delimited-input-port make-delimited-input-port) + + ;; Guile <= 2.0.11 was affected by . See Guile + ;; commit 4c7732c. + (when (module-variable %web-http 'read-line*) + (module-set! %web-http 'read-line* read-header-line)))) ;; XXX: Work around , present in Guile ;; up to 2.0.7. -- cgit v1.2.3 From 6071122b713e8a87158cdd4e913851fab283ead3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 Jan 2016 22:42:09 +0100 Subject: utils: Add 'ensure-keyword-arguments'. * guix/utils.scm (delkw, ensure-keyword-arguments): New procedures. * tests/utils.scm ("ensure-keyword-arguments"): New test. --- guix/utils.scm | 42 +++++++++++++++++++++++++++++++++++++++++- tests/utils.scm | 10 +++++++++- 2 files changed, 50 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/utils.scm b/guix/utils.scm index 7b589e68a8..c61f105513 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2013, 2014, 2015 Mark H Weaver ;;; Copyright © 2014 Eric Bavier ;;; Copyright © 2014 Ian Denhardt @@ -52,6 +52,7 @@ strip-keyword-arguments default-keyword-arguments substitute-keyword-arguments + ensure-keyword-arguments location @@ -453,6 +454,45 @@ previous value of the keyword argument." (() (reverse before))))))) +(define (delkw kw lst) + "Remove KW and its associated value from LST, a keyword/value list such +as '(#:foo 1 #:bar 2)." + (let loop ((lst lst) + (result '())) + (match lst + (() + (reverse result)) + ((kw? value rest ...) + (if (eq? kw? kw) + (append (reverse result) rest) + (loop rest (cons* value kw? result))))))) + +(define (ensure-keyword-arguments args kw/values) + "Force the keywords arguments KW/VALUES in the keyword argument list ARGS. +For instance: + + (ensure-keyword-arguments '(#:foo 2) '(#:foo 2)) + => (#:foo 2) + + (ensure-keyword-arguments '(#:foo 2) '(#:bar 3)) + => (#:foo 2 #:bar 3) + + (ensure-keyword-arguments '(#:foo 2) '(#:bar 3 #:foo 42)) + => (#:foo 42 #:bar 3) +" + (let loop ((args args) + (kw/values kw/values) + (result '())) + (match args + (() + (append (reverse result) kw/values)) + ((kw value rest ...) + (match (memq kw kw/values) + ((_ value . _) + (loop rest (delkw kw kw/values) (cons* value kw result))) + (#f + (loop rest kw/values (cons* value kw result)))))))) + (define* (nix-system->gnu-triplet #:optional (system (%current-system)) (vendor "unknown")) "Return a guess of the GNU triplet corresponding to Nix system diff --git a/tests/utils.scm b/tests/utils.scm index 04a859fc9d..a05faabc15 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2014 Eric Bavier ;;; ;;; This file is part of GNU Guix. @@ -141,6 +141,14 @@ '(a #:foo 42 #:b b #:baz 3 #:c c #:bar 4))) +(test-equal "ensure-keyword-arguments" + '((#:foo 2) + (#:foo 2 #:bar 3) + (#:foo 42 #:bar 3)) + (list (ensure-keyword-arguments '(#:foo 2) '(#:foo 2)) + (ensure-keyword-arguments '(#:foo 2) '(#:bar 3)) + (ensure-keyword-arguments '(#:foo 2) '(#:bar 3 #:foo 42)))) + (let* ((tree (alist->vhash '((0 2 3) (1 3 4) (2) (3 5 6) (4 6) (5) (6)) hashq)) -- cgit v1.2.3 From d4aaf954011646413e7c2ca39a34030821e84910 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 Jan 2016 22:56:01 +0100 Subject: build-system/gnu: Make 'package-with-explicit-inputs' idempotent. * guix/build-system/gnu.scm (package-with-explicit-inputs): Use 'ensure-keyword-arguments' instead of appending to ARGS. * gnu/packages/commencement.scm (static-bash-for-glibc): Add missing #:guile argument. --- gnu/packages/commencement.scm | 5 +++-- guix/build-system/gnu.scm | 9 +++++---- 2 files changed, 8 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/gnu/packages/commencement.scm b/gnu/packages/commencement.scm index 73b0ce4364..73b27a290a 100644 --- a/gnu/packages/commencement.scm +++ b/gnu/packages/commencement.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2014 Andreas Enge ;;; Copyright © 2012 Nikita Karetnikov ;;; Copyright © 2014, 2015 Mark H Weaver @@ -434,7 +434,8 @@ exec ~a/bin/~a-~a -B~a/lib -Wl,-dynamic-linker -Wl,~a/~a \"$@\"~%" ("libc" ,glibc-final-with-bootstrap-bash) ,@(fold alist-delete %boot1-inputs '("gcc" "libc"))) - (current-source-location))))) + (current-source-location) + #:guile %bootstrap-guile)))) (define gettext-boot0 ;; A minimal gettext used during bootstrap. diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index c83c50b76e..9c53825c4a 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -96,10 +96,11 @@ builder, or the distro's final Guile when GUILE is #f." (package (inherit p) (location (if (pair? loc) (source-properties->location loc) loc)) (arguments - (let ((args (package-arguments p))) - `(#:guile ,guile - #:implicit-inputs? #f - ,@args))) + ;; 'ensure-keyword-arguments' guarantees that this procedure is + ;; idempotent. + (ensure-keyword-arguments (package-arguments p) + `(#:guile ,guile + #:implicit-inputs? #f))) (replacement (let ((replacement (package-replacement p))) (and replacement -- cgit v1.2.3 From d1c116089bb747009c11a3205e16a019dc5ecf7c Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 16 Dec 2015 14:22:17 +0100 Subject: import: Add package->upstream-name procedure. * guix/import/cran.scm (package->upstream-name): New procedure. --- guix/import/cran.scm | 40 +++++++++++++++++++++++----------------- 1 file changed, 23 insertions(+), 17 deletions(-) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 45c679cbe2..bf46d17ead 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -204,27 +204,33 @@ which was derived from the R package's DESCRIPTION file." ;;; Updater. ;;; +(define (package->upstream-name package) + "Return the upstream name of the PACKAGE." + (let* ((properties (package-properties package)) + (upstream-name (and=> properties + (cut assoc-ref <> 'upstream-name)))) + (if upstream-name + upstream-name + (match (package-source package) + ((? origin? origin) + (match (origin-uri origin) + ((url rest ...) + (let ((end (string-rindex url #\_)) + (start (string-rindex url #\/))) + ;; The URL ends on + ;; (string-append "/" name "_" version ".tar.gz") + (substring url start end))) + (_ #f))) + (_ #f))))) + (define (latest-release package) "Return an for the latest release of PACKAGE." - (define (package->cran-name package) - (match (package-source package) - ((? origin? origin) - (match (origin-uri origin) - ((url rest ...) - (let ((end (string-rindex url #\_)) - (start (string-rindex url #\/))) - ;; The URL ends on - ;; (string-append "/" name "_" version ".tar.gz") - (substring url start end))) - (_ #f))) - (_ #f))) - - (define cran-name - (package->cran-name (specification->package package))) + (define upstream-name + (package->upstream-name (specification->package package))) (define meta - (cran-fetch cran-name)) + (cran-fetch upstream-name)) (and meta (let ((version (assoc-ref meta "Version"))) @@ -232,7 +238,7 @@ which was derived from the R package's DESCRIPTION file." (upstream-source (package package) (version version) - (urls (cran-uri cran-name version)))))) + (urls (cran-uri upstream-name version)))))) (define (cran-package? package) "Return true if PACKAGE is an R package from CRAN." -- cgit v1.2.3 From 34a75d35bb8366136309be62000baa6ba1067399 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 16 Dec 2015 14:28:43 +0100 Subject: import: Rename "cran-fetch" to "fetch-description". * guix/import/cran.scm (cran-fetch): Rename procedure ... (fetch-description): ... to this. --- guix/import/cran.scm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index bf46d17ead..fc2709020a 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -109,11 +109,11 @@ package definition." (define %cran-url "http://cran.r-project.org/web/packages/") -(define (cran-fetch name) +(define (fetch-description base-url name) "Return an alist of the contents of the DESCRIPTION file for the R package NAME, or #f on failure. NAME is case-sensitive." ;; This API always returns the latest release of the module. - (let ((url (string-append %cran-url name "/DESCRIPTION"))) + (let ((url (string-append base-url name "/DESCRIPTION"))) (description->alist (read-string (http-fetch url))))) (define (listify meta field) @@ -196,7 +196,7 @@ which was derived from the R package's DESCRIPTION file." (define (cran->guix-package package-name) "Fetch the metadata for PACKAGE-NAME from cran.r-project.org, and return the `package' s-expression corresponding to that package, or #f on failure." - (let ((module-meta (cran-fetch package-name))) + (let ((module-meta (fetch-description %cran-url package-name))) (and=> module-meta description->package))) @@ -230,7 +230,7 @@ which was derived from the R package's DESCRIPTION file." (package->upstream-name (specification->package package))) (define meta - (cran-fetch upstream-name)) + (fetch-description %cran-url upstream-name)) (and meta (let ((version (assoc-ref meta "Version"))) -- cgit v1.2.3 From 17ad0a2714271dd3567808637f451d86f1291cab Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 8 Jan 2016 19:06:26 +0100 Subject: build-system/python: 'pypi-uri' takes an optional file name extension. Suggested by swedebugia . * guix/build-system/python.scm (pypi-uri): Add 'extension' parameter and use it. --- guix/build-system/python.scm | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index 2532210a49..86efc1a715 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2013 Andreas Enge ;;; Copyright © 2013 Nikita Karetnikov ;;; @@ -41,12 +41,13 @@ ;; ;; Code: -(define (pypi-uri name version) +(define* (pypi-uri name version #:optional (extension ".tar.gz")) "Return a URI string for the Python package hosted on the Python Package -Index (PyPI) corresponding to NAME and VERSION." +Index (PyPI) corresponding to NAME and VERSION. EXTENSION is the file name +extension, such as '.tar.gz'." (string-append "https://pypi.python.org/packages/source/" (string-take name 1) "/" name "/" - name "-" version ".tar.gz")) + name "-" version extension)) (define %python-build-system-modules ;; Build-side modules imported by default. -- cgit v1.2.3 From 8c9ef2c3a220c856ef7ec10cdb970988c96f2713 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 13 Jan 2016 15:42:13 +0100 Subject: monad-repl: Close connection when leaving the monad REPL. * guix/monad-repl.scm (store-monad-language): Add 'store' parameter and use it. Remove call to 'open-connection'. (enter-store-monad): Use 'with-store' and pass the store to 'store-monad-language. --- guix/monad-repl.scm | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/monad-repl.scm b/guix/monad-repl.scm index ebd9151065..aefabdeebb 100644 --- a/guix/monad-repl.scm +++ b/guix/monad-repl.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -60,11 +60,10 @@ "Return the derivation of the default " (package-derivation store (default-guile) system)) -(define (store-monad-language) - "Return a compiler language for the store monad." - (let* ((store (open-connection)) - (guile (or (%guile-for-build) - (default-guile-derivation store)))) +(define (store-monad-language store) + "Return a compiler language for the store monad using STORE." + (let ((guile (or (%guile-for-build) + (default-guile-derivation store)))) (monad-language %store-monad (cut run-with-store store <> #:guile-for-build guile) @@ -84,10 +83,11 @@ Run EXP through the store monad." (define-meta-command ((enter-store-monad guix) repl) "enter-store-monad Enter a REPL for values in the store monad." - (let ((new (make-repl (store-monad-language)))) - ;; Force interpretation so that our specially-crafted language evaluator - ;; is actually used. - (repl-option-set! new 'interp #t) - (run-repl new))) + (with-store store + (let ((new (make-repl (store-monad-language store)))) + ;; Force interpretation so that our specially-crafted language evaluator + ;; is actually used. + (repl-option-set! new 'interp #t) + (run-repl new)))) ;;; monad-repl.scm ends here -- cgit v1.2.3 From b8a35309f848f676cf7d4b3bbec9b92de554e27a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 13 Jan 2016 17:38:42 +0100 Subject: build-system/gnu: 'dist-package' can be passed the phases. * guix/build-system/gnu.scm (dist-package): Add #:phases parameter and honor it. --- guix/build-system/gnu.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index 9c53825c4a..67ae46faed 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -178,9 +178,10 @@ use `--strip-all' as the arguments to `strip'." flags))))) (replacement (and=> (package-replacement p) static-package)))) -(define* (dist-package p source) +(define* (dist-package p source #:key (phases '%dist-phases)) "Return a package that runs takes source files from the SOURCE directory, -runs `make distcheck' and whose result is one or more source tarballs." +runs `make distcheck' and whose result is one or more source tarballs. The +exact build phases are defined by PHASES." (let ((s source)) (package (inherit p) (name (string-append (package-name p) "-dist")) @@ -199,7 +200,7 @@ runs `make distcheck' and whose result is one or more source tarballs." `((guix build gnu-dist) ,@modules)) ((#:phases _) - '%dist-phases)))) + phases)))) (native-inputs ;; Add autotools & co. as inputs. (let ((ref (lambda (module var) -- cgit v1.2.3