From df36e62938a7a2250601e7652a968e31f89a13f4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 15 Jul 2015 18:01:05 +0200 Subject: ui: Add 'leave-on-EPIPE'. * guix/scripts/package.scm (leave-on-EPIPE): Move to... * guix/ui.scm (leave-on-EPIPE): ... here. --- guix/scripts/package.scm | 16 ---------------- guix/ui.scm | 17 +++++++++++++++++ 2 files changed, 17 insertions(+), 16 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 56a6e2db64..b545ea2672 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -307,22 +307,6 @@ (define matches? ((<) #t) (else #f))))) -(define-syntax-rule (leave-on-EPIPE exp ...) - "Run EXP... in a context when EPIPE errors are caught and lead to 'exit' -with successful exit code. This is useful when writing to the standard output -may lead to EPIPE, because the standard output is piped through 'head' or -similar." - (catch 'system-error - (lambda () - exp ...) - (lambda args - ;; We really have to exit this brutally, otherwise Guile eventually - ;; attempts to flush all the ports, leading to an uncaught EPIPE down - ;; the path. - (if (= EPIPE (system-error-errno args)) - (primitive-_exit 0) - (apply throw args))))) - (define (upgradeable? name current-version current-path) "Return #t if there's a version of package NAME newer than CURRENT-VERSION, or if the newest available version is equal to CURRENT-VERSION but would have diff --git a/guix/ui.scm b/guix/ui.scm index 11af646a6e..28d4b97118 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -62,6 +62,7 @@ (define-module (guix ui) show-manifest-transaction call-with-error-handling with-error-handling + leave-on-EPIPE read/eval read/eval-package-expression location->string @@ -430,6 +431,22 @@ (define (call-with-error-handling thunk) (leave (_ "~a: ~a~%") proc (apply format #f format-string format-args)))))) +(define-syntax-rule (leave-on-EPIPE exp ...) + "Run EXP... in a context when EPIPE errors are caught and lead to 'exit' +with successful exit code. This is useful when writing to the standard output +may lead to EPIPE, because the standard output is piped through 'head' or +similar." + (catch 'system-error + (lambda () + exp ...) + (lambda args + ;; We really have to exit this brutally, otherwise Guile eventually + ;; attempts to flush all the ports, leading to an uncaught EPIPE down + ;; the path. + (if (= EPIPE (system-error-errno args)) + (primitive-_exit 0) + (apply throw args))))) + (define %guix-user-module ;; Module in which user expressions are evaluated. ;; Compute lazily to avoid circularity with (guix gexp). -- cgit v1.2.3 From d2f2c8f126ebc400f016781805c76683cc364c18 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 15 Jul 2015 18:05:29 +0200 Subject: size: Gracefully handle EPIPE. * guix/scripts/size.scm (guix-size): Wrap body in 'leave-on-EPIPE'. --- guix/scripts/size.scm | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm index 13341fdfe2..1339742946 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -280,15 +280,16 @@ (define (guix-size . args) (() (leave (_ "missing store item argument\n"))) ((file) - (with-store store - (run-with-store store - (mlet* %store-monad ((item (ensure-store-item file)) - (profile (store-profile item))) - (if map-file - (begin - (profile->page-map profile map-file) - (return #t)) - (display-profile* profile))) - #:system system))) + (leave-on-EPIPE + (with-store store + (run-with-store store + (mlet* %store-monad ((item (ensure-store-item file)) + (profile (store-profile item))) + (if map-file + (begin + (profile->page-map profile map-file) + (return #t)) + (display-profile* profile))) + #:system system)))) ((files ...) (leave (_ "too many arguments\n"))))))) -- cgit v1.2.3 From ee2a6304f3bcf19df895310aedff372ed7e17c34 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 17 Jul 2015 01:07:50 +0200 Subject: system: Add 'kernel-arguments' field. * gnu/system.scm ()[kernel-arguments]: New field. (operating-system-grub.cfg): Honor it. (operating-system-parameters-file): Add 'kernel-arguments' to the parameters file. * guix/scripts/system.scm (previous-grub-entries)[system->grub-entry]: Read the 'kernel-arguments' field of the parameters file, when available. * gnu/system/vm.scm (system-qemu-image/shared-store-script): Use (operating-system-kernel-arguments os) in '-append'. * doc/guix.texi (operating-system Reference): Document it. --- doc/guix.texi | 4 ++++ gnu/system.scm | 16 +++++++++++----- gnu/system/vm.scm | 3 ++- guix/scripts/system.scm | 11 +++++++---- 4 files changed, 24 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index e4662cbfe1..2f8c52c8b6 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4825,6 +4825,10 @@ The package object of the operating system kernel to use@footnote{Currently only the Linux-libre kernel is supported. In the future, it will be possible to use the GNU@tie{}Hurd.}. +@item @code{kernel-arguments} (default: @code{'()}) +List of strings or gexps representing additional arguments to pass on +the kernel's command-line---e.g., @code{("console=ttyS0")}. + @item @code{bootloader} The system bootloader configuration object. @xref{GRUB Configuration}. diff --git a/gnu/system.scm b/gnu/system.scm index efad14596a..ed37c320f7 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -68,6 +68,7 @@ (define-module (gnu system) operating-system-host-name operating-system-hosts-file operating-system-kernel + operating-system-kernel-arguments operating-system-initrd operating-system-users operating-system-groups @@ -103,6 +104,8 @@ (define-record-type* operating-system operating-system? (kernel operating-system-kernel ; package (default linux-libre)) + (kernel-arguments operating-system-kernel-arguments + (default '())) ; list of gexps/strings (bootloader operating-system-bootloader) ; (initrd operating-system-initrd ; (list fs) -> M derivation @@ -866,11 +869,12 @@ (define* (operating-system-grub.cfg os #:optional (old-entries '())) (label (kernel->grub-label kernel)) (linux kernel) (linux-arguments - (list (string-append "--root=" - (file-system-device root-fs)) - #~(string-append "--system=" #$system) - #~(string-append "--load=" #$system - "/boot"))) + (cons* (string-append "--root=" + (file-system-device root-fs)) + #~(string-append "--system=" #$system) + #~(string-append "--load=" #$system + "/boot") + (operating-system-kernel-arguments os))) (initrd #~(string-append #$system "/initrd")))))) (grub-configuration-file (operating-system-bootloader os) entries #:old-entries old-entries))) @@ -887,6 +891,8 @@ (define (operating-system-parameters-file os) (label #$label) (root-device #$(file-system-device root)) (kernel #$(operating-system-kernel os)) + (kernel-arguments + #$(operating-system-kernel-arguments os)) (initrd #$initrd))))) (define (operating-system-derivation os) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 2520493e2e..b293009127 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -493,7 +493,8 @@ (define builder #~(" -kernel " #$(operating-system-kernel os) "/bzImage \ -initrd " #$os-drv "/initrd \ -append \"" #$(if graphic? "" "console=ttyS0 ") - "--system=" #$os-drv " --load=" #$os-drv "/boot --root=/dev/vda1\" ")) + "--system=" #$os-drv " --load=" #$os-drv "/boot --root=/dev/vda1 " + (string-join (list #+@(operating-system-kernel-arguments os))) "\" ")) #$(common-qemu-options image (map file-system-mapping-source (cons %store-mapping mappings))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 6084ab8a37..45f598219d 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -249,16 +249,19 @@ (define (system->grub-entry system number time) (('boot-parameters ('version 0) ('label label) ('root-device root) ('kernel linux) - _ ...) + rest ...) (menu-entry (label (string-append label " (#" (number->string number) ", " (seconds->string time) ")")) (linux linux) (linux-arguments - (list (string-append "--root=" root) - #~(string-append "--system=" #$system) - #~(string-append "--load=" #$system "/boot"))) + (cons* (string-append "--root=" root) + #~(string-append "--system=" #$system) + #~(string-append "--load=" #$system "/boot") + (match (assq 'kernel-arguments rest) + ((_ args) args) + (#f '())))) ;old format (initrd #~(string-append #$system "/initrd")))) (_ ;unsupported format (warning (_ "unrecognized boot parameters for '~a'~%") -- cgit v1.2.3 From 0eed5501b8f04710f871ca8b05d1566f455de6fd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 17 Jul 2015 12:13:31 +0200 Subject: licenses: Add Fontana's copyleft-next. * guix/licenses.scm (copyleft-next): New variable. --- guix/licenses.scm | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'guix') diff --git a/guix/licenses.scm b/guix/licenses.scm index a036c8e903..5539f3e3e8 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -32,6 +32,7 @@ (define-module (guix licenses) cddl1.0 cecill-c artistic2.0 clarified-artistic + copyleft-next cpl1.0 epl1.0 expat @@ -154,6 +155,11 @@ (define clarified-artistic "http://gianluca.dellavedova.org/2011/01/03/clarified-artistic-license/" "https://www.gnu.org/licenses/license-list.html#ArtisticLicense2")) +(define copyleft-next + (license "copyleft-next" + "https://raw.github.com/richardfontana/copyleft-next/master/Releases/copyleft-next-0.3.0" + "GPL-compatible copyleft license")) + (define cpl1.0 (license "CPL 1.0" "http://directory.fsf.org/wiki/License:CPLv1.0" -- cgit v1.2.3 From 4f7b564adbc09267fa61ee93292e2fc8a470f9cd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 17 Jul 2015 22:31:12 +0200 Subject: download: Remove spurious warning about 'https_proxy'. * guix/build/download.scm (open-connection-for-uri)[with-https-proxy]: Warn about 'https_proxy' only when 'getenv' returns a non-empty string. --- guix/build/download.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index 65d18eb839..ae59b0109c 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -231,7 +231,8 @@ (define https? (resolve-interface '(web client)) 'current-http-proxy)) (parameterize ((current-http-proxy #f)) - (when (getenv "https_proxy") + (when (and=> (getenv "https_proxy") + (negate string-null?)) (format (current-error-port) "warning: 'https_proxy' is ignored~%")) (thunk)) -- cgit v1.2.3 From 13f0c6ed4147d381e7b5e4601a50fe9f997d0ca5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 17 Jul 2015 23:31:29 +0200 Subject: syscalls: Struct deserializer can now return arbitrary objects. * guix/build/syscalls.scm (read-types): Add RETURN and VALUES parameters. (define-c-struct): Add WRAP-FIELDS parameter and pass it to 'read-types'. (sockaddr-in, sockaddr-in6): Add first argument that uses 'make-socket-address'. (read-socket-address): Remove 'match' on the result of 'read-sockaddr-in' and 'read-sockaddr-in6'. --- guix/build/syscalls.scm | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index dcca5fc339..b7c0f7e745 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -398,22 +398,23 @@ (define-syntax read-type (define-syntax read-types (syntax-rules () - ((_ bv offset ()) - '()) - ((_ bv offset (type0 types ...)) - (cons (read-type bv offset type0) - (read-types bv (+ offset (type-size type0)) (types ...)))))) + ((_ return bv offset () (values ...)) + (return values ...)) + ((_ return bv offset (type0 types ...) (values ...)) + (read-types return + bv (+ offset (type-size type0)) (types ...) + (values ... (read-type bv offset type0)))))) (define-syntax define-c-struct (syntax-rules () - "Define READ as an optimized serializer and WRITE! as a deserializer for -the C structure with the given TYPES." - ((_ name read write! (fields types) ...) + "Define READ as a deserializer and WRITE! as a serializer for the C +structure with the given TYPES. READ uses WRAP-FIELDS to return its value." + ((_ name wrap-fields read write! (fields types) ...) (begin (define (write! bv offset fields ...) (write-types bv offset (types ...) (fields ...))) (define (read bv offset) - (read-types bv offset (types ...))))))) + (read-types wrap-fields bv offset (types ...) ())))))) ;;; @@ -463,6 +464,8 @@ (define ifreq-struct-size 32)) (define-c-struct sockaddr-in ; + (lambda (family port address) + (make-socket-address family address port)) read-sockaddr-in write-sockaddr-in! (family unsigned-short) @@ -470,6 +473,8 @@ (define-c-struct sockaddr-in ; (address (int32 ~ big))) (define-c-struct sockaddr-in6 ; + (lambda (family port flowinfo address scopeid) + (make-socket-address family address port flowinfo scopeid)) read-sockaddr-in6 write-sockaddr-in6! (family unsigned-short) @@ -501,14 +506,9 @@ (define (read-socket-address bv index) "Read a socket address from bytevector BV at INDEX." (let ((family (bytevector-u16-native-ref bv index))) (cond ((= family AF_INET) - (match (read-sockaddr-in bv index) - ((family port address) - (make-socket-address family address port)))) + (read-sockaddr-in bv index)) ((= family AF_INET6) - (match (read-sockaddr-in6 bv index) - ((family port flowinfo address scopeid) - (make-socket-address family address port - flowinfo scopeid)))) + (read-sockaddr-in6 bv index)) (else "unsupported socket address family" family)))) -- cgit v1.2.3 From 3b307162e892e0050836434b12e14376758419cc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 18 Jul 2015 00:14:04 +0200 Subject: publish: Write hashes in nix-base32 format. * guix/scripts/publish.scm (narinfo-string): Use 'bytevector->nix-base32-string', not 'bytevector->base32-string'. --- guix/scripts/publish.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 7bad2619b9..e0226f35ee 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -143,7 +143,7 @@ (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))) - (hash (bytevector->base32-string + (hash (bytevector->nix-base32-string (path-info-hash path-info))) (size (path-info-nar-size path-info)) (references (string-join -- cgit v1.2.3 From 6e9f2913ba800e3488b95c661438f3981095a259 Mon Sep 17 00:00:00 2001 From: pjotrp Date: Mon, 13 Jul 2015 15:32:36 +0200 Subject: build-system/ruby: Add #:gem-flags parameter. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/build-system/ruby.scm (build): add 'gem-flags' key * guix/build/ruby-build-system.scm (build): use 'gem-flags' key * doc/guix.texi (Build Systems): Mention #:gem-flags. Co-authored-by: Ludovic Courtès --- doc/guix.texi | 3 ++- guix/build-system/ruby.scm | 2 ++ guix/build/ruby-build-system.scm | 12 +++++++----- 3 files changed, 11 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 0d24b12f8c..71b3b2d529 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2458,7 +2458,8 @@ implements the RubyGems build procedure used by Ruby packages, which involves running @code{gem build} followed by @code{gem install}. Which Ruby package is used can be specified with the @code{#:ruby} -parameter. +parameter. A list of additional flags to be passed to the @command{gem} +command can be specified with the @code{#:gem-flags} parameter. @end defvr @defvr {Scheme Variable} waf-build-system diff --git a/guix/build-system/ruby.scm b/guix/build-system/ruby.scm index e4fda30cf3..135eda665b 100644 --- a/guix/build-system/ruby.scm +++ b/guix/build-system/ruby.scm @@ -71,6 +71,7 @@ (define private-keywords (define* (ruby-build store name inputs #:key + (gem-flags ''()) (test-target "test") (tests? #t) (phases '(@ (guix build ruby-build-system) @@ -95,6 +96,7 @@ (define builder (source source)) #:system ,system + #:gem-flags ,gem-flags #:test-target ,test-target #:tests? ,tests? #:phases ,phases diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm index fce39b8dfd..307ac919dd 100644 --- a/guix/build/ruby-build-system.scm +++ b/guix/build/ruby-build-system.scm @@ -63,7 +63,8 @@ (define* (check #:key tests? test-target #:allow-other-keys) (zero? (system* "rake" test-target)) #t)) -(define* (install #:key source inputs outputs #:allow-other-keys) +(define* (install #:key source inputs outputs (gem-flags '()) + #:allow-other-keys) (let* ((ruby-version (match:substring (string-match "ruby-(.*)\\.[0-9]$" (assoc-ref inputs "ruby")) @@ -72,10 +73,11 @@ (define* (install #:key source inputs outputs #:allow-other-keys) (gem-home (string-append out "/lib/ruby/gems/" ruby-version ".0"))) (setenv "GEM_HOME" gem-home) (mkdir-p gem-home) - (zero? (system* "gem" "install" "--local" - (first-matching-file "\\.gem$") - ;; Executables should go into /bin, not /lib/ruby/gems. - "--bindir" (string-append out "/bin"))))) + (zero? (apply system* "gem" "install" "--local" + (first-matching-file "\\.gem$") + ;; Executables should go into /bin, not /lib/ruby/gems. + "--bindir" (string-append out "/bin") + gem-flags)))) (define %standard-phases (modify-phases gnu:%standard-phases -- cgit v1.2.3