From 95fa173ed12b832315d119d635b85813bb5317bd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 19 Jun 2016 21:29:43 +0200 Subject: store: 'register-path' no longer swallows 'system-error' exceptions. * guix/store.scm (register-path): Do not catch 'system-error'. --- guix/store.scm | 31 +++++++++++++------------------ 1 file changed, 13 insertions(+), 18 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index a64016611..276684e2f 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1061,24 +1061,19 @@ Return #t on success. Use with care as it directly modifies the store! This is primarily meant to be used internally by the daemon's build hook." ;; Currently this is implemented by calling out to the fine C++ blob. - (catch 'system-error - (lambda () - (let ((pipe (apply open-pipe* OPEN_WRITE %guix-register-program - `(,@(if prefix - `("--prefix" ,prefix) - '()) - ,@(if state-directory - `("--state-directory" ,state-directory) - '()))))) - (and pipe - (begin - (format pipe "~a~%~a~%~a~%" - path (or deriver "") (length references)) - (for-each (cut format pipe "~a~%" <>) references) - (zero? (close-pipe pipe)))))) - (lambda args - ;; Failed to run %GUIX-REGISTER-PROGRAM. - #f))) + (let ((pipe (apply open-pipe* OPEN_WRITE %guix-register-program + `(,@(if prefix + `("--prefix" ,prefix) + '()) + ,@(if state-directory + `("--state-directory" ,state-directory) + '()))))) + (and pipe + (begin + (format pipe "~a~%~a~%~a~%" + path (or deriver "") (length references)) + (for-each (cut format pipe "~a~%" <>) references) + (zero? (close-pipe pipe)))))) ;;; -- cgit v1.3 From cbbbb7be0fbaa11ff75bce92f2d82131ff8db104 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 19 Jun 2016 22:15:15 +0200 Subject: utils: 'current-source-directory' resolves relative file names at run time. * guix/utils.scm (absolute-dirname): New procedure. (current-source-directory): Emit code to use it instead of calling 'search-path'. --- guix/utils.scm | 20 +++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/utils.scm b/guix/utils.scm index a642bd3d6..0e20be3c1 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -702,6 +702,18 @@ output port, and PROC's result is returned." ;;; Source location. ;;; +(define (absolute-dirname file) + "Return the absolute name of the directory containing FILE, or #f upon +failure." + (match (search-path %load-path file) + (#f #f) + ((? string? file) + ;; If there are relative names in %LOAD-PATH, FILE can be relative and + ;; needs to be canonicalized. + (if (string-prefix? "/" file) + (dirname file) + (canonicalize-path (dirname file)))))) + (define-syntax current-source-directory (lambda (s) "Return the absolute name of the current directory, or #f if it could not @@ -711,11 +723,13 @@ be determined." (match (assq 'filename (syntax-source s)) (('filename . (? string? file-name)) ;; If %FILE-PORT-NAME-CANONICALIZATION is 'relative, then FILE-NAME - ;; can be relative. In that case, we try to find out the absolute - ;; file name by looking at %LOAD-PATH. + ;; can be relative. In that case, we try to find out at run time + ;; the absolute file name by looking at %LOAD-PATH; doing this at + ;; run time rather than expansion time is necessary to allow files + ;; to be moved on the file system. (if (string-prefix? "/" file-name) (dirname file-name) - (and=> (search-path %load-path file-name) dirname))) + #`(absolute-dirname #,file-name))) (_ #f)))))) -- cgit v1.3 From a68d0f6fd5a93dc80fe9d919413f5d3e8db2a5b4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 19 Jun 2016 22:30:34 +0200 Subject: utils: 'current-source-directory' gracefully handles lack of source info. * guix/utils.scm (current-source-directory): Add case for when FILE-NAME is #f. --- guix/utils.scm | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/utils.scm b/guix/utils.scm index 0e20be3c1..69f4e78a8 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -727,9 +727,12 @@ be determined." ;; the absolute file name by looking at %LOAD-PATH; doing this at ;; run time rather than expansion time is necessary to allow files ;; to be moved on the file system. - (if (string-prefix? "/" file-name) - (dirname file-name) - #`(absolute-dirname #,file-name))) + (cond ((not file-name) + #f) ;raising an error would upset Geiser users + ((string-prefix? "/" file-name) + (dirname file-name)) + (else + #`(absolute-dirname #,file-name)))) (_ #f)))))) -- cgit v1.3 From a9601e23528c6018a3a6d4ad44b7d119df67ab6b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 20 Jun 2016 23:46:32 +0200 Subject: gexp: Use a relative file name. This is a followup to cbbbb7be0fbaa11ff75bce92f2d82131ff8db104. * guix/gexp.scm (%utils-module): Use a file name relative to this file instead of using 'search-path'. --- guix/gexp.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index 2bf1013b3..b929b79c2 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -856,8 +856,10 @@ and in the current monad setting (system type, etc.)" (define %utils-module ;; This file provides 'mkdir-p', needed to implement 'imported-files' and - ;; other primitives below. - (local-file (search-path %load-path "guix/build/utils.scm") + ;; other primitives below. Note: We give the file name relative to this + ;; file you are currently reading; 'search-path' could return a file name + ;; relative to the current working directory. + (local-file "build/utils.scm" "build-utils.scm")) (define* (imported-files files -- cgit v1.3 From 2831675bfd4d4ba78f6511cf7698ee745d1fbf33 Mon Sep 17 00:00:00 2001 From: Alex Kost Date: Mon, 20 Jun 2016 15:49:04 +0300 Subject: build: emacs: Search for elisp in "share/emacs/site-lisp". * guix/build/emacs-build-system.scm (emacs-inputs-el-directories): Add ".../share/emacs/site-lisp" directory to the returned result as elisp files can also be placed there. --- guix/build/emacs-build-system.scm | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm index ab970012a..44e8b0d31 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -1,5 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Federico Beffa +;;; Copyright © 2016 David Thompson +;;; Copyright © 2016 Alex Kost ;;; ;;; This file is part of GNU Guix. ;;; @@ -152,10 +154,11 @@ store in '.el' files." (define (emacs-inputs-el-directories dirs) "Build the list of Emacs Lisp directories from the Emacs package directory DIRS." - (map (lambda (d) - (string-append d %install-suffix "/" - (store-directory->elpa-name-version d))) - dirs)) + (append-map (lambda (d) + (list (string-append d "/share/emacs/site-lisp") + (string-append d %install-suffix "/" + (store-directory->elpa-name-version d)))) + dirs)) (define (package-name-version->elpa-name-version name-ver) "Convert the Guix package NAME-VER to the corresponding ELPA name-version -- cgit v1.3 From 3583b27b2cb42ac8c88e7f53df2e3101d5a82ede Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 22 Jun 2016 23:39:57 +0200 Subject: utils: 'cache-directory' honors 'XDG_CACHE_HOME'. * guix/utils.scm (cache-directory): Honor 'XDG_CACHE_HOME', not 'XDG_CONFIG_HOME'. --- guix/utils.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/utils.scm b/guix/utils.scm index 69f4e78a8..6bcee1777 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -637,7 +637,7 @@ output port, and PROC's result is returned." (define (cache-directory) "Return the cache directory for Guix, by default ~/.cache/guix." - (or (getenv "XDG_CONFIG_HOME") + (or (getenv "XDG_CACHE_HOME") (and=> (or (getenv "HOME") (passwd:dir (getpwuid (getuid)))) (cut string-append <> "/.cache/guix")))) -- cgit v1.3 From f10dcbf1a92c147a2fedba6f774afa6a7013fcdf Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 22 Jun 2016 23:46:32 +0200 Subject: substitute: Use ~/.cache when invoked by an unprivileged user. This is a followup to ea0c6e0507a6997f12a4f29d0445b51cf53bd81e. * guix/scripts/substitute.scm (%narinfo-cache-directory): Use 'cache-directory' when (getuid) returns non-zero. (cache-narinfo!): Remove 'catch'. --- guix/scripts/substitute.scm | 28 +++++++++++++--------------- 1 file changed, 13 insertions(+), 15 deletions(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 81ce770dc..5722aa821 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -94,10 +94,15 @@ ;;; Code: (define %narinfo-cache-directory - ;; A local cache of narinfos, to avoid going to the network. - (or (and=> (getenv "XDG_CACHE_HOME") - (cut string-append <> "/guix/substitute")) - (string-append %state-directory "/substitute/cache"))) + ;; A local cache of narinfos, to avoid going to the network. Most of the + ;; time, 'guix substitute' is called by guix-daemon as root and stores its + ;; cached data in /var/guix/…. However, when invoked from 'guix challenge' + ;; as a user, it stores its cache in ~/.cache. + (if (zero? (getuid)) + (or (and=> (getenv "XDG_CACHE_HOME") + (cut string-append <> "/guix/substitute")) + (string-append %state-directory "/substitute/cache")) + (string-append (cache-directory) "/substitute"))) (define %allow-unauthenticated-substitutes? ;; Whether to allow unchecked substitutes. This is useful for testing @@ -501,17 +506,10 @@ indicates that PATH is unavailable at CACHE-URL." (value ,(and=> narinfo narinfo->string)))) (let ((file (narinfo-cache-file cache-url path))) - (catch 'system-error - (lambda () - (mkdir-p (dirname file)) - (with-atomic-file-output file - (lambda (out) - (write (cache-entry cache-url narinfo) out)))) - (lambda args - ;; We may not have write access to the local cache when called from an - ;; unprivileged process such as 'guix challenge'. - (unless (= EACCES (system-error-errno args)) - (apply throw args))))) + (mkdir-p (dirname file)) + (with-atomic-file-output file + (lambda (out) + (write (cache-entry cache-url narinfo) out)))) narinfo) -- cgit v1.3 From bae06364c16d7e36bc17e636637f9943855bf0df Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Sun, 22 May 2016 14:56:06 +0300 Subject: bournish: Add 'wc' command. * guix/build/bournish.scm (lines+chars, file-exists?*, wc-print) (wc-l-print, wc-c-print, wc-command, wc-command-implementation) (wc-l-command-implementation, wc-c-command-implementation): New procedures. (%commands): Add 'wc'. Co-authored-by: Ludovic Courtès --- guix/build/bournish.scm | 62 ++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 61 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/bournish.scm b/guix/build/bournish.scm index 1f17e0a22..928bef5b9 100644 --- a/guix/build/bournish.scm +++ b/guix/build/bournish.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,6 +26,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 ftw) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:export (%bournish-language)) @@ -103,6 +105,63 @@ characters." ((@ (guix build utils) dump-port) port (current-output-port)) *unspecified*))) +(define (lines+chars port) + "Return the number of lines and number of chars read from PORT." + (let loop ((lines 0) (chars 0)) + (match (read-char port) + ((? eof-object?) ;done! + (values lines chars)) + (#\newline ;recurse + (loop (1+ lines) (1+ chars))) + (_ ;recurse + (loop lines (1+ chars)))))) + +(define (file-exists?* file) + "Like 'file-exists?' but emits a warning if FILE is not accessible." + (catch 'system-error + (lambda () + (stat file)) + (lambda args + (let ((errno (system-error-errno args))) + (format (current-error-port) "~a: ~a~%" + file (strerror errno)) + #f)))) + +(define (wc-print file) + (let-values (((lines chars) + (call-with-input-file file lines+chars))) + (format #t "~a ~a ~a~%" lines chars file))) + +(define (wc-l-print file) + (let-values (((lines chars) + (call-with-input-file file lines+chars))) + (format #t "~a ~a~%" lines file))) + +(define (wc-c-print file) + (let-values (((lines chars) + (call-with-input-file file lines+chars))) + (format #t "~a ~a~%" chars file))) + +(define (wc-command-implementation . files) + (for-each wc-print (filter file-exists?* files))) + +(define (wc-l-command-implementation . files) + (for-each wc-l-print (filter file-exists?* files))) + +(define (wc-c-command-implementation . files) + (for-each wc-c-print (filter file-exists?* files))) + +(define (wc-command . args) + "Emit code for the 'wc' command." + (cond ((member "-l" args) + `((@@ (guix build bournish) wc-l-command-implementation) + ,@(delete "-l" args))) + ((member "-c" args) + `((@@ (guix build bournish) wc-c-command-implementation) + ,@(delete "-c" args))) + (else + `((@@ (guix build bournish) wc-command-implementation) ,@args)))) + (define (help-command . _) (display "\ Hello, this is Bournish, a minimal Bourne-like shell in Guile! @@ -129,7 +188,8 @@ commands such as 'ls' and 'cd'; it lacks globbing, pipes---everything.\n")) ("help" ,help-command) ("ls" ,ls-command) ("which" ,which-command) - ("cat" ,cat-command))) + ("cat" ,cat-command) + ("wc" ,wc-command))) (define (read-bournish port env) "Read a Bournish expression from PORT, and return the corresponding Scheme -- cgit v1.3 From 934c5d5b28f74ab2fe187ad727e4b56cfda6def8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 25 Jun 2016 00:58:48 +0200 Subject: utils: 'cache-directory' always appends "/guix". Fixes . Fixes a regression introduced in f10dcbf1a92c147a2fedba6f774afa6a7013fcdf. Reported by myglc2 . * guix/utils.scm (cache-directory): Always append "/guix". --- guix/utils.scm | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/utils.scm b/guix/utils.scm index 6bcee1777..9e1b8ead0 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -637,10 +637,11 @@ output port, and PROC's result is returned." (define (cache-directory) "Return the cache directory for Guix, by default ~/.cache/guix." - (or (getenv "XDG_CACHE_HOME") - (and=> (or (getenv "HOME") - (passwd:dir (getpwuid (getuid)))) - (cut string-append <> "/.cache/guix")))) + (string-append (or (getenv "XDG_CACHE_HOME") + (and=> (or (getenv "HOME") + (passwd:dir (getpwuid (getuid)))) + (cut string-append <> "/.cache"))) + "/guix")) (define (readlink* file) "Call 'readlink' until the result is not a symlink." -- cgit v1.3 From 8ea8e8d3c332d2b187c26762c8e9e7930f6c2cb7 Mon Sep 17 00:00:00 2001 From: 宋文武 Date: Thu, 23 Jun 2016 19:23:28 +0800 Subject: guix: python-build-system: Change pypi-uri to use https://pypi.io. * guix/build-system/python.scm (pypi-uri): Use https://pypi.io. * gnu/packages/python.scm (python-twisted)[uri]: Remove https://pypi.io. --- gnu/packages/python.scm | 5 +---- guix/build-system/python.scm | 2 +- 2 files changed, 2 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/gnu/packages/python.scm b/gnu/packages/python.scm index 4567a91e5..8c34ff2e4 100644 --- a/gnu/packages/python.scm +++ b/gnu/packages/python.scm @@ -9097,10 +9097,7 @@ to provide a high-level synchronous API on top of the libev event loop.") (version "16.2.0") (source (origin (method url-fetch) - (uri (list (pypi-uri "Twisted" version ".tar.bz2") ; 404 - (string-append - "https://pypi.io/packages/source/T/Twisted/" - "Twisted-" version ".tar.bz2"))) + (uri (pypi-uri "Twisted" version ".tar.bz2")) (sha256 (base32 "0ydxrp9myw1mvsz3qfzx5579y5llmqa82pxvqchgp5syczffi450")))) diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index c3d6c6240..705943eb7 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -48,7 +48,7 @@ "Return a URI string for the Python package hosted on the Python Package 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-append "https://pypi.io/packages/source/" (string-take name 1) "/" name "/" name "-" version extension)) -- cgit v1.3 From aebd383d04b351465cfb14e4fd0949b67d4b282e Mon Sep 17 00:00:00 2001 From: Cyril Roelandt Date: Fri, 17 Jun 2016 14:11:08 +0200 Subject: import: pypi: do not fail when 'run_requires' is missing from the metadata. * guix/import/pypi.scm (read-wheel-metadata): do not crash when 'run_requires' is missing from the metadata. --- guix/import/pypi.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index 70ef50766..efa69081e 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -175,8 +175,10 @@ cannot determine package dependencies")) (lambda (port) (let* ((metadata (json->scm port)) (run_requires (hash-ref metadata "run_requires")) - (requirements (hash-ref (list-ref run_requires 0) - "requires"))) + (requirements (if run_requires + (hash-ref (list-ref run_requires 0) + "requires") + '()))) (map (lambda (r) (python->package-name (clean-requirement r))) requirements))))) -- cgit v1.3 From 9dd674db017dbdc451cfd35da2dc3ce08db0726a Mon Sep 17 00:00:00 2001 From: David Craven Date: Thu, 23 Jun 2016 19:44:38 +0200 Subject: daemon: Rename 'NIX_CONF_DIR' to 'GUIX_CONFIGURATION_DIRECTORY'. Partly fixes . Reported by Jeff Mickey and David Craven . * nix/libstore/globals.cc (Settings::processEnvironment()): Change 'NIX_CONF_DIR' to 'GUIX_CONFIGURATION_DIRECTORY'. * nix/local.mk (libstore_a_CPPFLAGS): Likewise. * guix/config.scm.in (%config-directory): Likewise. * build-aux/test-env.in: Likewise. * gnu/packages/patches/hydra-automake-1.15.patch: Likewise. Signed-off-by: Ludovic Courtès --- build-aux/test-env.in | 12 ++++++------ gnu/packages/patches/hydra-automake-1.15.patch | 4 ++-- guix/config.scm.in | 4 ++-- nix/libstore/globals.cc | 2 +- nix/local.mk | 2 +- 5 files changed, 12 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/build-aux/test-env.in b/build-aux/test-env.in index c153763a5..1657556b1 100644 --- a/build-aux/test-env.in +++ b/build-aux/test-env.in @@ -69,16 +69,16 @@ then fi # The configuration directory, for import/export signing keys. - NIX_CONF_DIR="@GUIX_TEST_ROOT@/etc" - if [ ! -d "$NIX_CONF_DIR" ] + GUIX_CONFIGURATION_DIRECTORY="@GUIX_TEST_ROOT@/etc" + if [ ! -d "$GUIX_CONFIGURATION_DIRECTORY" ] then # Copy the keys so that the secret key has the right permissions (the # daemon errors out when this is not the case.) - mkdir -p "$NIX_CONF_DIR" + mkdir -p "$GUIX_CONFIGURATION_DIRECTORY" cp "@abs_top_srcdir@/tests/signing-key.sec" \ "@abs_top_srcdir@/tests/signing-key.pub" \ - "$NIX_CONF_DIR" - chmod 400 "$NIX_CONF_DIR/signing-key.sec" + "$GUIX_CONFIGURATION_DIRECTORY" + chmod 400 "$GUIX_CONFIGURATION_DIRECTORY/signing-key.sec" fi # A place to store data of the substituter. @@ -100,7 +100,7 @@ then NIX_LOCALSTATE_DIR NIX_LOG_DIR NIX_STATE_DIR NIX_DB_DIR \ NIX_ROOT_FINDER GUIX_BINARY_SUBSTITUTE_URL \ GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES \ - NIX_CONF_DIR XDG_CACHE_HOME NIXPKGS + GUIX_CONFIGURATION_DIRECTORY XDG_CACHE_HOME NIXPKGS # Launch the daemon without chroot support because is may be # unavailable, for instance if we're not running as root. diff --git a/gnu/packages/patches/hydra-automake-1.15.patch b/gnu/packages/patches/hydra-automake-1.15.patch index 0d8fa9851..91c7b9202 100644 --- a/gnu/packages/patches/hydra-automake-1.15.patch +++ b/gnu/packages/patches/hydra-automake-1.15.patch @@ -23,7 +23,7 @@ Automake's parallel test harness. - HYDRA_HOME="$(top_srcdir)/src" \ - HYDRA_CONFIG= \ - NIX_REMOTE= \ -- NIX_CONF_DIR="$(abs_builddir)/nix/etc/nix" \ +- GUIX_CONFIGURATION_DIRECTORY="$(abs_builddir)/nix/etc/nix" \ - NIX_STATE_DIR="$(abs_builddir)/nix/var/nix" \ - NIX_MANIFESTS_DIR="$(abs_builddir)/nix/var/nix/manifests" \ - NIX_STORE_DIR="$(abs_builddir)/nix/store" \ @@ -39,7 +39,7 @@ Automake's parallel test harness. + HYDRA_HOME="$(top_srcdir)/src"; export HYDRA_HOME; \ + HYDRA_CONFIG=; export HYDRA_CONFIG; \ + NIX_REMOTE=; export NIX_REMOTE; \ -+ NIX_CONF_DIR="$(abs_builddir)/nix/etc/nix"; export NIX_CONF_DIR; \ ++ GUIX_CONFIGURATION_DIRECTORY="$(abs_builddir)/nix/etc/nix"; export GUIX_CONFIGURATION_DIRECTORY; \ + NIX_STATE_DIR="$(abs_builddir)/nix/var/nix"; export NIX_STATE_DIR; \ + NIX_MANIFESTS_DIR="$(abs_builddir)/nix/var/nix/manifests"; export NIX_MANIFESTS_DIR; \ + NIX_STORE_DIR="$(abs_builddir)/nix/store"; export NIX_STORE_DIR; \ diff --git a/guix/config.scm.in b/guix/config.scm.in index d7df9f7d2..adffa0cfe 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -59,8 +59,8 @@ (or (getenv "NIX_STATE_DIR") "@guix_localstatedir@/guix")) (define %config-directory - ;; This must match `NIX_CONF_DIR' as defined in `nix/local.mk'. - (or (getenv "NIX_CONF_DIR") "@guix_sysconfdir@/guix")) + ;; This must match `GUIX_CONFIGURATION_DIRECTORY' as defined in `nix/local.mk'. + (or (getenv "GUIX_CONFIGURATION_DIRECTORY") "@guix_sysconfdir@/guix")) (define %guix-register-program ;; The 'guix-register' program. diff --git a/nix/libstore/globals.cc b/nix/libstore/globals.cc index 84fc885eb..65dad24d9 100644 --- a/nix/libstore/globals.cc +++ b/nix/libstore/globals.cc @@ -67,7 +67,7 @@ void Settings::processEnvironment() nixLogDir = canonPath(getEnv("NIX_LOG_DIR", NIX_LOG_DIR)); nixStateDir = canonPath(getEnv("NIX_STATE_DIR", NIX_STATE_DIR)); nixDBPath = getEnv("NIX_DB_DIR", nixStateDir + "/db"); - nixConfDir = canonPath(getEnv("NIX_CONF_DIR", NIX_CONF_DIR)); + nixConfDir = canonPath(getEnv("GUIX_CONFIGURATION_DIRECTORY", GUIX_CONFIGURATION_DIRECTORY)); nixLibexecDir = canonPath(getEnv("NIX_LIBEXEC_DIR", NIX_LIBEXEC_DIR)); nixBinDir = canonPath(getEnv("NIX_BIN_DIR", NIX_BIN_DIR)); nixDaemonSocketFile = canonPath(nixStateDir + DEFAULT_SOCKET_PATH); diff --git a/nix/local.mk b/nix/local.mk index 07a92f74e..b0e9bc1a2 100644 --- a/nix/local.mk +++ b/nix/local.mk @@ -106,7 +106,7 @@ libstore_a_CPPFLAGS = \ -DNIX_DATA_DIR=\"$(datadir)\" \ -DNIX_STATE_DIR=\"$(localstatedir)/guix\" \ -DNIX_LOG_DIR=\"$(localstatedir)/log/guix\" \ - -DNIX_CONF_DIR=\"$(sysconfdir)/guix\" \ + -DGUIX_CONFIGURATION_DIRECTORY=\"$(sysconfdir)/guix\" \ -DNIX_LIBEXEC_DIR=\"$(libexecdir)\" \ -DNIX_BIN_DIR=\"$(bindir)\" \ -DOPENSSL_PATH="\"guix-authenticate\"" \ -- cgit v1.3 From 242ad41c0129eabfdc6678ae9eebd1c887ece55e Mon Sep 17 00:00:00 2001 From: David Thompson Date: Tue, 28 Jun 2016 09:36:34 -0400 Subject: download: Use basic authentication when userinfo is present in URI. * guix/download.scm (url-fetch): Include (guix base64) module on the build-side. * guix/build/download.scm (http-fetch): Add "Authorization" header when userinfo is present in the URI. --- guix/build/download.scm | 14 ++++++++++++-- guix/download.scm | 3 ++- 2 files changed, 14 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index bd011ce87..103e784bb 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -23,9 +23,11 @@ #:use-module (web http) #:use-module ((web client) #:hide (open-socket-for-uri)) #:use-module (web response) + #:use-module (guix base64) #:use-module (guix ftp-client) #:use-module (guix build utils) #:use-module (rnrs io ports) + #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) @@ -598,14 +600,22 @@ FILE on success." (string>? (version) "2.0.7"))) (define headers - '(;; Some web sites, such as http://dist.schmorp.de, would block you if + `(;; Some web sites, such as http://dist.schmorp.de, would block you if ;; there's no 'User-Agent' header, presumably on the assumption that ;; you're a spammer. So work around that. (User-Agent . "GNU Guile") ;; Some servers, such as https://alioth.debian.org, return "406 Not ;; Acceptable" when not explicitly told that everything is accepted. - (Accept . "*/*"))) + (Accept . "*/*") + + ;; Basic authentication, if needed. + ,@(match (uri-userinfo uri) + ((? string? str) + `((Authorization . ,(string-append "Basic " + (base64-encode + (string->utf8 str)))))) + (_ '())))) (let*-values (((connection) (open-connection-for-uri uri #:timeout timeout)) diff --git a/guix/download.scm b/guix/download.scm index 9b238dcbd..c3f34f552 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -328,7 +328,8 @@ in the store." #:modules '((guix build download) (guix build utils) (guix ftp-client) - (guix base32)) + (guix base32) + (guix base64)) ;; Use environment variables and a fixed script ;; name so there's only one script in store for -- cgit v1.3 From 8aa5e15ebd535019523b35f85b3f772afa008608 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 2 Jul 2016 16:23:40 +0200 Subject: download: Update CPAN mirrors. * guix/download.scm (%mirrors)[cpan]: Remove enstimac.fr, which seems dead; add ibcp.fr. --- guix/download.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/download.scm b/guix/download.scm index c3f34f552..c75a65592 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -168,7 +168,7 @@ "http://x.cs.pu.edu.tw/" "ftp://ftp.is.co.za/pub/x.org") ; South Africa (cpan ; from http://www.cpan.org/SITES.html - "http://cpan.enstimac.fr/" + "http://mirror.ibcp.fr/pub/CPAN/" "ftp://ftp.ciril.fr/pub/cpan/" "ftp://artfiles.org/cpan.org/" "http://www.cpan.org/" -- cgit v1.3 From 140dd8f82c4b513c182a71bbd61a9cfa1360782a Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Thu, 30 Jun 2016 15:43:23 +0200 Subject: guix: Support authentication when fetching from SVN. * guix/svn-download.scm (): Add fields for optional credentials. (svn-fetch): Pass credentials to build-side "svn-fetch". * guix/build/svn.scm (svn-fetch): Pass optional credentials to svn command. --- guix/build/svn.scm | 21 ++++++++++++++------- guix/svn-download.scm | 10 +++++++--- 2 files changed, 21 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/build/svn.scm b/guix/build/svn.scm index 74fe084da..31c30edaf 100644 --- a/guix/build/svn.scm +++ b/guix/build/svn.scm @@ -29,15 +29,22 @@ ;;; Code: (define* (svn-fetch url revision directory - #:key (svn-command "svn")) + #:key (svn-command "svn") + (user-name #f) + (password #f)) "Fetch REVISION from URL into DIRECTORY. REVISION must be an integer, and a valid Subversion revision. Return #t on success, #f otherwise." - (and (zero? (system* svn-command "checkout" "--non-interactive" - ;; Trust the server certificate. This is OK as we - ;; verify the checksum later. This can be removed when - ;; ca-certificates package is added. - "--trust-server-cert" "-r" (number->string revision) - url directory)) + (and (zero? (apply system* svn-command + "checkout" "--non-interactive" + ;; Trust the server certificate. This is OK as we + ;; verify the checksum later. This can be removed when + ;; ca-certificates package is added. + "--trust-server-cert" "-r" (number->string revision) + `(,@(if (and user-name password) + (list (string-append "--username=" user-name) + (string-append "--password=" password)) + '()) + ,url ,directory))) (with-directory-excursion directory (begin ;; The contents of '.svn' vary as a function of the current status diff --git a/guix/svn-download.scm b/guix/svn-download.scm index d6853ca86..dddf6485c 100644 --- a/guix/svn-download.scm +++ b/guix/svn-download.scm @@ -41,8 +41,10 @@ (define-record-type* svn-reference make-svn-reference svn-reference? - (url svn-reference-url) ; string - (revision svn-reference-revision)) ; number + (url svn-reference-url) ; string + (revision svn-reference-revision) ; number + (user-name svn-reference-user-name (default #f)) + (password svn-reference-password (default #f))) (define (subversion-package) "Return the default Subversion package." @@ -62,7 +64,9 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (svn-fetch '#$(svn-reference-url ref) '#$(svn-reference-revision ref) #$output - #:svn-command (string-append #+svn "/bin/svn")))) + #:svn-command (string-append #+svn "/bin/svn") + #:user-name #$(svn-reference-user-name ref) + #:password #$(svn-reference-password ref)))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "svn-checkout") build -- cgit v1.3 From 5b8e564ccdc734cda20d151adc1d60d7119fff3b Mon Sep 17 00:00:00 2001 From: Alex Sassmannshausen Date: Sat, 2 Jul 2016 20:06:02 +0200 Subject: import: cpan: Use our mirrors for 'https' URLs. * guix/import/cpan.scm (fix-source-url): New procedure. (cpan-module->sexp): Use it to construct our source-url. * tests/cpan.scm: Add tests for fix-source-url. Signed-off-by: Ludovic Courtès --- guix/import/cpan.scm | 13 +++++++++---- tests/cpan.scm | 11 +++++++++++ 2 files changed, 20 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm index ad61ee791..213a155fd 100644 --- a/guix/import/cpan.scm +++ b/guix/import/cpan.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Eric Bavier ;;; Copyright © 2015 Mark H Weaver +;;; Copyright © 2016 Alex Sassmannshausen ;;; ;;; This file is part of GNU Guix. ;;; @@ -99,6 +100,13 @@ or #f on failure. MODULE should be e.g. \"Test::Script\"" (define (cpan-home name) (string-append "http://search.cpan.org/dist/" name)) +(define (fix-source-url download-url) + "Return a new download URL based on DOWNLOAD-URL which now uses our mirrors, +if the original's domain was metacpan." + (regexp-substitute/global #f "http[s]?://cpan.metacpan.org" download-url + 'pre "mirror://cpan" 'post)) + + (define %corelist (delay (let* ((perl (with-store store @@ -183,10 +191,7 @@ META." (list (list guix-name (list 'quasiquote inputs)))))) - (define source-url - (regexp-substitute/global #f "http://cpan.metacpan.org" - (assoc-ref meta "download_url") - 'pre "mirror://cpan" 'post)) + (define source-url (fix-source-url (assoc-ref meta "download_url"))) (let ((tarball (with-store store (download-to-store store source-url)))) diff --git a/tests/cpan.scm b/tests/cpan.scm index 5d56f0bd2..898081b3e 100644 --- a/tests/cpan.scm +++ b/tests/cpan.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Eric Bavier +;;; Copyright © 2016 Alex Sassmannshausen ;;; ;;; This file is part of GNU Guix. ;;; @@ -97,4 +98,14 @@ (x (pk 'fail x #f))))) +(test-equal "source-url-http" + ((@@ (guix import cpan) fix-source-url) + "http://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz") + "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz") + +(test-equal "source-url-https" + ((@@ (guix import cpan) fix-source-url) + "https://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz") + "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz") + (test-end "cpan") -- cgit v1.3 From affd7761f3b38f7d5670a4e91fefef72174621cc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 2 Jul 2016 23:19:40 +0200 Subject: gexp: Keep only a single 'references' field. The distinction between native inputs and "normal" inputs can already be determined by looking at the 'native?' field of . The extra 'natives' field of added complexity for no good reason. * guix/gexp.scm ()[natives]: Remove. (write-gexp): Remove use of 'gexp-native-references'. (gexp-inputs)[native-input?]: New procedure. Use it. (gexp->sexp)[reference->sexp]: Honor N? for input lists. Remove use of 'gexp-native-references'. (gexp)[collect-native-escapes]: Remove. Simplify. --- guix/gexp.scm | 57 +++++++++++++++------------------------------------------ 1 file changed, 15 insertions(+), 42 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index b929b79c2..c86f4d0fd 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -98,11 +98,10 @@ ;; "G expressions". (define-record-type - (make-gexp references natives proc) + (make-gexp references proc) gexp? - (references gexp-references) ; ((DRV-OR-PKG OUTPUT) ...) - (natives gexp-native-references) ; ((DRV-OR-PKG OUTPUT) ...) - (proc gexp-proc)) ; procedure + (references gexp-references) ;list of + (proc gexp-proc)) ;procedure (define (write-gexp gexp port) "Write GEXP on PORT." @@ -113,8 +112,7 @@ ;; tries to use 'append' on that, which fails with wrong-type-arg. (false-if-exception (write (apply (gexp-proc gexp) - (append (gexp-references gexp) - (gexp-native-references gexp))) + (gexp-references gexp)) port)) (format port " ~a>" (number->string (object-address gexp) 16))) @@ -630,11 +628,15 @@ references; otherwise, return only non-native references." ;; Ignore references to other kinds of objects. result))) + (define (native-input? x) + (and (gexp-input? x) + (gexp-input-native? x))) + (fold-right add-reference-inputs '() (if native? - (gexp-native-references exp) - (gexp-references exp)))) + (filter native-input? (gexp-references exp)) + (remove native-input? (gexp-references exp))))) (define gexp-native-inputs (cut gexp-inputs <> #:native? #t)) @@ -687,7 +689,7 @@ and in the current monad setting (system type, etc.)" (if (gexp-input? ref) ref (%gexp-input ref "out" n?)) - native?)) + (or n? native?))) refs))) (($ (? struct? thing) output n?) (let ((target (if (or n? native?) #f target))) @@ -706,9 +708,7 @@ and in the current monad setting (system type, etc.)" (mlet %store-monad ((args (sequence %store-monad - (append (map reference->sexp (gexp-references exp)) - (map (cut reference->sexp <> #t) - (gexp-native-references exp)))))) + (map reference->sexp (gexp-references exp))))) (return (apply (gexp-proc exp) args)))) (define (syntax-location-string s) @@ -741,33 +741,9 @@ and in the current monad setting (system type, etc.)" ((ungexp-splicing _ ...) (cons exp result)) ((ungexp-native _ ...) - result) - ((ungexp-native-splicing _ ...) - result) - ((exp0 exp ...) - (let ((result (loop #'exp0 result))) - (fold loop result #'(exp ...)))) - (_ - result)))) - - (define (collect-native-escapes exp) - ;; Return all the 'ungexp-native' forms present in EXP. - (let loop ((exp exp) - (result '())) - (syntax-case exp (ungexp - ungexp-splicing - ungexp-native - ungexp-native-splicing) - ((ungexp-native _) - (cons exp result)) - ((ungexp-native _ _) (cons exp result)) ((ungexp-native-splicing _ ...) (cons exp result)) - ((ungexp _ ...) - result) - ((ungexp-splicing _ ...) - result) ((exp0 exp ...) (let ((result (loop #'exp0 result))) (fold loop result #'(exp ...)))) @@ -838,14 +814,11 @@ and in the current monad setting (system type, etc.)" (syntax-case s (ungexp output) ((_ exp) - (let* ((normals (delete-duplicates (collect-escapes #'exp))) - (natives (delete-duplicates (collect-native-escapes #'exp))) - (escapes (append normals natives)) + (let* ((escapes (delete-duplicates (collect-escapes #'exp))) (formals (generate-temporaries escapes)) (sexp (substitute-references #'exp (zip escapes formals))) - (refs (map escape->ref normals)) - (nrefs (map escape->ref natives))) - #`(make-gexp (list #,@refs) (list #,@nrefs) + (refs (map escape->ref escapes))) + #`(make-gexp (list #,@refs) (lambda #,formals #,sexp))))))) -- cgit v1.3 From 0bb9929eaa3f963ae75478e789723f9e8582116b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 3 Jul 2016 22:26:19 +0200 Subject: gexp: Add 'with-imported-modules' macro. * guix/gexp.scm ()[modules]: New field. (gexp-modules): New procedure. (gexp->derivation): Use it and append the result to %MODULES. Update docstring to mark #:modules as deprecated. (current-imported-modules, with-imported-modules): New macros. (gexp): Pass CURRENT-IMPORTED-MODULES as second argument to 'gexp'. (gexp->script): Use and honor 'gexp-modules'; define '%modules'. * tests/gexp.scm ("gexp->derivation & with-imported-modules") ("gexp->derivation & nested with-imported-modules") ("gexp-modules & ungexp", "gexp-modules & ungexp-splicing"): New tests. ("program-file"): Use 'with-imported-modules'. Remove #:modules argument to 'program-file'. * doc/guix.texi (G-Expressions): Document 'with-imported-modules'. Mark #:modules of 'gexp->derivation' as deprecated. * emacs/guix-devel.el: Add syntax for 'with-imported-modules'. (guix-devel-keywords): Add it. * .dir-locals.el: Likewise. --- .dir-locals.el | 1 + doc/guix.texi | 38 ++++++++++++++++++++++++++++++- emacs/guix-devel.el | 2 ++ guix/gexp.scm | 47 ++++++++++++++++++++++++++++++++++----- tests/gexp.scm | 64 +++++++++++++++++++++++++++++++++++++++++++++++++---- 5 files changed, 142 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/.dir-locals.el b/.dir-locals.el index 0873c1d74..c7ceb9e9f 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -59,6 +59,7 @@ (eval . (put 'run-with-store 'scheme-indent-function 1)) (eval . (put 'run-with-state 'scheme-indent-function 1)) (eval . (put 'wrap-program 'scheme-indent-function 1)) + (eval . (put 'with-imported-modules 'scheme-indent-function 1)) (eval . (put 'call-with-container 'scheme-indent-function 1)) (eval . (put 'container-excursion 'scheme-indent-function 1)) diff --git a/doc/guix.texi b/doc/guix.texi index c9d9bd897..b31532503 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3697,6 +3697,30 @@ In the example above, the native build of @var{coreutils} is used, so that @command{ln} can actually run on the host; but then the cross-compiled build of @var{emacs} is referenced. +@cindex imported modules, for gexps +@findex with-imported-modules +Another gexp feature is @dfn{imported modules}: sometimes you want to be +able to use certain Guile modules from the ``host environment'' in the +gexp, so those modules should be imported in the ``build environment''. +The @code{with-imported-modules} form allows you to express that: + +@example +(let ((build (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (mkdir-p (string-append #$output "/bin")))))) + (gexp->derivation "empty-dir" + #~(begin + #$build + (display "success!\n") + #t))) +@end example + +@noindent +In this example, the @code{(guix build utils)} module is automatically +pulled into the isolated build environment of our gexp, such that +@code{(use-modules (guix build utils))} works as expected. + The syntactic form to construct gexps is summarized below. @deffn {Scheme Syntax} #~@var{exp} @@ -3756,6 +3780,16 @@ G-expressions created by @code{gexp} or @code{#~} are run-time objects of the @code{gexp?} type (see below.) @end deffn +@deffn {Scheme Syntax} with-imported-modules @var{modules} @var{body}@dots{} +Mark the gexps defined in @var{body}@dots{} as requiring @var{modules} +in their execution environment. @var{modules} must be a list of Guile +module names, such as @code{'((guix build utils) (guix build gremlin))}. + +This form has @emph{lexical} scope: it has an effect on the gexps +directly defined in @var{body}@dots{}, but not on those defined, say, in +procedures called from @var{body}@dots{}. +@end deffn + @deffn {Scheme Procedure} gexp? @var{obj} Return @code{#t} if @var{obj} is a G-expression. @end deffn @@ -3781,7 +3815,9 @@ stored in a file called @var{script-name}. When @var{target} is true, it is used as the cross-compilation target triplet for packages referred to by @var{exp}. -Make @var{modules} available in the evaluation context of @var{exp}; +@var{modules} is deprecated in favor of @code{with-imported-modules}. +Its meaning is to +make @var{modules} available in the evaluation context of @var{exp}; @var{modules} is a list of names of Guile modules searched in @var{module-path} to be copied in the store, compiled, and made available in the load path during the execution of @var{exp}---e.g., @code{((guix diff --git a/emacs/guix-devel.el b/emacs/guix-devel.el index ee8371ce8..b71670cdf 100644 --- a/emacs/guix-devel.el +++ b/emacs/guix-devel.el @@ -216,6 +216,7 @@ to find 'modify-phases' keywords." "with-derivation-substitute" "with-directory-excursion" "with-error-handling" + "with-imported-modules" "with-monad" "with-mutex" "with-store")) @@ -306,6 +307,7 @@ Each rule should have a form (SYMBOL VALUE). See `put' for details." (with-derivation-substitute 2) (with-directory-excursion 1) (with-error-handling 0) + (with-imported-modules 1) (with-monad 1) (with-mutex 1) (with-store 1) diff --git a/guix/gexp.scm b/guix/gexp.scm index c86f4d0fd..e9274a05f 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -29,6 +29,7 @@ #:use-module (ice-9 match) #:export (gexp gexp? + with-imported-modules gexp-input gexp-input? @@ -98,9 +99,10 @@ ;; "G expressions". (define-record-type - (make-gexp references proc) + (make-gexp references modules proc) gexp? (references gexp-references) ;list of + (modules gexp-self-modules) ;list of module names (proc gexp-proc)) ;procedure (define (write-gexp gexp port) @@ -384,6 +386,23 @@ whether this should be considered a \"native\" input or not." (set-record-type-printer! write-gexp-output) +(define (gexp-modules gexp) + "Return the list of Guile module names GEXP relies on." + (delete-duplicates + (append (gexp-self-modules gexp) + (append-map (match-lambda + (($ (? gexp? exp)) + (gexp-modules exp)) + (($ (lst ...)) + (append-map (lambda (item) + (if (gexp? item) + (gexp-modules item) + '())) + lst)) + (_ + '())) + (gexp-references gexp))))) + (define raw-derivation (store-lift derivation)) @@ -465,7 +484,8 @@ derivation) on SYSTEM; EXP is stored in a file called SCRIPT-NAME. When TARGET is true, it is used as the cross-compilation target triplet for packages referred to by EXP. -Make MODULES available in the evaluation context of EXP; MODULES is a list of +MODULES is deprecated in favor of 'with-imported-modules'. Its meaning is to +make MODULES available in the evaluation context of EXP; MODULES is a list of names of Guile modules searched in MODULE-PATH to be copied in the store, compiled, and made available in the load path during the execution of EXP---e.g., '((guix build utils) (guix build gnu-build-system)). @@ -494,7 +514,9 @@ Similarly for DISALLOWED-REFERENCES, which can list items that must not be referenced by the outputs. The other arguments are as for 'derivation'." - (define %modules modules) + (define %modules + (delete-duplicates + (append modules (gexp-modules exp)))) (define outputs (gexp-outputs exp)) (define (graphs-file-names graphs) @@ -724,6 +746,17 @@ and in the current monad setting (system type, etc.)" (simple-format #f "~a:~a" line column))) ""))) +(define-syntax-parameter current-imported-modules + ;; Current list of imported modules. + (identifier-syntax '())) + +(define-syntax-rule (with-imported-modules modules body ...) + "Mark the gexps defined in BODY... as requiring MODULES in their execution +environment." + (syntax-parameterize ((current-imported-modules + (identifier-syntax modules))) + body ...)) + (define-syntax gexp (lambda (s) (define (collect-escapes exp) @@ -819,6 +852,7 @@ and in the current monad setting (system type, etc.)" (sexp (substitute-references #'exp (zip escapes formals))) (refs (map escape->ref escapes))) #`(make-gexp (list #,@refs) + current-imported-modules (lambda #,formals #,sexp))))))) @@ -960,8 +994,11 @@ they can refer to each other." #:key (modules '()) (guile (default-guile))) "Return an executable script NAME that runs EXP using GUILE with MODULES in its search path." - (mlet %store-monad ((modules (imported-modules modules)) - (compiled (compiled-modules modules))) + (define %modules + (append (gexp-modules exp) modules)) + + (mlet %store-monad ((modules (imported-modules %modules)) + (compiled (compiled-modules %modules))) (gexp->derivation name (gexp (call-with-output-file (ungexp output) diff --git a/tests/gexp.scm b/tests/gexp.scm index f44f0eaf9..36ce66f7c 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -526,6 +526,18 @@ get-bytevector-all)))) files)))))) +(test-equal "gexp-modules & ungexp" + '((bar) (foo)) + ((@@ (guix gexp) gexp-modules) + #~(foo #$(with-imported-modules '((foo)) #~+) + #+(with-imported-modules '((bar)) #~-)))) + +(test-equal "gexp-modules & ungexp-splicing" + '((foo) (bar)) + ((@@ (guix gexp) gexp-modules) + #~(foo #$@(list (with-imported-modules '((foo)) #~+) + (with-imported-modules '((bar)) #~-))))) + (test-assertm "gexp->derivation #:modules" (mlet* %store-monad ((build -> #~(begin @@ -540,6 +552,50 @@ (s (stat (string-append p "/guile/guix/nix")))) (return (eq? (stat:type s) 'directory)))))) +(test-assertm "gexp->derivation & with-imported-modules" + ;; Same test as above, but using 'with-imported-modules'. + (mlet* %store-monad + ((build -> (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (mkdir-p (string-append #$output "/guile/guix/nix")) + #t))) + (drv (gexp->derivation "test-with-modules" build))) + (mbegin %store-monad + (built-derivations (list drv)) + (let* ((p (derivation->output-path drv)) + (s (stat (string-append p "/guile/guix/nix")))) + (return (eq? (stat:type s) 'directory)))))) + +(test-assertm "gexp->derivation & nested with-imported-modules" + (mlet* %store-monad + ((build1 -> (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (mkdir-p (string-append #$output "/guile/guix/nix")) + #t))) + (build2 -> (with-imported-modules '((guix build bournish)) + #~(begin + (use-modules (guix build bournish) + (system base compile)) + #+build1 + (call-with-output-file (string-append #$output "/b") + (lambda (port) + (write + (read-and-compile (open-input-string "cd /foo") + #:from %bournish-language + #:to 'scheme) + port)))))) + (drv (gexp->derivation "test-with-modules" build2))) + (mbegin %store-monad + (built-derivations (list drv)) + (let* ((p (derivation->output-path drv)) + (s (stat (string-append p "/guile/guix/nix"))) + (b (string-append p "/b"))) + (return (and (eq? (stat:type s) 'directory) + (equal? '(chdir "/foo") + (call-with-input-file b read)))))))) + (test-assertm "gexp->derivation #:references-graphs" (mlet* %store-monad ((one (text-file "one" (random-text))) @@ -676,11 +732,11 @@ (test-assertm "program-file" (let* ((n (random (expt 2 50))) - (exp (gexp (begin - (use-modules (guix build utils)) - (display (ungexp n))))) + (exp (with-imported-modules '((guix build utils)) + (gexp (begin + (use-modules (guix build utils)) + (display (ungexp n)))))) (file (program-file "program" exp - #:modules '((guix build utils)) #:guile %bootstrap-guile))) (mlet* %store-monad ((drv (lower-object file)) (out -> (derivation->output-path drv))) -- cgit v1.3 From dd8d1a30468dae1412762e54801592f6b475f88e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 Jul 2016 22:19:23 +0200 Subject: gexp: Factorize load-path-setting expression. * guix/gexp.scm (load-path-expression): New procedure. (gexp->script): Use it. --- guix/gexp.scm | 26 ++++++++++++++------------ 1 file changed, 14 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index e9274a05f..e76a281bb 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -990,6 +990,18 @@ they can refer to each other." (module-ref (resolve-interface '(gnu packages commencement)) 'guile-final)) +(define (load-path-expression modules) + "Return as a monadic value a gexp that sets '%load-path' and +'%load-compiled-path' to point to MODULES, a list of module names." + (mlet %store-monad ((modules (imported-modules modules)) + (compiled (compiled-modules modules))) + (return (gexp (eval-when (expand load eval) + (set! %load-path + (cons (ungexp modules) %load-path)) + (set! %load-compiled-path + (cons (ungexp compiled) + %load-compiled-path))))))) + (define* (gexp->script name exp #:key (modules '()) (guile (default-guile))) "Return an executable script NAME that runs EXP using GUILE with MODULES in @@ -997,8 +1009,7 @@ its search path." (define %modules (append (gexp-modules exp) modules)) - (mlet %store-monad ((modules (imported-modules %modules)) - (compiled (compiled-modules %modules))) + (mlet %store-monad ((set-load-path (load-path-expression %modules))) (gexp->derivation name (gexp (call-with-output-file (ungexp output) @@ -1011,16 +1022,7 @@ its search path." "#!~a/bin/guile --no-auto-compile~%!#~%" (ungexp guile)) - ;; Write the 'eval-when' form so that it can be - ;; compiled. - (write - '(eval-when (expand load eval) - (set! %load-path - (cons (ungexp modules) %load-path)) - (set! %load-compiled-path - (cons (ungexp compiled) - %load-compiled-path))) - port) + (write '(ungexp set-load-path) port) (write '(ungexp exp) port) (chmod port #o555))))))) -- cgit v1.3 From 2b4185792d3ec9b43a5c1bb204b6846e5ac0f14a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 Jul 2016 23:54:18 +0200 Subject: gexp: 'gexp->file' emits code to set '%load-path'. * guix/gexp.scm (gexp->file): Add #:set-load-path? parameter and honor it. * gnu/system.scm (operating-system-parameters-file): Pass #:set-load-path? #f. * doc/guix.texi (G-Expressions): Adjust accordingly. --- doc/guix.texi | 6 +++++- gnu/system.scm | 3 ++- guix/gexp.scm | 32 +++++++++++++++++++++++--------- 3 files changed, 30 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index a0014e711..abd294e88 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3943,8 +3943,12 @@ script, and @var{modules} is the list of modules visible to that script. This is the declarative counterpart of @code{gexp->script}. @end deffn -@deffn {Monadic Procedure} gexp->file @var{name} @var{exp} +@deffn {Monadic Procedure} gexp->file @var{name} @var{exp} @ + [#:set-load-path? #t] Return a derivation that builds a file @var{name} containing @var{exp}. +When @var{set-load-path?} is true, emit code in the resulting file to +set @code{%load-path} and @code{%load-compiled-path} to honor +@var{exp}'s imported modules. The resulting file holds references to all the dependencies of @var{exp} or a subset thereof. diff --git a/gnu/system.scm b/gnu/system.scm index 96ea153cd..a49b3f29b 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -731,7 +731,8 @@ this file is the reconstruction of GRUB menu entries for old configurations." (kernel #$(operating-system-kernel os)) (kernel-arguments #$(operating-system-kernel-arguments os)) - (initrd #$initrd))))) + (initrd #$initrd)) + #:set-load-path? #f))) ;;; diff --git a/guix/gexp.scm b/guix/gexp.scm index e76a281bb..60f8905ea 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1026,15 +1026,29 @@ its search path." (write '(ungexp exp) port) (chmod port #o555))))))) -(define (gexp->file name exp) - "Return a derivation that builds a file NAME containing EXP." - (gexp->derivation name - (gexp - (call-with-output-file (ungexp output) - (lambda (port) - (write '(ungexp exp) port)))) - #:local-build? #t - #:substitutable? #f)) +(define* (gexp->file name exp #:key (set-load-path? #t)) + "Return a derivation that builds a file NAME containing EXP. When +SET-LOAD-PATH? is true, emit code in the resulting file to set '%load-path' +and '%load-compiled-path' to honor EXP's imported modules." + (match (if set-load-path? (gexp-modules exp) '()) + (() ;zero modules + (gexp->derivation name + (gexp + (call-with-output-file (ungexp output) + (lambda (port) + (write '(ungexp exp) port)))) + #:local-build? #t + #:substitutable? #f)) + ((modules ...) + (mlet %store-monad ((set-load-path (load-path-expression modules))) + (gexp->derivation name + (gexp + (call-with-output-file (ungexp output) + (lambda (port) + (write '(ungexp set-load-path) port) + (write '(ungexp exp) port)))) + #:local-build? #t + #:substitutable? #f))))) (define* (text-file* name #:rest text) "Return as a monadic value a derivation that builds a text file containing -- cgit v1.3 From 99b231dee663ce097e56108daacf24310f6c1078 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Jul 2016 00:54:22 +0200 Subject: profiles: Use 'with-imported-modules'. * guix/profiles.scm (info-dir-file): Use 'with-imported-modules' instead of the #:module argument to 'gexp->derivation'. (ghc-package-cache-file): Likewise. (ca-certificate-bundle): Likewise. (gtk-icon-themes): Likewise. (xdg-desktop-database): Likewise. (xdg-mime-database): Likewise. (profile-derivation): Likewise. --- guix/profiles.scm | 422 +++++++++++++++++++++++++++--------------------------- 1 file changed, 211 insertions(+), 211 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 90c43325a..77df6ad18 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -489,87 +489,87 @@ MANIFEST." (module-ref (resolve-interface '(gnu packages compression)) 'gzip)) (define build - #~(begin - (use-modules (guix build utils) - (srfi srfi-1) (srfi srfi-26) - (ice-9 ftw)) - - (define (info-file? file) - (or (string-suffix? ".info" file) - (string-suffix? ".info.gz" file))) - - (define (info-files top) - (let ((infodir (string-append top "/share/info"))) - (map (cut string-append infodir "/" <>) - (or (scandir infodir info-file?) '())))) - - (define (install-info info) - (setenv "PATH" (string-append #+gzip "/bin")) ;for info.gz files - (zero? - (system* (string-append #+texinfo "/bin/install-info") "--silent" - info (string-append #$output "/share/info/dir")))) - - (mkdir-p (string-append #$output "/share/info")) - (exit (every install-info - (append-map info-files - '#$(manifest-inputs manifest)))))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (srfi srfi-1) (srfi srfi-26) + (ice-9 ftw)) + + (define (info-file? file) + (or (string-suffix? ".info" file) + (string-suffix? ".info.gz" file))) + + (define (info-files top) + (let ((infodir (string-append top "/share/info"))) + (map (cut string-append infodir "/" <>) + (or (scandir infodir info-file?) '())))) + + (define (install-info info) + (setenv "PATH" (string-append #+gzip "/bin")) ;for info.gz files + (zero? + (system* (string-append #+texinfo "/bin/install-info") "--silent" + info (string-append #$output "/share/info/dir")))) + + (mkdir-p (string-append #$output "/share/info")) + (exit (every install-info + (append-map info-files + '#$(manifest-inputs manifest))))))) (gexp->derivation "info-dir" build - #:modules '((guix build utils)) #:local-build? #t #:substitutable? #f)) (define (ghc-package-cache-file manifest) "Return a derivation that builds the GHC 'package.cache' file for all the entries of MANIFEST, or #f if MANIFEST does not have any GHC packages." - (define ghc ;lazy reference + (define ghc ;lazy reference (module-ref (resolve-interface '(gnu packages haskell)) 'ghc)) (define build - #~(begin - (use-modules (guix build utils) - (srfi srfi-1) (srfi srfi-26) - (ice-9 ftw)) - - (define ghc-name-version - (let* ((base (basename #+ghc))) - (string-drop base - (+ 1 (string-index base #\-))))) - - (define db-subdir - (string-append "lib/" ghc-name-version "/package.conf.d")) - - (define db-dir - (string-append #$output "/" db-subdir)) - - (define (conf-files top) - (let ((db (string-append top "/" db-subdir))) - (if (file-exists? db) - (find-files db "\\.conf$") - '()))) - - (define (copy-conf-file conf) - (let ((base (basename conf))) - (copy-file conf (string-append db-dir "/" base)))) - - (system* (string-append #+ghc "/bin/ghc-pkg") "init" db-dir) - (for-each copy-conf-file - (append-map conf-files - (delete-duplicates - '#$(manifest-inputs manifest)))) - (let ((success - (zero? - (system* (string-append #+ghc "/bin/ghc-pkg") "recache" - (string-append "--package-db=" db-dir))))) - (for-each delete-file (find-files db-dir "\\.conf$")) - (exit success)))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (srfi srfi-1) (srfi srfi-26) + (ice-9 ftw)) + + (define ghc-name-version + (let* ((base (basename #+ghc))) + (string-drop base + (+ 1 (string-index base #\-))))) + + (define db-subdir + (string-append "lib/" ghc-name-version "/package.conf.d")) + + (define db-dir + (string-append #$output "/" db-subdir)) + + (define (conf-files top) + (let ((db (string-append top "/" db-subdir))) + (if (file-exists? db) + (find-files db "\\.conf$") + '()))) + + (define (copy-conf-file conf) + (let ((base (basename conf))) + (copy-file conf (string-append db-dir "/" base)))) + + (system* (string-append #+ghc "/bin/ghc-pkg") "init" db-dir) + (for-each copy-conf-file + (append-map conf-files + (delete-duplicates + '#$(manifest-inputs manifest)))) + (let ((success + (zero? + (system* (string-append #+ghc "/bin/ghc-pkg") "recache" + (string-append "--package-db=" db-dir))))) + (for-each delete-file (find-files db-dir "\\.conf$")) + (exit success))))) (with-monad %store-monad ;; Don't depend on GHC when there's nothing to do. (if (any (cut string-prefix? "ghc" <>) (map manifest-entry-name (manifest-entries manifest))) (gexp->derivation "ghc-package-cache" build - #:modules '((guix build utils)) #:local-build? #t #:substitutable? #f) (return #f)))) @@ -585,58 +585,58 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx." (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales)) (define build - #~(begin - (use-modules (guix build utils) - (rnrs io ports) - (srfi srfi-1) - (srfi srfi-26) - (ice-9 ftw) - (ice-9 match)) - - (define (pem-file? file) - (string-suffix? ".pem" file)) - - (define (ca-files top) - (let ((cert-dir (string-append top "/etc/ssl/certs"))) - (map (cut string-append cert-dir "/" <>) - (or (scandir cert-dir pem-file?) '())))) - - (define (concatenate-files files result) - "Make RESULT the concatenation of all of FILES." - (define (dump file port) - (display (call-with-input-file file get-string-all) - port) - (newline port)) ;required, see - - (call-with-output-file result - (lambda (port) - (for-each (cut dump <> port) files)))) - - ;; Some file names in the NSS certificates are UTF-8 encoded so - ;; install a UTF-8 locale. - (setenv "LOCPATH" - (string-append #+glibc-utf8-locales "/lib/locale/" - #+(package-version glibc-utf8-locales))) - (setlocale LC_ALL "en_US.utf8") - - (match (append-map ca-files '#$(manifest-inputs manifest)) - (() - ;; Since there are no CA files, just create an empty directory. Do - ;; not create the etc/ssl/certs sub-directory, since that would - ;; wrongfully lead to a message about 'SSL_CERT_DIR' needing to be - ;; defined. - (mkdir #$output) - #t) - ((ca-files ...) - (let ((result (string-append #$output "/etc/ssl/certs"))) - (mkdir-p result) - (concatenate-files ca-files - (string-append result - "/ca-certificates.crt")) - #t))))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (rnrs io ports) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 ftw) + (ice-9 match)) + + (define (pem-file? file) + (string-suffix? ".pem" file)) + + (define (ca-files top) + (let ((cert-dir (string-append top "/etc/ssl/certs"))) + (map (cut string-append cert-dir "/" <>) + (or (scandir cert-dir pem-file?) '())))) + + (define (concatenate-files files result) + "Make RESULT the concatenation of all of FILES." + (define (dump file port) + (display (call-with-input-file file get-string-all) + port) + (newline port)) ;required, see + + (call-with-output-file result + (lambda (port) + (for-each (cut dump <> port) files)))) + + ;; Some file names in the NSS certificates are UTF-8 encoded so + ;; install a UTF-8 locale. + (setenv "LOCPATH" + (string-append #+glibc-utf8-locales "/lib/locale/" + #+(package-version glibc-utf8-locales))) + (setlocale LC_ALL "en_US.utf8") + + (match (append-map ca-files '#$(manifest-inputs manifest)) + (() + ;; Since there are no CA files, just create an empty directory. Do + ;; not create the etc/ssl/certs sub-directory, since that would + ;; wrongfully lead to a message about 'SSL_CERT_DIR' needing to be + ;; defined. + (mkdir #$output) + #t) + ((ca-files ...) + (let ((result (string-append #$output "/etc/ssl/certs"))) + (mkdir-p result) + (concatenate-files ca-files + (string-append result + "/ca-certificates.crt")) + #t)))))) (gexp->derivation "ca-certificate-bundle" build - #:modules '((guix build utils)) #:local-build? #t #:substitutable? #f)) @@ -645,44 +645,44 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx." creates the GTK+ 'icon-theme.cache' file for each theme." (mlet %store-monad ((gtk+ (manifest-lookup-package manifest "gtk+"))) (define build - #~(begin - (use-modules (guix build utils) - (guix build union) - (guix build profiles) - (srfi srfi-26) - (ice-9 ftw)) - - (let* ((destdir (string-append #$output "/share/icons")) - (icondirs (filter file-exists? - (map (cut string-append <> "/share/icons") - '#$(manifest-inputs manifest)))) - (update-icon-cache (string-append - #+gtk+ "/bin/gtk-update-icon-cache"))) - - ;; Union all the icons. - (mkdir-p (string-append #$output "/share")) - (union-build destdir icondirs - #:log-port (%make-void-port "w")) - - ;; Update the 'icon-theme.cache' file for each icon theme. - (for-each - (lambda (theme) - (let ((dir (string-append destdir "/" theme))) - ;; Occasionally DESTDIR contains plain files, such as - ;; "abiword_48.png". Ignore these. - (when (file-is-directory? dir) - (ensure-writable-directory dir) - (system* update-icon-cache "-t" dir "--quiet")))) - (scandir destdir (negate (cut member <> '("." "..")))))))) + (with-imported-modules '((guix build utils) + (guix build union) + (guix build profiles) + (guix search-paths) + (guix records)) + #~(begin + (use-modules (guix build utils) + (guix build union) + (guix build profiles) + (srfi srfi-26) + (ice-9 ftw)) + + (let* ((destdir (string-append #$output "/share/icons")) + (icondirs (filter file-exists? + (map (cut string-append <> "/share/icons") + '#$(manifest-inputs manifest)))) + (update-icon-cache (string-append + #+gtk+ "/bin/gtk-update-icon-cache"))) + + ;; Union all the icons. + (mkdir-p (string-append #$output "/share")) + (union-build destdir icondirs + #:log-port (%make-void-port "w")) + + ;; Update the 'icon-theme.cache' file for each icon theme. + (for-each + (lambda (theme) + (let ((dir (string-append destdir "/" theme))) + ;; Occasionally DESTDIR contains plain files, such as + ;; "abiword_48.png". Ignore these. + (when (file-is-directory? dir) + (ensure-writable-directory dir) + (system* update-icon-cache "-t" dir "--quiet")))) + (scandir destdir (negate (cut member <> '("." ".."))))))))) ;; Don't run the hook when there's nothing to do. (if gtk+ (gexp->derivation "gtk-icon-themes" build - #:modules '((guix build utils) - (guix build union) - (guix build profiles) - (guix search-paths) - (guix records)) #:local-build? #t #:substitutable? #f) (return #f)))) @@ -695,28 +695,28 @@ MIME type." (manifest-lookup-package manifest "desktop-file-utils"))) (define build - #~(begin - (use-modules (srfi srfi-26) - (guix build utils) - (guix build union)) - (let* ((destdir (string-append #$output "/share/applications")) - (appdirs (filter file-exists? - (map (cut string-append <> - "/share/applications") - '#$(manifest-inputs manifest)))) - (update-desktop-database (string-append - #+desktop-file-utils - "/bin/update-desktop-database"))) - (mkdir-p (string-append #$output "/share")) - (union-build destdir appdirs - #:log-port (%make-void-port "w")) - (exit (zero? (system* update-desktop-database destdir)))))) + (with-imported-modules '((guix build utils) + (guix build union)) + #~(begin + (use-modules (srfi srfi-26) + (guix build utils) + (guix build union)) + (let* ((destdir (string-append #$output "/share/applications")) + (appdirs (filter file-exists? + (map (cut string-append <> + "/share/applications") + '#$(manifest-inputs manifest)))) + (update-desktop-database (string-append + #+desktop-file-utils + "/bin/update-desktop-database"))) + (mkdir-p (string-append #$output "/share")) + (union-build destdir appdirs + #:log-port (%make-void-port "w")) + (exit (zero? (system* update-desktop-database destdir))))))) ;; Don't run the hook when 'desktop-file-utils' is not referenced. (if desktop-file-utils (gexp->derivation "xdg-desktop-database" build - #:modules '((guix build utils) - (guix build union)) #:local-build? #t #:substitutable? #f) (return #f)))) @@ -728,30 +728,30 @@ entries. It's used to query the MIME type of a given file." (manifest-lookup-package manifest "shared-mime-info"))) (define build - #~(begin - (use-modules (srfi srfi-26) - (guix build utils) - (guix build union)) - (let* ((datadir (string-append #$output "/share")) - (destdir (string-append datadir "/mime")) - (pkgdirs (filter file-exists? - (map (cut string-append <> - "/share/mime/packages") - '#$(manifest-inputs manifest)))) - (update-mime-database (string-append - #+shared-mime-info - "/bin/update-mime-database"))) - (mkdir-p destdir) - (union-build (string-append destdir "/packages") pkgdirs - #:log-port (%make-void-port "w")) - (setenv "XDG_DATA_HOME" datadir) - (exit (zero? (system* update-mime-database destdir)))))) + (with-imported-modules '((guix build utils) + (guix build union)) + #~(begin + (use-modules (srfi srfi-26) + (guix build utils) + (guix build union)) + (let* ((datadir (string-append #$output "/share")) + (destdir (string-append datadir "/mime")) + (pkgdirs (filter file-exists? + (map (cut string-append <> + "/share/mime/packages") + '#$(manifest-inputs manifest)))) + (update-mime-database (string-append + #+shared-mime-info + "/bin/update-mime-database"))) + (mkdir-p destdir) + (union-build (string-append destdir "/packages") pkgdirs + #:log-port (%make-void-port "w")) + (setenv "XDG_DATA_HOME" datadir) + (exit (zero? (system* update-mime-database destdir))))))) ;; Don't run the hook when 'shared-mime-info' is referenced. (if shared-mime-info (gexp->derivation "xdg-mime-database" build - #:modules '((guix build utils) - (guix build union)) #:local-build? #t #:substitutable? #f) (return #f)))) @@ -790,34 +790,34 @@ the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc." (manifest-inputs manifest))) (define builder - #~(begin - (use-modules (guix build profiles) - (guix search-paths) - (srfi srfi-1)) - - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - - (define search-paths - ;; Search paths of MANIFEST's packages, converted back to their - ;; record form. - (map sexp->search-path-specification - (delete-duplicates - '#$(map search-path-specification->sexp - (append-map manifest-entry-search-paths - (manifest-entries manifest)))))) - - (build-profile #$output '#$inputs - #:manifest '#$(manifest->gexp manifest) - #:search-paths search-paths))) + (with-imported-modules '((guix build profiles) + (guix build union) + (guix build utils) + (guix search-paths) + (guix records)) + #~(begin + (use-modules (guix build profiles) + (guix search-paths) + (srfi srfi-1)) + + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) + + (define search-paths + ;; Search paths of MANIFEST's packages, converted back to their + ;; record form. + (map sexp->search-path-specification + (delete-duplicates + '#$(map search-path-specification->sexp + (append-map manifest-entry-search-paths + (manifest-entries manifest)))))) + + (build-profile #$output '#$inputs + #:manifest '#$(manifest->gexp manifest) + #:search-paths search-paths)))) (gexp->derivation "profile" builder #:system system - #:modules '((guix build profiles) - (guix build union) - (guix build utils) - (guix search-paths) - (guix records)) ;; Not worth offloading. #:local-build? #t -- cgit v1.3 From e9b046fddaefbb98c931260821399090c221173d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Jul 2016 00:56:37 +0200 Subject: download: Use 'with-imported-modules'. * guix/cvs-download.scm (cvs-fetch): Use 'with-imported-modules' instead of the #:modules argument of 'gexp->derivation'. * guix/download.scm (url-fetch): Likewise. * guix/git-download.scm (git-fetch): Likewise. * guix/hg-download.scm (hg-fetch): Likewise. * guix/svn-download.scm (svn-fetch): Likewise. --- guix/cvs-download.scm | 20 +++++++++--------- guix/download.scm | 57 ++++++++++++++++++++++++++------------------------- guix/git-download.scm | 36 ++++++++++++++++---------------- guix/hg-download.scm | 22 ++++++++++---------- guix/svn-download.scm | 22 ++++++++++---------- 5 files changed, 79 insertions(+), 78 deletions(-) (limited to 'guix') diff --git a/guix/cvs-download.scm b/guix/cvs-download.scm index 72478dd2c..85744c5b5 100644 --- a/guix/cvs-download.scm +++ b/guix/cvs-download.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 ;;; Copyright © 2014 Sree Harsha Totakura ;;; Copyright © 2015 Mark H Weaver ;;; @@ -60,13 +60,15 @@ object. The output is expected to have recursive hash HASH of type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (define build - #~(begin - (use-modules (guix build cvs)) - (cvs-fetch '#$(cvs-reference-root-directory ref) - '#$(cvs-reference-module ref) - '#$(cvs-reference-revision ref) - #$output - #:cvs-command (string-append #+cvs "/bin/cvs")))) + (with-imported-modules '((guix build cvs) + (guix build utils)) + #~(begin + (use-modules (guix build cvs)) + (cvs-fetch '#$(cvs-reference-root-directory ref) + '#$(cvs-reference-module ref) + '#$(cvs-reference-revision ref) + #$output + #:cvs-command (string-append #+cvs "/bin/cvs"))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "cvs-checkout") build @@ -74,8 +76,6 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." #:hash-algo hash-algo #:hash hash #:recursive? #t - #:modules '((guix build cvs) - (guix build utils)) #:guile-for-build guile #:local-build? #t))) diff --git a/guix/download.scm b/guix/download.scm index c75a65592..336bc541e 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -286,33 +286,39 @@ in the store." (any https? url))))) (define builder - #~(begin - #+(if need-gnutls? + (with-imported-modules '((guix build download) + (guix build utils) + (guix ftp-client) + (guix base32) + (guix base64)) + #~(begin + #+(if need-gnutls? - ;; Add GnuTLS to the inputs and to the load path. - #~(eval-when (load expand eval) - (set! %load-path - (cons (string-append #+(gnutls-package) - "/share/guile/site/" - (effective-version)) - %load-path))) - #~#t) + ;; Add GnuTLS to the inputs and to the load path. + #~(eval-when (load expand eval) + (set! %load-path + (cons (string-append #+(gnutls-package) + "/share/guile/site/" + (effective-version)) + %load-path))) + #~#t) - (use-modules (guix build download) - (guix base32)) + (use-modules (guix build download) + (guix base32)) - (let ((value-from-environment (lambda (variable) - (call-with-input-string - (getenv variable) - read)))) - (url-fetch (value-from-environment "guix download url") - #$output - #:mirrors (call-with-input-file #$%mirror-file read) + (let ((value-from-environment (lambda (variable) + (call-with-input-string + (getenv variable) + read)))) + (url-fetch (value-from-environment "guix download url") + #$output + #:mirrors (call-with-input-file #$%mirror-file read) - ;; Content-addressed mirrors. - #:hashes (value-from-environment "guix download hashes") - #:content-addressed-mirrors - (primitive-load #$%content-addressed-mirror-file))))) + ;; Content-addressed mirrors. + #:hashes + (value-from-environment "guix download hashes") + #:content-addressed-mirrors + (primitive-load #$%content-addressed-mirror-file)))))) (let ((uri (and (string? url) (string->uri url)))) (if (or (and (string? url) (not uri)) @@ -325,11 +331,6 @@ in the store." #:system system #:hash-algo hash-algo #:hash hash - #:modules '((guix build download) - (guix build utils) - (guix ftp-client) - (guix base32) - (guix base64)) ;; Use environment variables and a fixed script ;; name so there's only one script in store for diff --git a/guix/git-download.scm b/guix/git-download.scm index 1e5c845e3..9cc6dd3d9 100644 --- a/guix/git-download.scm +++ b/guix/git-download.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. ;;; @@ -68,23 +68,25 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." '())) (define build - #~(begin - (use-modules (guix build git) - (guix build utils) - (ice-9 match)) + (with-imported-modules '((guix build git) + (guix build utils)) + #~(begin + (use-modules (guix build git) + (guix build utils) + (ice-9 match)) - ;; The 'git submodule' commands expects Coreutils, sed, - ;; grep, etc. to be in $PATH. - (set-path-environment-variable "PATH" '("bin") - (match '#+inputs - (((names dirs) ...) - dirs))) + ;; The 'git submodule' commands expects Coreutils, sed, + ;; grep, etc. to be in $PATH. + (set-path-environment-variable "PATH" '("bin") + (match '#+inputs + (((names dirs) ...) + dirs))) - (git-fetch '#$(git-reference-url ref) - '#$(git-reference-commit ref) - #$output - #:recursive? '#$(git-reference-recursive? ref) - #:git-command (string-append #+git "/bin/git")))) + (git-fetch '#$(git-reference-url ref) + '#$(git-reference-commit ref) + #$output + #:recursive? '#$(git-reference-recursive? ref) + #:git-command (string-append #+git "/bin/git"))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "git-checkout") build @@ -93,8 +95,6 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." #:hash-algo hash-algo #:hash hash #:recursive? #t - #:modules '((guix build git) - (guix build utils)) #:guile-for-build guile #:local-build? #t))) diff --git a/guix/hg-download.scm b/guix/hg-download.scm index f3e1d2906..842098090 100644 --- a/guix/hg-download.scm +++ b/guix/hg-download.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 ;;; Copyright © 2016 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. @@ -60,15 +60,17 @@ object. The output is expected to have recursive hash HASH of type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (define build - #~(begin - (use-modules (guix build hg) - (guix build utils) - (ice-9 match)) + (with-imported-modules '((guix build hg) + (guix build utils)) + #~(begin + (use-modules (guix build hg) + (guix build utils) + (ice-9 match)) - (hg-fetch '#$(hg-reference-url ref) - '#$(hg-reference-changeset ref) - #$output - #:hg-command (string-append #+hg "/bin/hg")))) + (hg-fetch '#$(hg-reference-url ref) + '#$(hg-reference-changeset ref) + #$output + #:hg-command (string-append #+hg "/bin/hg"))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "hg-checkout") build @@ -77,8 +79,6 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." #:hash-algo hash-algo #:hash hash #:recursive? #t - #:modules '((guix build hg) - (guix build utils)) #:guile-for-build guile))) ;;; hg-download.scm ends here diff --git a/guix/svn-download.scm b/guix/svn-download.scm index dddf6485c..c1200fa0c 100644 --- a/guix/svn-download.scm +++ b/guix/svn-download.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 ;;; Copyright © 2014 Sree Harsha Totakura ;;; ;;; This file is part of GNU Guix. @@ -59,14 +59,16 @@ object. The output is expected to have recursive hash HASH of type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (define build - #~(begin - (use-modules (guix build svn)) - (svn-fetch '#$(svn-reference-url ref) - '#$(svn-reference-revision ref) - #$output - #:svn-command (string-append #+svn "/bin/svn") - #:user-name #$(svn-reference-user-name ref) - #:password #$(svn-reference-password ref)))) + (with-imported-modules '((guix build svn) + (guix build utils)) + #~(begin + (use-modules (guix build svn)) + (svn-fetch '#$(svn-reference-url ref) + '#$(svn-reference-revision ref) + #$output + #:svn-command (string-append #+svn "/bin/svn") + #:user-name #$(svn-reference-user-name ref) + #:password #$(svn-reference-password ref))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "svn-checkout") build @@ -74,8 +76,6 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." #:hash-algo hash-algo #:hash hash #:recursive? #t - #:modules '((guix build svn) - (guix build utils)) #:guile-for-build guile #:local-build? #t))) -- cgit v1.3 From a769bffb65d6ddfc108a4904641b310029f4924f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Jul 2016 17:43:19 +0200 Subject: gexp: 'computed-file' no longer has a #:modules parameter. * guix/gexp.scm ()[modules]: Remove. (computed-file): Remove #:modules. (computed-file-compiler): Likewise. * doc/guix.texi (G-Expressions): Adjust accordingly. --- doc/guix.texi | 5 ++--- guix/gexp.scm | 15 ++++++--------- 2 files changed, 8 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 37e854dc5..1a14ff9f0 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3898,10 +3898,9 @@ This is the declarative counterpart of @code{text-file}. @end deffn @deffn {Scheme Procedure} computed-file @var{name} @var{gexp} @ - [#:modules '()] [#:options '(#:local-build? #t)] + [#:options '(#:local-build? #t)] Return an object representing the store item @var{name}, a file or -directory computed by @var{gexp}. @var{modules} specifies the set of -modules visible in the execution context of @var{gexp}. @var{options} +directory computed by @var{gexp}. @var{options} is a list of additional arguments to pass to @code{gexp->derivation}. This is the declarative counterpart of @code{gexp->derivation}. diff --git a/guix/gexp.scm b/guix/gexp.scm index 60f8905ea..ec4fe0896 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -50,7 +50,6 @@ computed-file? computed-file-name computed-file-gexp - computed-file-modules computed-file-options program-file @@ -273,30 +272,28 @@ This is the declarative counterpart of 'text-file'." (text-file name content references)))) (define-record-type - (%computed-file name gexp modules options) + (%computed-file name gexp options) computed-file? (name computed-file-name) ;string (gexp computed-file-gexp) ;gexp - (modules computed-file-modules) ;list of module names (options computed-file-options)) ;list of arguments (define* (computed-file name gexp - #:key (modules '()) (options '(#:local-build? #t))) + #:key (options '(#:local-build? #t))) "Return an object representing the store item NAME, a file or directory -computed by GEXP. MODULES specifies the set of modules visible in the -execution context of GEXP. OPTIONS is a list of additional arguments to pass +computed by GEXP. OPTIONS is a list of additional arguments to pass to 'gexp->derivation'. This is the declarative counterpart of 'gexp->derivation'." - (%computed-file name gexp modules options)) + (%computed-file name gexp options)) (define-gexp-compiler (computed-file-compiler (file computed-file?) system target) ;; Compile FILE by returning a derivation whose build expression is its ;; gexp. (match file - (($ name gexp modules options) - (apply gexp->derivation name gexp #:modules modules options)))) + (($ name gexp options) + (apply gexp->derivation name gexp options)))) (define-record-type (%program-file name gexp modules guile) -- cgit v1.3 From 9c14a487bb3813ec5a555536b6bd1c4160ebb042 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Jul 2016 17:57:28 +0200 Subject: gexp: 'program-file' and 'gexp->script' no longer have #:modules. * guix/gexp.scm ()[modules]: Remove. (program-file): Remove #:modules and adjust accordingly. (program-file-compiler): Likewise. (gexp->script): Likewise. --- doc/guix.texi | 6 +++--- guix/gexp.scm | 27 ++++++++++----------------- 2 files changed, 13 insertions(+), 20 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 1a14ff9f0..6d424b23e 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3908,7 +3908,7 @@ This is the declarative counterpart of @code{gexp->derivation}. @deffn {Monadic Procedure} gexp->script @var{name} @var{exp} Return an executable script @var{name} that runs @var{exp} using -@var{guile} with @var{modules} in its search path. +@var{guile}, with @var{exp}'s imported modules in its search path. The example below builds a script that simply invokes the @command{ls} command: @@ -3934,10 +3934,10 @@ executable file @file{/gnu/store/@dots{}-list-files} along these lines: @end deffn @deffn {Scheme Procedure} program-file @var{name} @var{exp} @ - [#:modules '()] [#:guile #f] + [#:guile #f] Return an object representing the executable store item @var{name} that runs @var{gexp}. @var{guile} is the Guile package used to execute that -script, and @var{modules} is the list of modules visible to that script. +script. This is the declarative counterpart of @code{gexp->script}. @end deffn diff --git a/guix/gexp.scm b/guix/gexp.scm index ec4fe0896..302879fb4 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -56,7 +56,6 @@ program-file? program-file-name program-file-gexp - program-file-modules program-file-guile scheme-file @@ -296,29 +295,25 @@ This is the declarative counterpart of 'gexp->derivation'." (apply gexp->derivation name gexp options)))) (define-record-type - (%program-file name gexp modules guile) + (%program-file name gexp guile) program-file? (name program-file-name) ;string (gexp program-file-gexp) ;gexp - (modules program-file-modules) ;list of module names (guile program-file-guile)) ;package -(define* (program-file name gexp - #:key (modules '()) (guile #f)) +(define* (program-file name gexp #:key (guile #f)) "Return an object representing the executable store item NAME that runs -GEXP. GUILE is the Guile package used to execute that script, and MODULES is -the list of modules visible to that script. +GEXP. GUILE is the Guile package used to execute that script. This is the declarative counterpart of 'gexp->script'." - (%program-file name gexp modules guile)) + (%program-file name gexp guile)) (define-gexp-compiler (program-file-compiler (file program-file?) system target) ;; Compile FILE by returning a derivation that builds the script. (match file - (($ name gexp modules guile) + (($ name gexp guile) (gexp->script name gexp - #:modules modules #:guile (or guile (default-guile)))))) (define-record-type @@ -1000,13 +995,11 @@ they can refer to each other." %load-compiled-path))))))) (define* (gexp->script name exp - #:key (modules '()) (guile (default-guile))) - "Return an executable script NAME that runs EXP using GUILE with MODULES in -its search path." - (define %modules - (append (gexp-modules exp) modules)) - - (mlet %store-monad ((set-load-path (load-path-expression %modules))) + #:key (guile (default-guile))) + "Return an executable script NAME that runs EXP using GUILE, with EXP's +imported modules in its search path." + (mlet %store-monad ((set-load-path + (load-path-expression (gexp-modules exp)))) (gexp->derivation name (gexp (call-with-output-file (ungexp output) -- cgit v1.3 From 66a35ceb43f53c3f3e363714c9a6a402f243670d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Jul 2016 18:00:16 +0200 Subject: gexp: Remove more uses of #:modules. * guix/scripts/system.scm (switch-to-system): Adjust comment. * tests/gexp.scm ("gexp->derivation #:references-graphs"): Use 'with-imported-modules' instead of #:modules. * tests/grafts.scm ("graft-derivation, preserve empty directories"): Likewise. --- guix/scripts/system.scm | 2 +- tests/gexp.scm | 36 ++++++++++++++++++------------------ tests/grafts.scm | 16 ++++++++-------- 3 files changed, 27 insertions(+), 27 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index dd1e534c9..e2c6b2efe 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -362,7 +362,7 @@ it atomically, and then run OS's activation 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 …). + ;; computes derivations with 'gexp->derivation'. (save-load-path-excursion (primitive-load (derivation->output-path script)))) diff --git a/tests/gexp.scm b/tests/gexp.scm index 36ce66f7c..03a64fa6b 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -601,26 +601,26 @@ ((one (text-file "one" (random-text))) (two (gexp->derivation "two" #~(symlink #$one #$output:chbouib))) - (drv (gexp->derivation "ref-graphs" - #~(begin - (use-modules (guix build store-copy)) - (with-output-to-file #$output - (lambda () - (write (call-with-input-file "guile" - read-reference-graph)))) - (with-output-to-file #$output:one - (lambda () - (write (call-with-input-file "one" - read-reference-graph)))) - (with-output-to-file #$output:two - (lambda () - (write (call-with-input-file "two" - read-reference-graph))))) + (build -> (with-imported-modules '((guix build store-copy) + (guix build utils)) + #~(begin + (use-modules (guix build store-copy)) + (with-output-to-file #$output + (lambda () + (write (call-with-input-file "guile" + read-reference-graph)))) + (with-output-to-file #$output:one + (lambda () + (write (call-with-input-file "one" + read-reference-graph)))) + (with-output-to-file #$output:two + (lambda () + (write (call-with-input-file "two" + read-reference-graph))))))) + (drv (gexp->derivation "ref-graphs" build #:references-graphs `(("one" ,one) ("two" ,two "chbouib") - ("guile" ,%bootstrap-guile)) - #:modules '((guix build store-copy) - (guix build utils)))) + ("guile" ,%bootstrap-guile)))) (ok? (built-derivations (list drv))) (guile-drv (package->derivation %bootstrap-guile)) (bash (interned-file (search-bootstrap-binary "bash" diff --git a/tests/grafts.scm b/tests/grafts.scm index 8cd048552..13c56750e 100644 --- a/tests/grafts.scm +++ b/tests/grafts.scm @@ -135,14 +135,14 @@ (replacement fake))) (drv (gexp->derivation "to-graft" - #~(begin - (use-modules (guix build utils)) - (mkdir-p (string-append #$output - "/a/b/c/d")) - (symlink #$%bash - (string-append #$output - "/bash"))) - #:modules '((guix build utils)))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (mkdir-p (string-append #$output + "/a/b/c/d")) + (symlink #$%bash + (string-append #$output + "/bash")))))) (grafted ((store-lift graft-derivation) drv (list graft))) (_ (built-derivations (list grafted))) -- cgit v1.3 From 1929fdba80ab2432d0a9c27633c94a79fb3bb170 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Jul 2016 22:23:12 +0200 Subject: packages: no longer has an 'imported-modules' field. * guix/packages.scm ()[imported-modules]: Remove. (patch-and-repack): Remove #:imported-modules. Use 'with-imported-modules'. Remove #:modules argument to 'gexp->derivation'. (origin->derivation): Adjust accordingly. * doc/guix.texi (origin Reference): Adjust accordingly. --- doc/guix.texi | 9 +-- guix/packages.scm | 209 ++++++++++++++++++++++++++---------------------------- 2 files changed, 105 insertions(+), 113 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 6d424b23e..67ece1d23 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2697,8 +2697,9 @@ file name explicitly because the default is not very descriptive. A list of file names containing patches to be applied to the source. @item @code{snippet} (default: @code{#f}) -A quoted piece of code that will be run in the source directory to make -any modifications, which is sometimes more convenient than a patch. +A G-expression (@pxref{G-Expressions}) or S-expression that will be run +in the source directory. This is a convenient way to modify the source, +sometimes more convenient than a patch. @item @code{patch-flags} (default: @code{'("-p1")}) A list of command-line flags that should be passed to the @code{patch} @@ -2713,10 +2714,6 @@ such as GNU@tie{}Patch. A list of Guile modules that should be loaded during the patching process and while running the code in the @code{snippet} field. -@item @code{imported-modules} (default: @code{'()}) -The list of Guile modules to import in the patch derivation, for use by -the @code{snippet}. - @item @code{patch-guile} (default: @code{#f}) The Guile package that should be used in the patching process. When this is @code{#f}, a sensible default is used. diff --git a/guix/packages.scm b/guix/packages.scm index acb8f3441..bfb4c557a 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -56,7 +56,6 @@ origin-patch-guile origin-snippet origin-modules - origin-imported-modules base32 package @@ -164,8 +163,7 @@ (default #f)) (modules origin-modules ; list of module names (default '())) - (imported-modules origin-imported-modules ; list of module names - (default '())) + (patch-guile origin-patch-guile ; package or #f (default #f))) @@ -381,14 +379,13 @@ the build code of derivation." (snippet #f) (flags '("-p1")) (modules '()) - (imported-modules '()) (guile-for-build (%guile-for-build)) (system (%current-system))) "Unpack SOURCE (a derivation or store path), apply all of PATCHES, and repack the tarball using the tools listed in INPUTS. When SNIPPET is true, it must be an s-expression that will run from within the directory where -SOURCE was unpacked, after all of PATCHES have been applied. MODULES and -IMPORTED-MODULES specify modules to use/import for use by SNIPPET." +SOURCE was unpacked, after all of PATCHES have been applied. MODULES +specifies modules in scope when evaluating SNIPPET." (define source-file-name ;; SOURCE is usually a derivation, but it could be a store file. (if (derivation? source) @@ -449,107 +446,107 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET." (patches (sequence %store-monad (map instantiate-patch patches)))) (define build - #~(begin - (use-modules (ice-9 ftw) - (srfi srfi-1) - (guix build utils)) - - ;; The --sort option was added to GNU tar in version 1.28, released - ;; 2014-07-28. During bootstrap we must cope with older versions. - (define tar-supports-sort? - (zero? (system* (string-append #+tar "/bin/tar") - "cf" "/dev/null" "--files-from=/dev/null" - "--sort=name"))) - - (define (apply-patch patch) - (format (current-error-port) "applying '~a'...~%" patch) - - ;; Use '--force' so that patches that do not apply perfectly are - ;; rejected. - (zero? (system* (string-append #+patch "/bin/patch") - "--force" #+@flags "--input" patch))) - - (define (first-file directory) - ;; Return the name of the first file in DIRECTORY. - (car (scandir directory - (lambda (name) - (not (member name '("." ".."))))))) - - ;; Encoding/decoding errors shouldn't be silent. - (fluid-set! %default-port-conversion-strategy 'error) - - (when #+locales - ;; First of all, install a UTF-8 locale so that UTF-8 file names - ;; are correctly interpreted. During bootstrap, LOCALES is #f. - (setenv "LOCPATH" - (string-append #+locales "/lib/locale/" - #+(and locales - (package-version locales)))) - (setlocale LC_ALL "en_US.utf8")) - - (setenv "PATH" (string-append #+xz "/bin" ":" - #+decomp "/bin")) - - ;; SOURCE may be either a directory or a tarball. - (and (if (file-is-directory? #+source) - (let* ((store (%store-directory)) - (len (+ 1 (string-length store))) - (base (string-drop #+source len)) - (dash (string-index base #\-)) - (directory (string-drop base (+ 1 dash)))) - (mkdir directory) - (copy-recursively #+source directory) - #t) - #+(if (string=? decompression-type "unzip") - #~(zero? (system* "unzip" #+source)) - #~(zero? (system* (string-append #+tar "/bin/tar") - "xvf" #+source)))) - (let ((directory (first-file "."))) - (format (current-error-port) - "source is under '~a'~%" directory) - (chdir directory) - - (and (every apply-patch '#+patches) - #+@(if snippet - #~((let ((module (make-fresh-user-module))) - (module-use-interfaces! module - (map resolve-interface - '#+modules)) - ((@ (system base compile) compile) - '#+snippet - #:to 'value - #:opts %auto-compilation-options - #:env module))) - #~()) - - (begin (chdir "..") #t) - - (unless tar-supports-sort? - (call-with-output-file ".file_list" - (lambda (port) - (for-each (lambda (name) (format port "~a~%" name)) - (find-files directory - #:directories? #t - #:fail-on-error? #t))))) - (zero? (apply system* (string-append #+tar "/bin/tar") - "cvfa" #$output - ;; avoid non-determinism in the archive - "--mtime=@0" - "--owner=root:0" - "--group=root:0" - (if tar-supports-sort? - `("--sort=name" - ,directory) - '("--no-recursion" - "--files-from=.file_list"))))))))) - - (let ((name (tarxz-name original-file-name)) - (modules (delete-duplicates (cons '(guix build utils) - imported-modules)))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (ice-9 ftw) + (srfi srfi-1) + (guix build utils)) + + ;; The --sort option was added to GNU tar in version 1.28, released + ;; 2014-07-28. During bootstrap we must cope with older versions. + (define tar-supports-sort? + (zero? (system* (string-append #+tar "/bin/tar") + "cf" "/dev/null" "--files-from=/dev/null" + "--sort=name"))) + + (define (apply-patch patch) + (format (current-error-port) "applying '~a'...~%" patch) + + ;; Use '--force' so that patches that do not apply perfectly are + ;; rejected. + (zero? (system* (string-append #+patch "/bin/patch") + "--force" #+@flags "--input" patch))) + + (define (first-file directory) + ;; Return the name of the first file in DIRECTORY. + (car (scandir directory + (lambda (name) + (not (member name '("." ".."))))))) + + ;; Encoding/decoding errors shouldn't be silent. + (fluid-set! %default-port-conversion-strategy 'error) + + (when #+locales + ;; First of all, install a UTF-8 locale so that UTF-8 file names + ;; are correctly interpreted. During bootstrap, LOCALES is #f. + (setenv "LOCPATH" + (string-append #+locales "/lib/locale/" + #+(and locales + (package-version locales)))) + (setlocale LC_ALL "en_US.utf8")) + + (setenv "PATH" (string-append #+xz "/bin" ":" + #+decomp "/bin")) + + ;; SOURCE may be either a directory or a tarball. + (and (if (file-is-directory? #+source) + (let* ((store (%store-directory)) + (len (+ 1 (string-length store))) + (base (string-drop #+source len)) + (dash (string-index base #\-)) + (directory (string-drop base (+ 1 dash)))) + (mkdir directory) + (copy-recursively #+source directory) + #t) + #+(if (string=? decompression-type "unzip") + #~(zero? (system* "unzip" #+source)) + #~(zero? (system* (string-append #+tar "/bin/tar") + "xvf" #+source)))) + (let ((directory (first-file "."))) + (format (current-error-port) + "source is under '~a'~%" directory) + (chdir directory) + + (and (every apply-patch '#+patches) + #+@(if snippet + #~((let ((module (make-fresh-user-module))) + (module-use-interfaces! + module + (map resolve-interface '#+modules)) + ((@ (system base compile) compile) + '#+snippet + #:to 'value + #:opts %auto-compilation-options + #:env module))) + #~()) + + (begin (chdir "..") #t) + + (unless tar-supports-sort? + (call-with-output-file ".file_list" + (lambda (port) + (for-each (lambda (name) + (format port "~a~%" name)) + (find-files directory + #:directories? #t + #:fail-on-error? #t))))) + (zero? (apply system* + (string-append #+tar "/bin/tar") + "cvfa" #$output + ;; avoid non-determinism in the archive + "--mtime=@0" + "--owner=root:0" + "--group=root:0" + (if tar-supports-sort? + `("--sort=name" + ,directory) + '("--no-recursion" + "--files-from=.file_list")))))))))) + + (let ((name (tarxz-name original-file-name))) (gexp->derivation name build #:graft? #f #:system system - #:modules modules #:guile-for-build guile-for-build)))) (define (transitive-inputs inputs) @@ -1138,8 +1135,7 @@ cross-compilation target triplet." ;; No patches, no snippet: this is a fixed-output derivation. (method uri 'sha256 sha256 name #:system system)) (($ uri method sha256 name (= force (patches ...)) snippet - (flags ...) inputs (modules ...) (imported-modules ...) - guile-for-build) + (flags ...) inputs (modules ...) guile-for-build) ;; Patches and/or a snippet. (mlet %store-monad ((source (method uri 'sha256 sha256 name #:system system)) @@ -1153,7 +1149,6 @@ cross-compilation target triplet." #:flags flags #:system system #:modules modules - #:imported-modules imported-modules #:guile-for-build guile))))) (define-gexp-compiler (origin-compiler (origin origin?) system target) -- cgit v1.3 From cd4c41fdcf469524161fbbec58c2756f36bcef56 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 13 Jul 2016 00:32:36 +0200 Subject: download: Attempt to update SourceForge mirror URLs. * guix/download.scm (%mirrors)[sourceforge]: End in "/project" instead of "/sourceforge". Remove a couple of dangling URLs. --- guix/download.scm | 38 +++++++++++++++++--------------------- 1 file changed, 17 insertions(+), 21 deletions(-) (limited to 'guix') diff --git a/guix/download.scm b/guix/download.scm index 336bc541e..bcb043ba8 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -99,27 +99,23 @@ "http://www.centervenus.com/mirrors/nongnu/" "http://download.savannah.gnu.org/releases-noredirect/") (sourceforge ; https://sourceforge.net/p/forge/documentation/Mirrors/ - "http://prdownloads.sourceforge.net/" - "http://heanet.dl.sourceforge.net/sourceforge/" - "http://dfn.dl.sourceforge.net/sourceforge/" - "http://freefr.dl.sourceforge.net/sourceforge/" - "http://internode.dl.sourceforge.net/sourceforge/" - "http://iweb.dl.sourceforge.net/sourceforge/" - "http://jaist.dl.sourceforge.net/sourceforge/" - "http://kaz.dl.sourceforge.net/sourceforge/" - "http://kent.dl.sourceforge.net/sourceforge/" - "http://liquidtelecom.dl.sourceforge.net/sourceforge/" - "http://nbtelecom.dl.sourceforge.net/sourceforge/" - "http://nchc.dl.sourceforge.net/sourceforge/" - "http://ncu.dl.sourceforge.net/sourceforge/" - "http://netcologne.dl.sourceforge.net/sourceforge/" - "http://netix.dl.sourceforge.net/sourceforge/" - "http://pilotfiber.dl.sourceforge.net/sourceforge/" - "http://superb-sea2.dl.sourceforge.net/sourceforge/" - "http://tenet.dl.sourceforge.net/sourceforge/" - "http://ufpr.dl.sourceforge.net/sourceforge/" - "http://vorboss.dl.sourceforge.net/sourceforge/" - "http://netassist.dl.sourceforge.net/sourceforge/") + "http://ufpr.dl.sourceforge.net/project/" + "http://heanet.dl.sourceforge.net/project/" + "http://freefr.dl.sourceforge.net/project/" + "http://internode.dl.sourceforge.net/project/" + "http://jaist.dl.sourceforge.net/project/" + "http://kent.dl.sourceforge.net/project/" + "http://liquidtelecom.dl.sourceforge.net/project/" + "http://nbtelecom.dl.sourceforge.net/project/" + "http://nchc.dl.sourceforge.net/project/" + "http://ncu.dl.sourceforge.net/project/" + "http://netcologne.dl.sourceforge.net/project/" + "http://netix.dl.sourceforge.net/project/" + "http://pilotfiber.dl.sourceforge.net/project/" + "http://superb-sea2.dl.sourceforge.net/project/" + "http://tenet.dl.sourceforge.net/project/" + "http://vorboss.dl.sourceforge.net/project/" + "http://netassist.dl.sourceforge.net/project/") (kernel.org "http://www.all.kernel.org/pub/" "http://ramses.wh2.tu-dresden.de/pub/mirrors/kernel.org/" -- cgit v1.3 From bfcb3d767bbc24dc6c6d834619073351fbcc61b5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 13 Jul 2016 00:50:05 +0200 Subject: lint: 'validate-uri' reports suspiciously small 200 responses. * guix/scripts/lint.scm (validate-uri): Upon 200 http-response, check the 'response-content-length' and emit a warning when it is <= 1000. * tests/lint.scm (call-with-http-server): Add 'data' parameter. (with-http-server): Likewise. (%long-string): New variable. ("home-page: 200"): Pass %LONG-STRING to 'with-http-server'. ("home-page: 404", "source: 200", "source: 404"): Likewise. ("home-page: 200 but short length"): New test. ("source: 200 but short length"): New test. --- guix/scripts/lint.scm | 17 ++++++++++++++++- tests/lint.scm | 52 ++++++++++++++++++++++++++++++++++++++++----------- 2 files changed, 57 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index b4fdb6f90..d5e9197cc 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -359,7 +359,22 @@ warning for PACKAGE mentionning the FIELD." (probe-uri uri #:timeout 3))) ;wait at most 3 seconds (case status ((http-response) - (or (= 200 (response-code argument)) + (if (= 200 (response-code argument)) + (match (response-content-length argument) + ((? number? length) + ;; As of July 2016, SourceForge returns 200 (instead of 404) + ;; with a small HTML page upon failure. Attempt to detect such + ;; malicious behavior. + (or (> length 1000) + (begin + (emit-warning package + (format #f + (_ "URI ~a returned \ +suspiciously small file (~a bytes)") + (uri->string uri) + length)) + #f))) + (_ #t)) (begin (emit-warning package (format #f diff --git a/tests/lint.scm b/tests/lint.scm index 1f1b0c95e..ce751c42c 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -102,14 +102,14 @@ http-write (@@ (web server http) http-close)) -(define (call-with-http-server code thunk) - "Call THUNK with an HTTP server running and returning CODE on HTTP -requests." +(define (call-with-http-server code data thunk) + "Call THUNK with an HTTP server running and returning CODE and DATA (a +string) on HTTP requests." (define (server-body) (define (handle request body) (values (build-response #:code code #:reason-phrase "Such is life") - "Hello, world.")) + data)) (catch 'quit (lambda () @@ -123,8 +123,11 @@ requests." ;; Normally SERVER exits automatically once it has received a request. (thunk)))) -(define-syntax-rule (with-http-server code body ...) - (call-with-http-server code (lambda () body ...))) +(define-syntax-rule (with-http-server code data body ...) + (call-with-http-server code data (lambda () body ...))) + +(define %long-string + (make-string 2000 #\a)) (test-begin "lint") @@ -402,18 +405,30 @@ requests." (test-equal "home-page: 200" "" (with-warnings - (with-http-server 200 + (with-http-server 200 %long-string (let ((pkg (package (inherit (dummy-package "x")) (home-page %local-url)))) (check-home-page pkg))))) +(test-skip (if %http-server-socket 0 1)) +(test-assert "home-page: 200 but short length" + (->bool + (string-contains + (with-warnings + (with-http-server 200 "This is too small." + (let ((pkg (package + (inherit (dummy-package "x")) + (home-page %local-url)))) + (check-home-page pkg)))) + "suspiciously small"))) + (test-skip (if %http-server-socket 0 1)) (test-assert "home-page: 404" (->bool (string-contains (with-warnings - (with-http-server 404 + (with-http-server 404 %long-string (let ((pkg (package (inherit (dummy-package "x")) (home-page %local-url)))) @@ -501,7 +516,7 @@ requests." (test-equal "source: 200" "" (with-warnings - (with-http-server 200 + (with-http-server 200 %long-string (let ((pkg (package (inherit (dummy-package "x")) (source (origin @@ -510,12 +525,27 @@ requests." (sha256 %null-sha256)))))) (check-source pkg))))) +(test-skip (if %http-server-socket 0 1)) +(test-assert "source: 200 but short length" + (->bool + (string-contains + (with-warnings + (with-http-server 200 "This is too small." + (let ((pkg (package + (inherit (dummy-package "x")) + (source (origin + (method url-fetch) + (uri %local-url) + (sha256 %null-sha256)))))) + (check-source pkg)))) + "suspiciously small"))) + (test-skip (if %http-server-socket 0 1)) (test-assert "source: 404" (->bool (string-contains (with-warnings - (with-http-server 404 + (with-http-server 404 %long-string (let ((pkg (package (inherit (dummy-package "x")) (source (origin @@ -617,6 +647,6 @@ requests." (test-end "lint") ;; Local Variables: -;; eval: (put 'with-http-server 'scheme-indent-function 1) +;; eval: (put 'with-http-server 'scheme-indent-function 2) ;; eval: (put 'with-warnings 'scheme-indent-function 0) ;; End: -- cgit v1.3 From a7a3b390600351014bee523cadb25c9a242064e9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 14 Jul 2016 15:19:07 +0200 Subject: substitute: Gracefully handle trailing slashes in URLs. Previously, using something like "--substitute-urls=http://example.org///" would lead to a 'cache-narinfo!' call with #f as its second argument. It would also do the wrong thing for URLs with a non-empty initial path component, such as "http://example.org/foo/bar". * guix/scripts/substitute.scm (fetch-narinfos)[handle-narinfo-response]: Add call to 'basename' for PATH. --- guix/scripts/substitute.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 5722aa821..8827c45fb 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -610,7 +610,8 @@ if file doesn't exist, and the narinfo otherwise." (update-progress!) (cons narinfo result)) (let* ((path (uri-path (request-uri request))) - (hash-part (string-drop-right path 8))) ; drop ".narinfo" + (hash-part (basename + (string-drop-right path 8)))) ;drop ".narinfo" (if len (get-bytevector-n port len) (read-to-eof port)) -- cgit v1.3 From db8f6b34121b392df12b551b3f7ca16349dc7018 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 14 Jul 2016 15:25:00 +0200 Subject: challenge: Disable grafting. * guix/scripts/challenge.scm (guix-challenge): Set %GRAFT? to #f. --- guix/scripts/challenge.scm | 40 ++++++++++++++++++++++------------------ 1 file changed, 22 insertions(+), 18 deletions(-) (limited to 'guix') diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 149647cfd..590d8f109 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -21,6 +21,7 @@ #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix grafts) #:use-module (guix monads) #:use-module (guix base32) #:use-module (guix packages) @@ -222,23 +223,26 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) (urls (assoc-ref opts 'substitute-urls))) (leave-on-EPIPE (with-store store - (let ((files (match files - (() - (filter (cut locally-built? store <>) - (live-paths store))) - (x - files)))) - (set-build-options store - #:use-substitutes? #f) - - (run-with-store store - (mlet* %store-monad ((items (mapm %store-monad - ensure-store-item files)) - (issues (discrepancies items urls))) - (for-each summarize-discrepancy issues) - (unless (null? issues) - (exit 2)) - (return (null? issues))) - #:system system))))))) + ;; Disable grafts since substitute servers normally provide only + ;; ungrafted stuff. + (parameterize ((%graft? #f)) + (let ((files (match files + (() + (filter (cut locally-built? store <>) + (live-paths store))) + (x + files)))) + (set-build-options store + #:use-substitutes? #f) + + (run-with-store store + (mlet* %store-monad ((items (mapm %store-monad + ensure-store-item files)) + (issues (discrepancies items urls))) + (for-each summarize-discrepancy issues) + (unless (null? issues) + (exit 2)) + (return (null? issues))) + #:system system)))))))) ;;; challenge.scm ends here -- cgit v1.3 From babc2c80a7e1f1b5e72fd1685ef6604b93157a8e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 14 Jul 2016 18:58:36 +0200 Subject: records: Improve reporting of invalid field specifiers. Fixes . Reported by Vincent Legoll . * guix/records.scm (report-invalid-field-specifier): New procedure. * tests/records.scm ("define-record-type* & wrong field specifier"): New test. --- guix/records.scm | 19 +++++++++++++++++-- tests/records.scm | 29 ++++++++++++++++++++++++++++- 2 files changed, 45 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/records.scm b/guix/records.scm index 0d35a747b..f3f3aafb0 100644 --- a/guix/records.scm +++ b/guix/records.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 ;;; ;;; This file is part of GNU Guix. ;;; @@ -42,6 +42,15 @@ (format #f fmt args ...) form)))) +(define (report-invalid-field-specifier name bindings) + "Report the first invalid binding among BINDINGS." + (let loop ((bindings bindings)) + (syntax-case bindings () + (((field value) rest ...) ;good + (loop #'(rest ...))) + ((weird _ ...) ;weird! + (syntax-violation name "invalid field specifier" #'weird))))) + (define-syntax make-syntactic-constructor (syntax-rules () "Make the syntactic constructor NAME for TYPE, that calls CTOR, and @@ -147,7 +156,13 @@ fields, and DELAYED is the list of identifiers of delayed fields." "missing field initializers ~a" (lset-difference eq? '(expected ...) - fields))))))))))))) + fields))))))) + ((_ bindings (... ...)) + ;; One of BINDINGS doesn't match the (field value) pattern. + ;; Report precisely which one is faulty, instead of letting the + ;; "source expression failed to match any pattern" error. + (report-invalid-field-specifier 'name + #'(bindings (... ...)))))))))) (define-syntax-rule (define-field-property-predicate predicate property) "Define PREDICATE as a procedure that takes a syntax object and, when passed diff --git a/tests/records.scm b/tests/records.scm index c6f85d4a8..d6d27bb96 100644 --- a/tests/records.scm +++ b/tests/records.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 ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,6 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (test-records) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-64) #:use-module (ice-9 match) #:use-module (ice-9 regex) @@ -214,6 +215,32 @@ (equal? (foo-bar y) 1)) ;promise was already forced (eq? (foo-baz y) 'b))))) +(test-assert "define-record-type* & wrong field specifier" + (let ((exp '(begin + (define-record-type* foo make-foo + foo? + (bar foo-bar (default 42)) + (baz foo-baz)) + + (foo (baz 1 2 3 4 5)))) ;syntax error + (loc (current-source-location))) ;keep this alignment! + (catch 'syntax-error + (lambda () + (eval exp (test-module)) + #f) + (lambda (key proc message location form . args) + (and (eq? proc 'foo) + (string-match "invalid field" message) + (equal? form '(baz 1 2 3 4 5)) + + ;; Make sure the location is that of the field specifier. + ;; See . + (lset= equal? + (pk 'expected-loc + `((line . ,(- (assq-ref loc 'line) 1)) + ,@(alist-delete 'line loc))) + (pk 'actual-loc location))))))) + (test-assert "define-record-type* & missing initializers" (catch 'syntax-error (lambda () -- cgit v1.3 From f82ce8f6b1e1f64aad08e66eec77d72d8e53b1ad Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 16 Jul 2016 12:52:42 +0200 Subject: build: Substitute URLs now default to "mirror.hydra.gnu.org" alone. * config-daemon.ac: Remove "hydra.gnu.org" from 'guix_substitute_urls'. * guix/store.scm (%default-substitute-urls): Remove "hydra.gnu.org". --- config-daemon.ac | 4 ++-- guix/store.scm | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/config-daemon.ac b/config-daemon.ac index 803eb5369..f66f31269 100644 --- a/config-daemon.ac +++ b/config-daemon.ac @@ -113,10 +113,10 @@ if test "x$guix_build_daemon" = "xyes"; then dnl Determine the appropriate default list of substitute URLs. GUILE_MODULE_AVAILABLE([have_gnutls], [(gnutls)]) if test "x$have_gnutls" = "xyes"; then - guix_substitute_urls="https://mirror.hydra.gnu.org https://hydra.gnu.org" + guix_substitute_urls="https://mirror.hydra.gnu.org" else AC_MSG_WARN([GnuTLS is missing, substitutes will be downloaded in the clear]) - guix_substitute_urls="http://mirror.hydra.gnu.org http://hydra.gnu.org" + guix_substitute_urls="http://mirror.hydra.gnu.org" fi AC_MSG_CHECKING([for default substitute URLs]) AC_MSG_RESULT([$guix_substitute_urls]) diff --git a/guix/store.scm b/guix/store.scm index 276684e2f..9f409b420 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -510,7 +510,7 @@ encoding conversion errors." (map (if (false-if-exception (resolve-interface '(gnutls))) (cut string-append "https://" <>) (cut string-append "http://" <>)) - '("mirror.hydra.gnu.org" "hydra.gnu.org"))) + '("mirror.hydra.gnu.org"))) (define* (set-build-options server #:key keep-failed? keep-going? fallback? -- cgit v1.3 From 1187a27112be10f2ff74144f50c88714ccf30301 Mon Sep 17 00:00:00 2001 From: Vincent Legoll Date: Sat, 16 Jul 2016 10:05:48 +0200 Subject: guix gc: Display of saved space for garbage collection. Fixes . * guix/scripts/gc.scm (guix-gc): Display freed bytes. Signed-off-by: Vincent Legoll Signed-off-by: Ludovic Courtès --- guix/scripts/gc.scm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 8db28138c..bdfee4308 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -24,6 +24,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:export (guix-gc)) @@ -221,9 +222,11 @@ Invoke the garbage collector.\n")) (free-space (ensure-free-space store free-space)) (min-freed - (collect-garbage store min-freed)) + (let-values (((paths freed) (collect-garbage store min-freed))) + (info (_ "freed ~h bytes~%") freed))) (else - (collect-garbage store))))) + (let-values (((paths freed) (collect-garbage store))) + (info (_ "freed ~h bytes~%") freed)))))) ((delete) (delete-paths store (map direct-store-path paths))) ((list-references) -- cgit v1.3 From 721539026dda02e58addbb618f2102b31a2927f8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 18 Jul 2016 23:14:14 +0200 Subject: Add (guix zlib). * guix/zlib.scm, tests/zlib.scm: New files. * Makefile.am (MODULES): Add guix/zlib.scm. (SCM_TESTS): Add tests/zlib.scm. * m4/guix.m4 (GUIX_LIBGCRYPT_LIBDIR): New macro. * configure.ac (LIBGCRYPT_LIBDIR): Use it. Define and substitute 'LIBZ'. * guix/config.scm.in (%libz): New variable. --- .dir-locals.el | 2 + Makefile.am | 2 + configure.ac | 11 +++ guix/config.scm.in | 6 +- guix/zlib.scm | 234 +++++++++++++++++++++++++++++++++++++++++++++++++++++ m4/guix.m4 | 11 +++ tests/zlib.scm | 63 +++++++++++++++ 7 files changed, 328 insertions(+), 1 deletion(-) create mode 100644 guix/zlib.scm create mode 100644 tests/zlib.scm (limited to 'guix') diff --git a/.dir-locals.el b/.dir-locals.el index c7ceb9e9f..572a35f82 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -41,6 +41,8 @@ (eval . (put 'with-atomic-file-output 'scheme-indent-function 1)) (eval . (put 'call-with-compressed-output-port 'scheme-indent-function 2)) (eval . (put 'call-with-decompressed-port 'scheme-indent-function 2)) + (eval . (put 'call-with-gzip-input-port 'scheme-indent-function 1)) + (eval . (put 'call-with-gzip-output-port 'scheme-indent-function 1)) (eval . (put 'signature-case 'scheme-indent-function 1)) (eval . (put 'emacs-batch-eval 'scheme-indent-function 0)) (eval . (put 'emacs-batch-edit-file 'scheme-indent-function 1)) diff --git a/Makefile.am b/Makefile.am index 37a0aef7d..576177f6d 100644 --- a/Makefile.am +++ b/Makefile.am @@ -57,6 +57,7 @@ MODULES = \ guix/licenses.scm \ guix/graph.scm \ guix/cve.scm \ + guix/zlib.scm \ guix/build-system.scm \ guix/build-system/ant.scm \ guix/build-system/cmake.scm \ @@ -258,6 +259,7 @@ SCM_TESTS = \ tests/graph.scm \ tests/challenge.scm \ tests/cve.scm \ + tests/zlib.scm \ tests/file-systems.scm \ tests/system.scm \ tests/services.scm \ diff --git a/configure.ac b/configure.ac index 7c6fcc9ec..8367b41f3 100644 --- a/configure.ac +++ b/configure.ac @@ -194,6 +194,17 @@ AC_SUBST([LIBGCRYPT_LIBDIR]) GUIX_ASSERT_LIBGCRYPT_USABLE +dnl Library name of zlib suitable for 'dynamic-link'. +GUIX_LIBZ_LIBDIR([libz_libdir]) +if test "x$libz_libdir" = "x"; then + LIBZ="libz" +else + LIBZ="$libz_libdir/libz" +fi +AC_MSG_CHECKING([for zlib's shared library name]) +AC_MSG_RESULT([$LIBZ]) +AC_SUBST([LIBZ]) + AC_CACHE_SAVE m4_include([config-daemon.ac]) diff --git a/guix/config.scm.in b/guix/config.scm.in index adffa0cfe..6d42cf233 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -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 ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,6 +27,7 @@ %guix-register-program %system %libgcrypt + %libz %nix-instantiate %gzip %bzip2 @@ -72,6 +73,9 @@ (define %libgcrypt "@LIBGCRYPT@") +(define %libz + "@LIBZ@") + (define %nix-instantiate "@NIX_INSTANTIATE@") diff --git a/guix/zlib.scm b/guix/zlib.scm new file mode 100644 index 000000000..51e5e9e42 --- /dev/null +++ b/guix/zlib.scm @@ -0,0 +1,234 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix zlib) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 match) + #:use-module (system foreign) + #:use-module (guix config) + #:export (zlib-available? + make-gzip-input-port + make-gzip-output-port + call-with-gzip-input-port + call-with-gzip-output-port + %default-buffer-size + %default-compression-level)) + +;;; Commentary: +;;; +;;; Bindings to the gzip-related part of zlib's API. The main limitation of +;;; this API is that it requires a file descriptor as the source or sink. +;;; +;;; Code: + +(define %zlib + ;; File name of zlib's shared library. When updating via 'guix pull', + ;; '%libz' might be undefined so protect against it. + (delay (dynamic-link (if (defined? '%libz) + %libz + "libz")))) + +(define (zlib-available?) + "Return true if zlib is available, #f otherwise." + (false-if-exception (force %zlib))) + +(define (zlib-procedure ret name parameters) + "Return a procedure corresponding to C function NAME in libz, or #f if +either zlib or the function could not be found." + (match (false-if-exception (dynamic-func name (force %zlib))) + ((? pointer? ptr) + (pointer->procedure ret ptr parameters)) + (#f + #f))) + +(define-wrapped-pointer-type + ;; Scheme counterpart of the 'gzFile' opaque type. + gzip-file? + pointer->gzip-file + gzip-file->pointer + (lambda (obj port) + (format port "#" + (number->string (object-address obj) 16)))) + +(define gzerror + (let ((proc (zlib-procedure '* "gzerror" '(* *)))) + (lambda (gzfile) + (let* ((errnum* (make-bytevector (sizeof int))) + (ptr (proc (gzip-file->pointer gzfile) + (bytevector->pointer errnum*)))) + (values (bytevector-sint-ref errnum* 0 + (native-endianness) (sizeof int)) + (pointer->string ptr)))))) + +(define gzdopen + (let ((proc (zlib-procedure '* "gzdopen" (list int '*)))) + (lambda (fd mode) + "Open file descriptor FD as a gzip stream with the given MODE. MODE must +be a string denoting the how FD is to be opened, such as \"r\" for reading or +\"w9\" for writing data compressed at level 9 to FD. Calling 'gzclose' also +closes FD." + (let ((result (proc fd (string->pointer mode)))) + (if (null-pointer? result) + (throw 'zlib-error 'gzdopen) + (pointer->gzip-file result)))))) + +(define gzread! + (let ((proc (zlib-procedure int "gzread" (list '* '* unsigned-int)))) + (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv))) + "Read up to COUNT bytes from GZFILE into BV at offset START. Return the +number of uncompressed bytes actually read." + (let ((ret (proc (gzip-file->pointer gzfile) + (bytevector->pointer bv start) + count))) + (if (< ret 0) + (throw 'zlib-error 'gzread! ret) + ret))))) + +(define gzwrite + (let ((proc (zlib-procedure int "gzwrite" (list '* '* unsigned-int)))) + (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv))) + "Write up to COUNT bytes from BV at offset START into GZFILE. Return +the number of uncompressed bytes written, a strictly positive integer." + (let ((ret (proc (gzip-file->pointer gzfile) + (bytevector->pointer bv start) + count))) + (if (<= ret 0) + (throw 'zlib-error 'gzwrite ret) + ret))))) + +(define gzbuffer! + (let ((proc (zlib-procedure int "gzbuffer" (list '* unsigned-int)))) + (lambda (gzfile size) + "Change the internal buffer size of GZFILE to SIZE bytes." + (let ((ret (proc (gzip-file->pointer gzfile) size))) + (unless (zero? ret) + (throw 'zlib-error 'gzbuffer! ret)))))) + +(define gzeof? + (let ((proc (zlib-procedure int "gzeof" '(*)))) + (lambda (gzfile) + "Return true if the end-of-file has been reached on GZFILE." + (not (zero? (proc (gzip-file->pointer gzfile))))))) + +(define gzclose + (let ((proc (zlib-procedure int "gzclose" '(*)))) + (lambda (gzfile) + "Close GZFILE." + (let ((ret (proc (gzip-file->pointer gzfile)))) + (unless (zero? ret) + (throw 'zlib-error 'gzclose ret (gzerror gzfile))))))) + + + +;;; +;;; Port interface. +;;; + +(define %default-buffer-size + ;; Default buffer size, as documented in . + 8192) + +(define %default-compression-level + ;; Z_DEFAULT_COMPRESSION. + -1) + +(define (close-procedure gzfile port) + "Return a procedure that closes GZFILE, ensuring its underlying PORT is +closed even if closing GZFILE triggers an exception." + (lambda () + (catch 'zlib-error + (lambda () + ;; 'gzclose' closes the underlying file descriptor. 'close-port' + ;; calls close(2), gets EBADF, which is ignores. + (gzclose gzfile) + (close-port port)) + (lambda args + ;; Make sure PORT is closed despite the zlib error. + (close-port port) + (apply throw args))))) + +(define* (make-gzip-input-port port #:key (buffer-size %default-buffer-size)) + "Return an input port that decompresses data read from PORT, a file port. +PORT is automatically closed when the resulting port is closed. BUFFER-SIZE +is the size in bytes of the internal buffer, 8 KiB by default; using a larger +buffer increases decompression speed." + (define gzfile + (gzdopen (fileno port) "r")) + + (define (read! bv start count) + ;; XXX: Can 'gzread!' return zero even though we haven't reached the EOF? + (gzread! gzfile bv start count)) + + (unless (= buffer-size %default-buffer-size) + (gzbuffer! gzfile buffer-size)) + + (make-custom-binary-input-port "gzip-input" read! #f #f + (close-procedure gzfile port))) + +(define* (make-gzip-output-port port + #:key + (level %default-compression-level) + (buffer-size %default-buffer-size)) + "Return an output port that compresses data at the given LEVEL, using PORT, +a file port, as its sink. PORT is automatically closed when the resulting +port is closed." + (define gzfile + (gzdopen (fileno port) + (string-append "w" (number->string level)))) + + (define (write! bv start count) + (gzwrite gzfile bv start count)) + + (unless (= buffer-size %default-buffer-size) + (gzbuffer! gzfile buffer-size)) + + (make-custom-binary-output-port "gzip-output" write! #f #f + (close-procedure gzfile port))) + +(define* (call-with-gzip-input-port port proc + #:key (buffer-size %default-buffer-size)) + "Call PROC with a port that wraps PORT and decompresses data read from it. +PORT is closed upon completion. The gzip internal buffer size is set to +BUFFER-SIZE bytes." + (let ((gzip (make-gzip-input-port port #:buffer-size buffer-size))) + (dynamic-wind + (const #t) + (lambda () + (proc gzip)) + (lambda () + (close-port gzip))))) + +(define* (call-with-gzip-output-port port proc + #:key + (level %default-compression-level) + (buffer-size %default-buffer-size)) + "Call PROC with an output port that wraps PORT and compresses data. PORT is +close upon completion. The gzip internal buffer size is set to BUFFER-SIZE +bytes." + (let ((gzip (make-gzip-output-port port + #:level level + #:buffer-size buffer-size))) + (dynamic-wind + (const #t) + (lambda () + (proc gzip)) + (lambda () + (close-port gzip))))) + +;;; zlib.scm ends here diff --git a/m4/guix.m4 b/m4/guix.m4 index 2d3dfd282..a4f83f029 100644 --- a/m4/guix.m4 +++ b/m4/guix.m4 @@ -308,6 +308,17 @@ AC_DEFUN([GUIX_LIBGCRYPT_LIBDIR], [ $1="$guix_cv_libgcrypt_libdir" ]) +dnl GUIX_LIBZ_LIBDIR VAR +dnl +dnl Attempt to determine libz's LIBDIR; store the result in VAR. +AC_DEFUN([GUIX_LIBZ_LIBDIR], [ + AC_REQUIRE([PKG_PROG_PKG_CONFIG]) + AC_CACHE_CHECK([zlib's library directory], + [guix_cv_libz_libdir], + [guix_cv_libz_libdir="`$PKG_CONFIG zlib --variable=libdir 2> /dev/null`"]) + $1="$guix_cv_libz_libdir" +]) + dnl GUIX_CURRENT_LOCALSTATEDIR dnl dnl Determine the localstatedir of an existing Guix installation and set diff --git a/tests/zlib.scm b/tests/zlib.scm new file mode 100644 index 000000000..5455240a7 --- /dev/null +++ b/tests/zlib.scm @@ -0,0 +1,63 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Ludovic Courtès +;;; +;;; 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 . + +(define-module (test-zlib) + #:use-module (guix zlib) + #:use-module (guix tests) + #:use-module (srfi srfi-64) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (ice-9 match)) + +;; Test the (guix zlib) module. + +(unless (zlib-available?) + (exit 77)) + +(test-begin "zlib") + +(test-assert "compression/decompression pipe" + (let ((data (random-bytevector (+ (random 10000) + (* 20 1024))))) + (match (pipe) + ((parent . child) + (match (primitive-fork) + (0 ;compress + (dynamic-wind + (const #t) + (lambda () + (close-port parent) + (call-with-gzip-output-port child + (lambda (port) + (put-bytevector port data)))) + (lambda () + (primitive-exit 0)))) + (pid ;decompress + (begin + (close-port child) + (let ((received (call-with-gzip-input-port parent + (lambda (port) + (get-bytevector-all port)) + #:buffer-size (* 64 1024)))) + (match (waitpid pid) + ((_ . status) + (and (zero? status) + (port-closed? parent) + (bytevector=? received data)))))))))))) + +(test-end) -- cgit v1.3 From 4a1fc562ae5eedf40f6ae4eabe30580b0983b8f6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 18 Jul 2016 23:58:34 +0200 Subject: publish: Add '--compression'. * guix/scripts/publish.scm (show-help, %options): Add '--compression'. (): New record type. (%no-compression, %default-gzip-compression): New variables. (%default-options): Add 'compression' key. (narinfo-string): Add #:compression parameter and honor it. (render-narinfo): Likewise. (render-nar): Likewise. : Add call to 'declare-header!'. (swallow-zlib-error): New macro. (nar-response-port): New procedure. (http-write): Add call to 'force-output'. Use 'nar-response-port' instead of 'response-port'. Use 'swallow-zlib-error'. (make-request-handler): Add #:compression parameter and honor it. Add "nar/gzip" URL handler. (run-publish-server): Add #:compression parameter and honor it. (guix-publish): Honor --compression. * tests/publish.scm (http-get-port, wait-until-ready): New procedures. : Run main server with "-C0". Call 'wait-until-ready'. ("/nar/gzip/*", "/*.narinfo with compression"): New tests. * doc/guix.texi (Invoking guix publish): Document it. --- doc/guix.texi | 12 ++++ guix/scripts/publish.scm | 163 ++++++++++++++++++++++++++++++++++++++++------- tests/publish.scm | 59 +++++++++++++++-- 3 files changed, 203 insertions(+), 31 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index a2732dede..6e8fb483f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5644,6 +5644,18 @@ accept connections from any interface. Change privileges to @var{user} as soon as possible---i.e., once the server socket is open and the signing key has been read. +@item --compression[=@var{level}] +@itemx -C [@var{level}] +Compress data using the given @var{level}. When @var{level} is zero, +disable compression. The range 1 to 9 corresponds to different gzip +compression levels: 1 is the fastest, and 9 is the best (CPU-intensive). +The default is 3. + +Note compression occurs on the fly and the compressed streams are not +cached. Thus, to reduce load on the machine that runs @command{guix +publish}, it may be a good idea to choose a low compression level, or to +run @command{guix publish} behind a caching proxy. + @item --ttl=@var{ttl} Produce @code{Cache-Control} HTTP headers that advertise a time-to-live (TTL) of @var{ttl}. @var{ttl} must denote a duration: @code{5d} means 5 diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 4c0aa8e41..3e1ecb9d1 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -27,6 +27,7 @@ #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) @@ -45,6 +46,7 @@ #:use-module (guix pk-crypto) #:use-module (guix store) #:use-module (guix serialization) + #:use-module (guix zlib) #:use-module (guix ui) #:use-module (guix scripts) #:export (guix-publish)) @@ -58,6 +60,9 @@ Publish ~a over HTTP.\n") %store-directory) --listen=HOST listen on the network interface for HOST")) (display (_ " -u, --user=USER change privileges to USER as soon as possible")) + (display (_ " + -C, --compression[=LEVEL] + compress archives at LEVEL")) (display (_ " --ttl=TTL announce narinfos can be cached for TTL seconds")) (display (_ " @@ -79,6 +84,20 @@ Publish ~a over HTTP.\n") %store-directory) (leave (_ "lookup of host '~a' failed: ~a~%") host (gai-strerror error))))) +;; Nar compression parameters. +(define-record-type + (compression type level) + compression? + (type compression-type) + (level compression-level)) + +(define %no-compression + (compression 'none 0)) + +(define %default-gzip-compression + ;; Since we compress on the fly, default to fast compression. + (compression 'gzip 3)) + (define %options (list (option '(#\h "help") #f #f (lambda _ @@ -102,6 +121,14 @@ Publish ~a over HTTP.\n") %store-directory) (() (leave (_ "lookup of host '~a' returned nothing") name))))) + (option '(#\C "compression") #f #t + (lambda (opt name arg result) + (match (if arg (string->number* arg) 3) + (0 + (alist-cons 'compression %no-compression result)) + (level + (alist-cons 'compression (compression 'gzip level) + result))))) (option '("ttl") #t #f (lambda (opt name arg result) (let ((duration (string->duration arg))) @@ -117,6 +144,12 @@ Publish ~a over HTTP.\n") %store-directory) (define %default-options `((port . 8080) + + ;; Default to fast & low compression. + (compression . ,(if (zlib-available?) + %default-gzip-compression + %no-compression)) + (address . ,(make-socket-address AF_INET INADDR_ANY 0)) (repl . #f))) @@ -152,12 +185,20 @@ Publish ~a over HTTP.\n") %store-directory) (define base64-encode-string (compose base64-encode string->utf8)) -(define (narinfo-string store store-path key) +(define* (narinfo-string store store-path key + #:key (compression %no-compression)) "Generate a narinfo key/value string for STORE-PATH; an exception is raised -if STORE-PATH is invalid. The narinfo is signed with KEY." +if STORE-PATH is invalid. Produce a URL that corresponds to COMPRESSION. The +narinfo is signed with KEY." (let* ((path-info (query-path-info store store-path)) - (url (encode-and-join-uri-path (list "nar" - (basename store-path)))) + (url (encode-and-join-uri-path + `("nar" + ,@(match compression + (($ 'none) + '()) + (($ type) + (list (symbol->string type)))) + ,(basename store-path)))) (hash (bytevector->nix-base32-string (path-info-hash path-info))) (size (path-info-nar-size path-info)) @@ -166,13 +207,16 @@ if STORE-PATH is invalid. The narinfo is signed with KEY." " ")) (deriver (path-info-deriver path-info)) (base-info (format #f - "StorePath: ~a + "\ +StorePath: ~a URL: ~a -Compression: none +Compression: ~a NarHash: sha256:~a NarSize: ~d References: ~a~%" - store-path url hash size references)) + store-path url + (compression-type compression) + hash size references)) ;; Do not render a "Deriver" or "System" line if we are rendering ;; info for a derivation. (info (if (not deriver) @@ -209,7 +253,8 @@ References: ~a~%" (format port "~a: ~a~%" key value))) %nix-cache-info)))) -(define* (render-narinfo store request hash #:key ttl) +(define* (render-narinfo store request hash + #:key ttl (compression %no-compression)) "Render metadata for the store path corresponding to HASH. If TTL is true, advertise it as the maximum validity period (in seconds) via the 'Cache-Control' header. This allows 'guix substitute' to cache it for an @@ -222,18 +267,35 @@ appropriate duration." `((cache-control (max-age . ,ttl))) '())) (cut display - (narinfo-string store store-path (force %private-key)) - <>))))) - -(define (render-nar store request store-item) + (narinfo-string store store-path (force %private-key) + #:compression compression) + <>))))) + +;; XXX: Declare the 'Guix-Compression' HTTP header, which is in fact for +;; internal consumption: it allows us to pass the compression info to +;; 'http-write', as part of the workaround to . +(declare-header! "Guix-Nar-Compression" + (lambda (str) + (match (call-with-input-string str read) + (('compression type level) + (compression type level)))) + compression? + (lambda (compression port) + (match compression + (($ type level) + (write `(compression ,type ,level) port))))) + +(define* (render-nar store request store-item + #:key (compression %no-compression)) "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 (valid-path? store store-path) - (values '((content-type . (application/x-nix-archive - (charset . "ISO-8859-1")))) + (values `((content-type . (application/x-nix-archive + (charset . "ISO-8859-1"))) + (guix-nar-compression . ,compression)) ;; XXX: We're not returning the actual contents, deferring ;; instead to 'http-write'. This is a hack to work around ;; . @@ -282,6 +344,28 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." (values) (apply throw args))))) +(define-syntax-rule (swallow-zlib-error exp ...) + "Swallow 'zlib-error' exceptions raised by EXP..." + (catch 'zlib-error + (lambda () + exp ...) + (const #f))) + +(define (nar-response-port response) + "Return a port on which to write the body of RESPONSE, the response of a +/nar request, according to COMPRESSION." + (match (assoc-ref (response-headers response) 'guix-nar-compression) + (($ 'gzip level) + ;; Note: We cannot used chunked encoding here because + ;; 'make-gzip-output-port' wants a file port. + (make-gzip-output-port (response-port response) + #:level level + #:buffer-size (* 64 1024))) + (($ 'none) + (response-port response)) + (#f + (response-port response)))) + (define (http-write server client response body) "Write RESPONSE and BODY to CLIENT, possibly in a separate thread to avoid blocking." @@ -293,16 +377,20 @@ blocking." (lambda () (let* ((response (write-response (sans-content-length response) client)) - (port (response-port response))) + (port (begin + (force-output client) + (nar-response-port response)))) ;; XXX: Given our ugly workaround for in ;; 'render-nar', BODY here is just the file name of the store item. ;; We call 'write-file' from here because we know that's the only ;; way to avoid building the whole nar in memory, which could ;; quickly become a real problem. As a bonus, we even do ;; sendfile(2) directly from the store files to the socket. - (swallow-EPIPE - (write-file (utf8->string body) port)) - (close-port port) + (swallow-zlib-error + (swallow-EPIPE + (write-file (utf8->string body) port))) + (swallow-zlib-error + (close-port port)) (values))))) (_ ;; Handle other responses sequentially. @@ -316,7 +404,10 @@ blocking." http-write (@@ (web server http) http-close)) -(define* (make-request-handler store #:key narinfo-ttl) +(define* (make-request-handler store + #:key + narinfo-ttl + (compression %no-compression)) (lambda (request body) (format #t "~a ~a~%" (request-method request) @@ -330,16 +421,37 @@ blocking." (((= extract-narinfo-hash (? string? hash))) ;; TODO: Register roots for HASH that will somehow remain for ;; NARINFO-TTL. - (render-narinfo store request hash #:ttl narinfo-ttl)) + (render-narinfo store request hash + #:ttl narinfo-ttl + #:compression compression)) + + ;; Use different URLs depending on the compression type. This + ;; guarantees that /nar URLs remain valid even when 'guix publish' + ;; is restarted with different compression parameters. + ;; /nar/ (("nar" store-item) - (render-nar store request store-item)) + (render-nar store request store-item + #:compression %no-compression)) + ;; /nar/gzip/ + (("nar" "gzip" store-item) + (if (zlib-available?) + (render-nar store request store-item + #:compression + (match compression + (($ 'gzip) + compression) + (_ + %default-gzip-compression))) + (not-found request))) (_ (not-found request))) (not-found request)))) (define* (run-publish-server socket store - #:key narinfo-ttl) - (run-server (make-request-handler store #:narinfo-ttl narinfo-ttl) + #:key (compression %no-compression) narinfo-ttl) + (run-server (make-request-handler store + #:narinfo-ttl narinfo-ttl + #:compression compression) concurrent-http-server `(#:socket ,socket))) @@ -378,6 +490,7 @@ blocking." (user (assoc-ref opts 'user)) (port (assoc-ref opts 'port)) (ttl (assoc-ref opts 'narinfo-ttl)) + (compression (assoc-ref opts 'compression)) (address (let ((addr (assoc-ref opts 'address))) (make-socket-address (sockaddr:fam addr) (sockaddr:addr addr) @@ -404,4 +517,6 @@ consider using the '--user' option!~%"))) (when repl-port (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port))) (with-store store - (run-publish-server socket store #:narinfo-ttl ttl))))) + (run-publish-server socket store + #:compression compression + #:narinfo-ttl ttl))))) diff --git a/tests/publish.scm b/tests/publish.scm index d6d537c58..9bf181f1f 100644 --- a/tests/publish.scm +++ b/tests/publish.scm @@ -28,12 +28,15 @@ #:use-module (guix store) #:use-module (guix base32) #:use-module (guix base64) + #:use-module ((guix records) #:select (recutils->alist)) #:use-module ((guix serialization) #:select (restore-file)) #:use-module (guix pk-crypto) + #:use-module (guix zlib) #:use-module (web uri) #:use-module (web client) #:use-module (web response) #:use-module (rnrs bytevectors) + #:use-module (ice-9 binary-ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-64) @@ -52,20 +55,28 @@ (call-with-values (lambda () (http-get uri)) (lambda (response body) body))) +(define (http-get-port uri) + (call-with-values (lambda () (http-get uri #:streaming? #t)) + (lambda (response port) port))) + (define (publish-uri route) (string-append "http://localhost:6789" route)) ;; Run a local publishing server in a separate thread. (call-with-new-thread (lambda () - (guix-publish "--port=6789"))) ; attempt to avoid port collision + (guix-publish "--port=6789" "-C0"))) ;attempt to avoid port collision + +(define (wait-until-ready port) + ;; Wait until the server is accepting connections. + (let ((conn (socket PF_INET SOCK_STREAM 0))) + (let loop () + (unless (false-if-exception + (connect conn AF_INET (inet-pton AF_INET "127.0.0.1") port)) + (loop))))) -;; Wait until the server is accepting connections. -(let ((conn (socket PF_INET SOCK_STREAM 0))) - (let loop () - (unless (false-if-exception - (connect conn AF_INET (inet-pton AF_INET "127.0.0.1") 6789)) - (loop)))) +;; Wait until the two servers are ready. +(wait-until-ready 6789) (test-begin "publish") @@ -145,6 +156,40 @@ References: ~%" (call-with-input-string nar (cut restore-file <> temp))) (call-with-input-file temp read-string)))) +(unless (zlib-available?) + (test-skip 1)) +(test-equal "/nar/gzip/*" + "bar" + (call-with-temporary-output-file + (lambda (temp port) + (let ((nar (http-get-port + (publish-uri + (string-append "/nar/gzip/" (basename %item)))))) + (call-with-gzip-input-port nar + (cut restore-file <> temp))) + (call-with-input-file temp read-string)))) + +(unless (zlib-available?) + (test-skip 1)) +(test-equal "/*.narinfo with compression" + `(("StorePath" . ,%item) + ("URL" . ,(string-append "nar/gzip/" (basename %item))) + ("Compression" . "gzip")) + (let ((thread (call-with-new-thread + (lambda () + (guix-publish "--port=6799" "-C5"))))) + (wait-until-ready 6799) + (let* ((url (string-append "http://localhost:6799/" + (store-path-hash-part %item) ".narinfo")) + (body (http-get-port url))) + (filter (lambda (item) + (match item + (("Compression" . _) #t) + (("StorePath" . _) #t) + (("URL" . _) #t) + (_ #f))) + (recutils->alist body))))) + (test-equal "/nar/ with properly encoded '+' sign" "Congrats!" (let ((item (add-text-to-store %store "fake-gtk+" "Congrats!"))) -- cgit v1.3 From 053fa76ae7bb579fe5fc9dedfc492411e6804cf0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 19 Jul 2016 16:46:16 +0200 Subject: publish: Keep compression disabled when zlib is missing. Reported by David Thompson. * guix/scripts/publish.scm (%options)[--compression]: Warn if LEVEL > 0 and zlib is missing, and return RESULT. --- guix/scripts/publish.scm | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 3e1ecb9d1..3baceaf64 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -127,8 +127,14 @@ Publish ~a over HTTP.\n") %store-directory) (0 (alist-cons 'compression %no-compression result)) (level - (alist-cons 'compression (compression 'gzip level) - result))))) + (if (zlib-available?) + (alist-cons 'compression + (compression 'gzip level) + result) + (begin + (warning (_ "zlib support is missing; \ +compression disabled~%")) + result)))))) (option '("ttl") #t #f (lambda (opt name arg result) (let ((duration (string->duration arg))) -- cgit v1.3