From 42d07286f42b82df2e4ea45e67c40da0f09f26ec Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 Dec 2016 00:38:30 +0100 Subject: publish: Factorize 'content-length' addition. * guix/scripts/publish.scm (with-content-length): New procedure. (http-write) : Use it. --- guix/scripts/publish.scm | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 1b32f639ea..33a7b3bd42 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -365,6 +365,14 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." (response-headers response) eq?))) +(define (with-content-length response length) + "Return RESPONSE with a 'content-length' header set to LENGTH." + (set-field response (response-headers) + (alist-cons 'content-length length + (alist-delete 'content-length + (response-headers response) + eq?)))) + (define-syntax-rule (swallow-EPIPE exp ...) "Swallow EPIPE errors raised by EXP..." (catch 'system-error @@ -432,13 +440,8 @@ blocking." (call-with-input-file (utf8->string body) (lambda (input) (let* ((size (stat:size (stat input))) - (headers (alist-cons 'content-length size - (alist-delete 'content-length - (response-headers response) - eq?))) - (response (write-response (set-field response - (response-headers) - headers) + (response (write-response (with-content-length response + size) client)) (output (response-port response))) (dump-port input output) -- cgit v1.2.3 From aebaee95cc26d404a8d7b62aece77dfbddb75836 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 5 Dec 2016 18:16:04 +0100 Subject: offload: Add "test" sub-command. * guix/scripts/offload.scm (assert-node-repl, assert-node-has-guix) (nonce, assert-node-can-import, assert-node-can-export) (check-machine-availability): New procedures. (%random-state): New variable. (guix-offload): Add case for "test". * doc/guix.texi (Daemon Offload Setup): Document it. Remove obsolete bit about remote invocation of 'guix build'. --- doc/guix.texi | 25 ++++++++++++-- guix/scripts/offload.scm | 87 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 109 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 47d0d7169a..4d7f96d907 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -941,9 +941,8 @@ name, and they will be scheduled on matching build machines. @end table @end deftp -The @code{guix} command must be in the search path on the build -machines, since offloading works by invoking the @code{guix archive} and -@code{guix build} commands. In addition, the Guix modules must be in +The @code{guile} command must be in the search path on the build +machines. In addition, the Guix modules must be in @code{$GUILE_LOAD_PATH} on the build machine---you can check whether this is the case by running: @@ -978,6 +977,26 @@ the master receives files from a build machine (and @i{vice versa}), its build daemon can make sure they are genuine, have not been tampered with, and that they are signed by an authorized key. +@cindex offload test +To test whether your setup is operational, run this command on the +master node: + +@example +# guix offload test +@end example + +This will attempt to connect to each of the build machines specified in +@file{/etc/guix/machines.scm}, make sure Guile and the Guix modules are +available on each machine, attempt to export to the machine and import +from it, and report any error in the process. + +If you want to test a different machine file, just specify it on the +command line: + +@example +# guix offload test machines-qualif.scm +@end example + @node Invoking guix-daemon @section Invoking @command{guix-daemon} diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 237a9638d3..4d697f7d00 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -623,6 +623,86 @@ allowed on MACHINE. Return +∞ if MACHINE is unreachable." ;; Not now, all the machines are busy. (display "# postpone\n"))))))) + +;;; +;;; Installation tests. +;;; + +(define (assert-node-repl node name) + "Bail out if NODE is not running Guile." + (match (node-guile-version node) + (#f + (leave (_ "Guile could not be started on '~a'~%") + name)) + ((? string? version) + ;; Note: The version string already contains the word "Guile". + (info (_ "'~a' is running ~a~%") + name (node-guile-version node))))) + +(define (assert-node-has-guix node name) + "Bail out if NODE lacks the (guix) module, or if its daemon is not running." + (match (node-eval node + '(begin + (use-modules (guix)) + (with-store store + (add-text-to-store store "test" + "Hello, build machine!")))) + ((? string? str) + (info (_ "Guix is usable on '~a' (test returned ~s)~%") + name str)) + (x + (leave (_ "failed to use Guix module on '~a' (test returned ~s)~%") + name x)))) + +(define %random-state + (delay + (seed->random-state (logxor (getpid) (car (gettimeofday)))))) + +(define (nonce) + (string-append (gethostname) "-" + (number->string (random 1000000 (force %random-state))))) + +(define (assert-node-can-import node name daemon-socket) + "Bail out if NODE refuses to import our archives." + (let ((session (node-session node))) + (with-store store + (let* ((item (add-text-to-store store "export-test" (nonce))) + (remote (connect-to-remote-daemon session daemon-socket))) + (send-files (list item) remote) + (if (valid-path? remote item) + (info (_ "'~a' successfully imported '~a'~%") + name item) + (leave (_ "'~a' was not properly imported on '~a'~%") + item name)))))) + +(define (assert-node-can-export node name daemon-socket) + "Bail out if we cannot import signed archives from NODE." + (let* ((session (node-session node)) + (remote (connect-to-remote-daemon session daemon-socket)) + (item (add-text-to-store remote "import-test" (nonce))) + (port (store-export-channel session (list item)))) + (with-store store + (if (and (import-paths store port) + (valid-path? store item)) + (info (_ "successfully imported '~a' from '~a'~%") + item name) + (leave (_ "failed to import '~a' from '~a'~%") + item name))))) + +(define (check-machine-availability machine-file) + "Check that each machine in MACHINE-FILE is usable as a build machine." + (let ((machines (build-machines machine-file))) + (info (_ "testing ~a build machines defined in '~a'...~%") + (length machines) machine-file) + (let* ((names (map build-machine-name machines)) + (sockets (map build-machine-daemon-socket machines)) + (sessions (map open-ssh-session machines)) + (nodes (map make-node sessions))) + (for-each assert-node-repl nodes names) + (for-each assert-node-has-guix nodes names) + (for-each assert-node-can-import nodes names sockets) + (for-each assert-node-can-export nodes names sockets)))) + ;;; ;;; Entry point. @@ -673,6 +753,13 @@ allowed on MACHINE. Return +∞ if MACHINE is unreachable." (else (leave (_ "invalid request line: ~s~%") line))) (loop (read-line))))))) + (("test" rest ...) + (with-error-handling + (let ((file (match rest + ((file) file) + (() %machine-file) + (_ (leave (_ "wrong number of arguments~%")))))) + (check-machine-availability (or file %machine-file))))) (("--version") (show-version-and-exit "guix offload")) (("--help") -- cgit v1.2.3 From d8501b844b9816b741dd4c1e372843242ec2f950 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Mon, 5 Dec 2016 20:50:10 +0100 Subject: refresh: Indicate that PACKAGE... is optional. * guix/scripts/refresh.scm (show-help): Add brackets around PACKAGE. --- guix/scripts/refresh.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index e1ff544de0..805e4543ec 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -119,7 +119,7 @@ (show-version-and-exit "guix refresh"))))) (define (show-help) - (display (_ "Usage: guix refresh [OPTION]... PACKAGE... + (display (_ "Usage: guix refresh [OPTION]... [PACKAGE]... Update package definitions to match the latest upstream version. When PACKAGE... is given, update only the specified packages. Otherwise -- cgit v1.2.3 From 067a2e2de9e5f8437ce020c62f64e08b82af72b8 Mon Sep 17 00:00:00 2001 From: Chris Marusich Date: Fri, 2 Dec 2016 01:52:04 -0800 Subject: guix system: If the new system generation already exists, overwrite it. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Before that, 'guix system reconfigure' would fail if the next generation already existed. * guix/scripts/system.scm (switch-to-system): Use 'switch-symlink' instead of 'symlink'. * doc/guix.texi (Using the Configuration System, Invoking guix system): Document the behavior. Signed-off-by: Ludovic Courtès --- doc/guix.texi | 16 +++++++++++++++- guix/scripts/system.scm | 2 +- 2 files changed, 16 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 4d7f96d907..5c94a56c01 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7174,7 +7174,15 @@ modifying or deleting previous generations. Old system generations get an entry in the GRUB boot menu, allowing you to boot them in case something went wrong with the latest generation. Reassuring, no? The @command{guix system list-generations} command lists the system -generations available on disk. +generations available on disk. It is also possible to roll back the +system via the commands @command{guix system roll-back} and +@command{guix system switch-generation}. + +Although the command @command{guix system reconfigure} will not modify +previous generations, must take care when the current generation is not +the latest (e.g., after invoking @command{guix system roll-back}), since +the operation might overwrite a later generation (@pxref{Invoking guix +system}). @unnumberedsubsubsec The Programming Interface @@ -12599,6 +12607,12 @@ currently running; if a service is currently running, it does not attempt to upgrade it since this would not be possible without stopping it first. +This command creates a new generation whose number is one greater than +the current generation (as reported by @command{guix system +list-generations}). If that generation already exists, it will be +overwritten. This behavior mirrors that of @command{guix package} +(@pxref{Invoking guix package}). + It also adds a GRUB menu entry for the new OS configuration, and moves entries for older configurations to a submenu---unless @option{--no-grub} is passed. diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index bb373a6726..144a7fd377 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -326,7 +326,7 @@ it atomically, and then run OS's activation script." (let* ((system (derivation->output-path drv)) (number (+ 1 (generation-number profile))) (generation (generation-file-name profile number))) - (symlink system generation) + (switch-symlinks generation system) (switch-symlinks profile generation) (format #t (_ "activating system...~%")) -- cgit v1.2.3 From 1d48cf948cfb825a5b080d5cbe3ba3cb69beb7c8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 5 Dec 2016 23:15:17 +0100 Subject: offload: Make the compression methods configurable. * guix/scripts/offload.scm ()[compression] [compression-level]: New fields. (open-ssh-session): Honor them. * doc/guix.texi (Daemon Offload Setup): Document them. --- doc/guix.texi | 7 +++++++ guix/scripts/offload.scm | 10 ++++++++-- 2 files changed, 15 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 5c94a56c01..738b7fb10c 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -921,6 +921,13 @@ Port number of SSH server on the machine. The SSH private key file to use when connecting to the machine, in OpenSSH format. +@item @code{compression} (default: @code{"zlib@@openssh.com,zlib"}) +@itemx @code{compression-level} (default: @code{3}) +The SSH-level compression methods and compression level requested. + +Note that offloading relies on SSH compression to reduce bandwidth usage +when transferring files to and from build machines. + @item @code{daemon-socket} (default: @code{"/var/guix/daemon-socket/socket"}) File name of the Unix-domain socket @command{guix-daemon} is listening to on that machine. diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 4d697f7d00..e20da99cbd 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -75,6 +75,10 @@ (private-key build-machine-private-key ; file name (default (user-openssh-private-key))) (host-key build-machine-host-key) ; string + (compression build-machine-compression ; string + (default "zlib@openssh.com,zlib")) + (compression-level build-machine-compression-level ;integer + (default 3)) (daemon-socket build-machine-daemon-socket ; string (default "/var/guix/daemon-socket/socket")) (parallel-builds build-machine-parallel-builds ; number @@ -175,8 +179,10 @@ private key from '~a': ~a") ;; We need lightweight compression when ;; exchanging full archives. - #:compression "zlib" - #:compression-level 3))) + #:compression + (build-machine-compression machine) + #:compression-level + (build-machine-compression-level machine)))) (match (connect! session) ('ok ;; Authenticate the server. XXX: Guile-SSH 0.10.1 doesn't know about -- cgit v1.2.3 From e11c42f297a4e128aa5abd11f379a250146f5cab Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 5 Dec 2016 23:25:29 +0100 Subject: offload: Fix plural of some messages. * guix/scripts/offload.scm (send-files): Use 'N_' for possibly plural message. Write "store item" instead of "store file". (retrieve-files): Likewise. --- guix/scripts/offload.scm | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index e20da99cbd..ed70f2267a 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -451,9 +451,11 @@ be read." (with-store store (remove (cut valid-path? store <>) ',files))))) + (count (length missing)) (port (store-import-channel session))) - (format #t (_ "sending ~a store files to '~a'...~%") - (length missing) (session-get session 'host)) + (format #t (N_ "sending ~a store item to '~a'...~%" + "sending ~a store items to '~a'...~%" count) + count (session-get session 'host)) ;; Send MISSING in topological order. (export-paths store missing port) @@ -472,9 +474,11 @@ be read." "Retrieve FILES from SESSION's store, and import them." (let* ((session (channel-get-session (nix-server-socket remote))) (host (session-get session 'host)) - (port (store-export-channel session files))) - (format #t (_ "retrieving ~a files from '~a'...~%") - (length files) host) + (port (store-export-channel session files)) + (count (length files))) + (format #t (N_ "retrieving ~a store item from '~a'...~%" + "retrieving ~a store items from '~a'...~%" count) + count host) ;; We cannot use the 'import-paths' RPC here because we already ;; hold the locks for FILES. -- cgit v1.2.3 From 0237d7971742ccfe5670455debb1feca9a491a0f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 Dec 2016 00:50:08 +0100 Subject: offload: Send the build log to the right file descriptor. This fixes a regression introduced in 21531add3205e400707c8fbfd841845f9a71863a whereby the build log would no longer be sent to FD 4, thereby leading the daemon to not see the build log. * guix/scripts/offload.scm (transfer-and-offload): Parameterize CURRENT-BUILD-OUTPUT-PORT. --- guix/scripts/offload.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index ed70f2267a..55d4c93c64 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -390,7 +390,8 @@ MACHINE." ;; Use exit code 100 for a permanent build failure. The daemon ;; interprets other non-zero codes as transient build failures. (primitive-exit 100))) - (build-derivations store (list drv))) + (parameterize ((current-build-output-port (build-log-port))) + (build-derivations store (list drv)))) (retrieve-files outputs store) (format (current-error-port) "done with offloaded '~a'~%" -- cgit v1.2.3 From 8d125cfc2e5cb0825bb40893ec3e940f85f1b235 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 Dec 2016 01:00:11 +0100 Subject: offload: Increase the connection timeout. * guix/scripts/offload.scm (open-ssh-session): Set #:timeout to 10. --- guix/scripts/offload.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 55d4c93c64..ebff11664d 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -173,7 +173,7 @@ private key from '~a': ~a") (session (make-session #:user (build-machine-user machine) #:host (build-machine-name machine) #:port (build-machine-port machine) - #:timeout 5 ;seconds + #:timeout 10 ;seconds ;; #:log-verbosity 'protocol #:identity (build-machine-private-key machine) -- cgit v1.2.3 From cba36e6482a39d9b7e3a61fb2251664a86cb492e Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 28 May 2016 17:32:04 +0200 Subject: gnu: cross-base: Add i686-w64-mingw32 target. * guix/utils.scm (mingw-target?): New function. * gnu/packages/cross-base.scm (cross-gcc-snippet): New procedure (cross-gcc): Use it. (cross-gcc-arguments, cross-gcc-patches, cross-gcc): Support MinGW. (native-libc, cross-newlib?): New functions. (cross-libc): Use cross-newlib? to support MinGW. (%gcc-include-paths, %gcc-cross-include-paths): New variables. --- gnu/packages/cross-base.scm | 309 +++++++++++++++++++++++++++++--------------- guix/utils.scm | 5 + 2 files changed, 212 insertions(+), 102 deletions(-) (limited to 'guix') diff --git a/gnu/packages/cross-base.scm b/gnu/packages/cross-base.scm index e6553dcd34..dac711472a 100644 --- a/gnu/packages/cross-base.scm +++ b/gnu/packages/cross-base.scm @@ -20,12 +20,12 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu packages cross-base) - #:use-module (guix licenses) #:use-module (gnu packages) #:use-module (gnu packages gcc) #:use-module (gnu packages base) #:use-module (gnu packages linux) #:use-module (gnu packages hurd) + #:use-module (gnu packages mingw) #:use-module (guix packages) #:use-module (guix download) #:use-module (guix utils) @@ -37,13 +37,26 @@ #:use-module (ice-9 regex) #:export (cross-binutils cross-libc - cross-gcc)) + cross-gcc + cross-newlib?)) (define %xgcc ;; GCC package used as the basis for cross-compilation. It doesn't have to ;; be 'gcc' and can be a specific variant such as 'gcc-4.8'. gcc) +(define %gcc-include-paths + ;; Environment variables for header search paths. + ;; Note: See for why not 'CPATH'. + '("C_INCLUDE_PATH" + "CPLUS_INCLUDE_PATH" + "OBJC_INCLUDE_PATH" + "OBJCPLUS_INCLUDE_PATH")) + +(define %gcc-cross-include-paths + ;; Search path for target headers when cross-compiling. + (map (cut string-append "CROSS_" <>) %gcc-include-paths)) + (define (cross p target) (package (inherit p) (name (string-append (package-name p) "-cross-" target)) @@ -131,7 +144,12 @@ may be either a libc package or #f.)" "--disable-libitm" "--disable-libvtv" "--disable-libsanitizer" - ))) + )) + + ;; For a newlib (non-glibc) target + ,@(if (cross-newlib? target) + '("--with-newlib") + '())) ,(if libc flags @@ -173,12 +191,82 @@ may be either a libc package or #f.)" ;; for cross-compilers. (zero? (system* "make" "install-strip"))) ,phases)))) - (if libc + (cond + ((target-mingw? target) + `(modify-phases ,phases + (add-before + 'configure 'set-cross-path + (lambda* (#:key inputs #:allow-other-keys) + ;; Add the cross mingw headers to CROSS_C_*_INCLUDE_PATH, + ;; and remove them from C_*INCLUDE_PATH. + (let ((libc (assoc-ref inputs "libc")) + (gcc (assoc-ref inputs "gcc"))) + (define (cross? x) + (and libc (string-prefix? libc x))) + (define (unpacked-mingw-dir) + (match + (scandir + "." + (lambda (name) (string-contains name "mingw-w64"))) + ((mingw-dir) + (string-append + (getcwd) "/" mingw-dir "/mingw-w64-headers")))) + (if libc + (let ((cpath (string-append + libc "/include" + ":" libc "/i686-w64-mingw32/include"))) + (for-each (cut setenv <> cpath) + ',%gcc-cross-include-paths)) + ;; libc is false, so we are building xgcc-sans-libc + ;; Add essential headers from mingw-w64. + (let ((mingw-source (assoc-ref inputs "mingw-source"))) + (system* "tar" "xf" mingw-source) + (let ((mingw-headers (unpacked-mingw-dir))) + ;; We need _mingw.h which will gets built from + ;; _mingw.h.in by mingw-w64's configure. We + ;; cannot configure mingw-w64 until we have + ;; xgcc-sans-libc; substitute to the rescue. + (copy-file (string-append mingw-headers + "/crt/_mingw.h.in") + (string-append mingw-headers + "/crt/_mingw.h")) + (substitute* (string-append mingw-headers + "/crt/_mingw.h") + (("@MINGW_HAS_SECURE_API@") + "#define MINGW_HAS_SECURE_API 1")) + (let ((cpath + (string-append + mingw-headers "/include" + ":" mingw-headers "/crt" + ":" mingw-headers "/defaults/include"))) + (for-each (cut setenv <> cpath) + (cons + "CROSS_LIBRARY_PATH" + ',%gcc-cross-include-paths)))) + (when libc + (setenv "CROSS_LIBRARY_PATH" + (string-append + libc "/lib" + ":" libc "/i686-w64-mingw32/lib"))))) + (setenv "CPP" (string-append gcc "/bin/cpp")) + (for-each + (lambda (var) + (and=> + (getenv var) + (lambda (value) + (let* ((path (search-path-as-string->list + value)) + (native-path (list->search-path-as-string + (remove cross? path) ":"))) + (setenv var native-path))))) + (cons "LIBRARY_PATH" ',%gcc-include-paths)) + #t))))) + (libc `(alist-cons-before 'configure 'set-cross-path (lambda* (#:key inputs #:allow-other-keys) - ;; Add the cross kernel headers to CROSS_CPATH, and remove them - ;; from CPATH. + ;; Add the cross kernel headers to CROSS_CPATH, and remove + ;; them from CPATH. (let ((libc (assoc-ref inputs "libc")) (kernel (assoc-ref inputs "xkernel-headers"))) (define (cross? x) @@ -189,37 +277,40 @@ may be either a libc package or #f.)" libc "/include" ":" kernel "/include"))) (for-each (cut setenv <> cpath) - '("CROSS_C_INCLUDE_PATH" - "CROSS_CPLUS_INCLUDE_PATH" - "CROSS_OBJC_INCLUDE_PATH" - "CROSS_OBJCPLUS_INCLUDE_PATH"))) + ',%gcc-cross-include-paths)) (setenv "CROSS_LIBRARY_PATH" (string-append libc "/lib:" kernel "/lib")) ;for Hurd's libihash (for-each (lambda (var) - (and=> (getenv var) - (lambda (value) - (let* ((path (search-path-as-string->list value)) - (native-path (list->search-path-as-string - (remove cross? path) ":"))) - (setenv var native-path))))) - '("C_INCLUDE_PATH" - "CPLUS_INCLUDE_PATH" - "OBJC_INCLUDE_PATH" - "OBJCPLUS_INCLUDE_PATH" - "LIBRARY_PATH")) + (and=> + (getenv var) + (lambda (value) + (let* ((path (search-path-as-string->list value)) + (native-path (list->search-path-as-string + (remove cross? path) ":"))) + (setenv var native-path))))) + (cons "LIBRARY_PATH" ',%gcc-include-paths)) #t)) - ,phases) - phases))))))) + ,phases)) + (else phases)))))))) (define (cross-gcc-patches target) "Return GCC patches needed for TARGET." (cond ((string-prefix? "xtensa-" target) ;; Patch by Qualcomm needed to build the ath9k-htc firmware. (search-patches "ath9k-htc-firmware-gcc.patch")) + ((target-mingw? target) + (search-patches "gcc-4.9.3-mingw-gthr-default.patch")) (else '()))) +(define (cross-gcc-snippet target) + "Return GCC snippet needed for TARGET." + (cond ((target-mingw? target) + '(copy-recursively "libstdc++-v3/config/os/mingw32-w64" + "libstdc++-v3/config/os/newlib")) + (else #f))) + (define* (cross-gcc target #:optional (xbinutils (cross-binutils target)) libc) "Return a cross-compiler for TARGET, where TARGET is a GNU triplet. Use @@ -234,7 +325,10 @@ GCC that does not target a libc; otherwise, target that libc." (append (origin-patches (package-source %xgcc)) (cons (search-patch "gcc-cross-environment-variables.patch") - (cross-gcc-patches target)))))) + (cross-gcc-patches target)))) + (modules '((guix build utils))) + (snippet + (cross-gcc-snippet target)))) ;; For simplicity, use a single output. Otherwise libgcc_s & co. are not ;; found by default, etc. @@ -244,6 +338,8 @@ GCC that does not target a libc; otherwise, target that libc." `(#:implicit-inputs? #f #:modules ((guix build gnu-build-system) (guix build utils) + (ice-9 ftw) + (ice-9 match) (ice-9 regex) (srfi srfi-1) (srfi srfi-26)) @@ -264,34 +360,32 @@ GCC that does not target a libc; otherwise, target that libc." ;; Remaining inputs. ,@(let ((inputs (append (package-inputs %xgcc) (alist-delete "libc" (%final-inputs))))) - (if libc - `(("libc" ,libc) - ("xkernel-headers" ;the target headers - ,@(assoc-ref (package-propagated-inputs libc) - "kernel-headers")) - ,@inputs) - inputs)))) + (cond + ((target-mingw? target) + (if libc + `(("libc" ,mingw-w64) + ,@inputs) + `(("mingw-source" ,(package-source mingw-w64)) + ,@inputs))) + (libc + `(("libc" ,libc) + ("xkernel-headers" ;the target headers + ,@(assoc-ref (package-propagated-inputs libc) + "kernel-headers")) + ,@inputs)) + (else inputs))))) (inputs '()) ;; Only search target inputs, not host inputs. - ;; Note: See for why not 'CPATH'. - (search-paths - (list (search-path-specification - (variable "CROSS_C_INCLUDE_PATH") - (files '("include"))) - (search-path-specification - (variable "CROSS_CPLUS_INCLUDE_PATH") - (files '("include"))) - (search-path-specification - (variable "CROSS_OBJC_INCLUDE_PATH") - (files '("include"))) - (search-path-specification - (variable "CROSS_OBJCPLUS_INCLUDE_PATH") - (files '("include"))) - (search-path-specification - (variable "CROSS_LIBRARY_PATH") - (files '("lib" "lib64"))))) + (search-paths (cons (search-path-specification + (variable "CROSS_LIBRARY_PATH") + (files '("lib" "lib64"))) + (map (lambda (variable) + (search-path-specification + (variable variable) + (files '("include")))) + %gcc-cross-include-paths))) (native-search-paths '()))) (define* (cross-kernel-headers target @@ -464,61 +558,72 @@ XBINUTILS and the cross tool chain." (_ glibc/linux))) ;; Use (cross-libc-for-target ...) to determine the correct libc to use. - (let ((libc (cross-libc-for-target target))) - (package (inherit libc) - (name (string-append "glibc-cross-" target)) - (arguments - (substitute-keyword-arguments - `(;; Disable stripping (see above.) - #:strip-binaries? #f - - ;; This package is used as a target input, but it should not have - ;; the usual cross-compilation inputs since that would include - ;; itself. - #:implicit-cross-inputs? #f - ;; We need SRFI 26. - #:modules ((guix build gnu-build-system) - (guix build utils) - (srfi srfi-26)) - - ,@(package-arguments libc)) - ((#:configure-flags flags) - `(cons ,(string-append "--host=" target) - ,flags)) - ((#:phases phases) - `(alist-cons-before - 'configure 'set-cross-kernel-headers-path - (lambda* (#:key inputs #:allow-other-keys) - (let* ((kernel (assoc-ref inputs "kernel-headers")) - (cpath (string-append kernel "/include"))) - (for-each (cut setenv <> cpath) - '("CROSS_C_INCLUDE_PATH" - "CROSS_CPLUS_INCLUDE_PATH" - "CROSS_OBJC_INCLUDE_PATH" - "CROSS_OBJCPLUS_INCLUDE_PATH")) - (setenv "CROSS_LIBRARY_PATH" - (string-append kernel "/lib")) ;for Hurd's libihash - #t)) - ,phases)))) - - ;; Shadow the native "kernel-headers" because glibc's recipe expects the - ;; "kernel-headers" input to point to the right thing. - (propagated-inputs `(("kernel-headers" ,xheaders))) - - ;; FIXME: 'static-bash' should really be an input, not a native input, but - ;; to do that will require building an intermediate cross libc. - (inputs '()) - - (native-inputs `(("cross-gcc" ,xgcc) - ("cross-binutils" ,xbinutils) - ,@(if (string-match (or "i586-pc-gnu" "i586-gnu") target) - `(("cross-mig" - ,@(assoc-ref (package-native-inputs xheaders) - "cross-mig"))) - '()) - ,@(package-inputs libc) ;FIXME: static-bash - ,@(package-native-inputs libc)))))) + (if (cross-newlib? target) + (native-libc target) + (let ((libc (cross-libc-for-target target))) + (package (inherit libc) + (name (string-append "glibc-cross-" target)) + (arguments + (substitute-keyword-arguments + `(;; Disable stripping (see above.) + #:strip-binaries? #f + + ;; This package is used as a target input, but it should not have + ;; the usual cross-compilation inputs since that would include + ;; itself. + #:implicit-cross-inputs? #f + + ;; We need SRFI 26. + #:modules ((guix build gnu-build-system) + (guix build utils) + (srfi srfi-26)) + + ,@(package-arguments libc)) + ((#:configure-flags flags) + `(cons ,(string-append "--host=" target) + ,flags)) + ((#:phases phases) + `(alist-cons-before + 'configure 'set-cross-kernel-headers-path + (lambda* (#:key inputs #:allow-other-keys) + (let* ((kernel (assoc-ref inputs "kernel-headers")) + (cpath (string-append kernel "/include"))) + (for-each (cut setenv <> cpath) + '("CROSS_C_INCLUDE_PATH" + "CROSS_CPLUS_INCLUDE_PATH" + "CROSS_OBJC_INCLUDE_PATH" + "CROSS_OBJCPLUS_INCLUDE_PATH")) + (setenv "CROSS_LIBRARY_PATH" + (string-append kernel "/lib")) ;for Hurd's libihash + #t)) + ,phases)))) + + ;; Shadow the native "kernel-headers" because glibc's recipe expects the + ;; "kernel-headers" input to point to the right thing. + (propagated-inputs `(("kernel-headers" ,xheaders))) + + ;; FIXME: 'static-bash' should really be an input, not a native input, but + ;; to do that will require building an intermediate cross libc. + (inputs '()) + + (native-inputs `(("cross-gcc" ,xgcc) + ("cross-binutils" ,xbinutils) + ,@(if (string-match (or "i586-pc-gnu" "i586-gnu") target) + `(("cross-mig" + ,@(assoc-ref (package-native-inputs xheaders) + "cross-mig"))) + '()) + ,@(package-inputs libc) ;FIXME: static-bash + ,@(package-native-inputs libc))))))) + +(define (native-libc target) + (if (target-mingw? target) + mingw-w64 + glibc)) + +(define (cross-newlib? target) + (not (eq? (native-libc target) glibc))) ;;; Concrete cross tool chains are instantiated like this: diff --git a/guix/utils.scm b/guix/utils.scm index 65a2baa0a2..06f49daca8 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -70,6 +70,7 @@ %current-system %current-target-system package-name->name+version + target-mingw? version-compare version>? version>=? @@ -508,6 +509,10 @@ returned. Both parts must not contain any '@'." (idx (values (substring spec 0 idx) (substring spec (1+ idx)))))) +(define* (target-mingw? #:optional (target (%current-target-system))) + (and target + (string-suffix? "-mingw32" target))) + (define version-compare (let ((strverscmp (let ((sym (or (dynamic-func "strverscmp" (dynamic-link)) -- cgit v1.2.3 From f13f60cb2620433280ccb2132376b7c6d3dbc06f Mon Sep 17 00:00:00 2001 From: Manolis Ragkousis Date: Wed, 30 Nov 2016 16:49:48 +0200 Subject: gnu: make-bootstrap: Produce the correct %glibc-bootstrap-tarball for Hurd systems. * gnu/packages/make-bootstrap.scm (%glibc-bootstrap-tarball): Make it a procedure. (%glibc-stripped): Make it a procedure and move the kernel specific part from here to ... * guix/build/make-bootstrap.scm (make-stripped-libc): ... here. New file. * Makefile.am (MODULES): Add it. --- Makefile.am | 1 + gnu/packages/make-bootstrap.scm | 67 +++++++++++--------------------- guix/build/make-bootstrap.scm | 84 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 108 insertions(+), 44 deletions(-) create mode 100644 guix/build/make-bootstrap.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 9d62f48024..0e3ddac146 100644 --- a/Makefile.am +++ b/Makefile.am @@ -112,6 +112,7 @@ MODULES = \ guix/build/graft.scm \ guix/build/bournish.scm \ guix/build/qt-utils.scm \ + guix/build/make-bootstrap.scm \ guix/search-paths.scm \ guix/packages.scm \ guix/import/utils.scm \ diff --git a/gnu/packages/make-bootstrap.scm b/gnu/packages/make-bootstrap.scm index f31db6aaef..44a7fd3a16 100644 --- a/gnu/packages/make-bootstrap.scm +++ b/gnu/packages/make-bootstrap.scm @@ -32,6 +32,7 @@ #:use-module (gnu packages guile) #:use-module (gnu packages bdw-gc) #:use-module (gnu packages linux) + #:use-module (gnu packages hurd) #:use-module (gnu packages multiprecision) #:use-module (ice-9 match) #:use-module (srfi srfi-1) @@ -332,61 +333,39 @@ for `sh' in $PATH, and without nscd, and with static NSS modules." #t)))) (inputs `(("binutils" ,%binutils-static))))) -(define %glibc-stripped +(define (%glibc-stripped) ;; GNU libc's essential shared libraries, dynamic linker, and headers, ;; with all references to store directories stripped. As a result, ;; libc.so is unusable and need to be patched for proper relocation. + (define (hurd-triplet? triplet) + (and (string-suffix? "-gnu" triplet) + (not (string-contains triplet "linux")))) + (let ((glibc (glibc-for-bootstrap))) (package (inherit glibc) (name "glibc-stripped") (build-system trivial-build-system) (arguments - `(#:modules ((guix build utils)) + `(#:modules ((guix build utils) + (guix build make-bootstrap)) #:builder (begin - (use-modules (guix build utils)) - - (setvbuf (current-output-port) _IOLBF) - (let* ((out (assoc-ref %outputs "out")) - (libdir (string-append out "/lib")) - (incdir (string-append out "/include")) - (libc (assoc-ref %build-inputs "libc")) - (linux (assoc-ref %build-inputs "kernel-headers"))) - (mkdir-p libdir) - (for-each (lambda (file) - (let ((target (string-append libdir "/" - (basename file)))) - (copy-file file target) - (remove-store-references target))) - (find-files (string-append libc "/lib") - "^(crt.*|ld.*|lib(c|m|dl|rt|pthread|nsl|util).*\\.so(\\..*)?|libc_nonshared\\.a)$")) - - (copy-recursively (string-append libc "/include") incdir) - - ;; Copy some of the Linux-Libre headers that glibc headers - ;; refer to. - (mkdir (string-append incdir "/linux")) - (for-each (lambda (file) - (copy-file (string-append linux "/include/linux/" file) - (string-append incdir "/linux/" - (basename file)))) - '("limits.h" "errno.h" "socket.h" "kernel.h" - "sysctl.h" "param.h" "ioctl.h" "types.h" - "posix_types.h" "stddef.h")) - - (copy-recursively (string-append linux "/include/asm") - (string-append incdir "/asm")) - (copy-recursively (string-append linux "/include/asm-generic") - (string-append incdir "/asm-generic")) - - #t)))) - (inputs `(("libc" ,(let ((target (%current-target-system))) + (use-modules (guix build make-bootstrap)) + (make-stripped-libc (assoc-ref %outputs "out") + (assoc-ref %build-inputs "libc") + (assoc-ref %build-inputs "kernel-headers"))))) + (inputs `(("kernel-headers" + ,(if (or (and (%current-target-system) + (hurd-triplet? (%current-target-system))) + (string-suffix? "-hurd" (%current-system))) + gnumach-headers + linux-libre-headers)) + ("libc" ,(let ((target (%current-target-system))) (if target (glibc-for-bootstrap (parameterize ((%current-target-system #f)) (cross-libc target))) - glibc))) - ("kernel-headers" ,linux-libre-headers))) + glibc))))) ;; Only one output. (outputs '("out"))))) @@ -647,9 +626,9 @@ for `sh' in $PATH, and without nscd, and with static NSS modules." ;; A tarball with the statically-linked Binutils programs. (tarball-package %binutils-static-stripped)) -(define %glibc-bootstrap-tarball +(define (%glibc-bootstrap-tarball) ;; A tarball with GNU libc's shared libraries, dynamic linker, and headers. - (tarball-package %glibc-stripped)) + (tarball-package (%glibc-stripped))) (define %gcc-bootstrap-tarball ;; A tarball with a dynamic-linked GCC and its headers. @@ -689,7 +668,7 @@ for `sh' in $PATH, and without nscd, and with static NSS modules." (inputs `(("guile-tarball" ,%guile-bootstrap-tarball) ("gcc-tarball" ,%gcc-bootstrap-tarball) ("binutils-tarball" ,%binutils-bootstrap-tarball) - ("glibc-tarball" ,%glibc-bootstrap-tarball) + ("glibc-tarball" ,(%glibc-bootstrap-tarball)) ("coreutils&co-tarball" ,%bootstrap-binaries-tarball))) (synopsis "Tarballs containing all the bootstrap binaries") (description synopsis) diff --git a/guix/build/make-bootstrap.scm b/guix/build/make-bootstrap.scm new file mode 100644 index 0000000000..bc4c0e3d5f --- /dev/null +++ b/guix/build/make-bootstrap.scm @@ -0,0 +1,84 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Manolis Fragkiskos Ragkousis +;;; Copyright © 2015 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 build make-bootstrap) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (guix build utils) + #:export (make-stripped-libc)) + +;; Commentary: +;; +;; This module provides facilities to build the bootstrap binaries. +;; +;; Code: + +(define (make-stripped-libc output libc kernel-headers) + "Copy to OUTPUT the subset of LIBC and KERNEL-HEADERS that is needed +when producing a bootstrap libc." + + (define (copy-mach-headers output kernel-headers) + (let* ((incdir (string-append output "/include"))) + (copy-recursively (string-append libc "/include") incdir) + + (copy-recursively (string-append kernel-headers "/include/mach") + (string-append incdir "/mach")) + #t)) + + (define (copy-linux-headers output kernel-headers) + (let* ((incdir (string-append output "/include"))) + (copy-recursively (string-append libc "/include") incdir) + + ;; Copy some of the Linux-Libre headers that glibc headers + ;; refer to. + (mkdir (string-append incdir "/linux")) + (for-each (lambda (file) + (install-file (string-append kernel-headers "/include/linux/" file) + (string-append incdir "/linux"))) + '("limits.h" "errno.h" "socket.h" "kernel.h" + "sysctl.h" "param.h" "ioctl.h" "types.h" + "posix_types.h" "stddef.h")) + + (copy-recursively (string-append kernel-headers "/include/asm") + (string-append incdir "/asm")) + (copy-recursively (string-append kernel-headers "/include/asm-generic") + (string-append incdir "/asm-generic")) + #t)) + + (define %libc-object-files-rx "^(crt.*|ld.*|lib(c|m|dl|rt|pthread|nsl|\ +util).*\\.so(\\..*)?|lib(machuser|hurduser).so.*|libc(rt|)_nonshared\\.a)$") + + (setvbuf (current-output-port) _IOLBF) + (let* ((libdir (string-append output "/lib"))) + (mkdir-p libdir) + (for-each (lambda (file) + (let ((target (string-append libdir "/" + (basename file)))) + (copy-file file target) + (remove-store-references target))) + (find-files (string-append libc "/lib") %libc-object-files-rx)) + #t) + + (if (directory-exists? (string-append kernel-headers "/include/mach")) + (copy-mach-headers output kernel-headers) + (copy-linux-headers output kernel-headers))) + + -- cgit v1.2.3 From 13d5e8dae5f1282eac630dea428c5fe3dc073fb4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 8 Dec 2016 14:03:33 +0100 Subject: store: 'open-connection' no longer raises '&nar-error' for protocol errors. * guix/store.scm (open-connection): Guard body against 'nar-error?' and re-raise as '&nix-connection-error'. * tests/store.scm ("connection handshake error"): New test. --- guix/store.scm | 53 ++++++++++++++++++++++++++++++----------------------- tests/store.scm | 9 +++++++++ 2 files changed, 39 insertions(+), 23 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index a669011f3a..49549d0771 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -374,29 +374,36 @@ space on the file system so that the garbage collector can still operate, should the disk become full. When CPU-AFFINITY is true, it must be an integer corresponding to an OS-level CPU number to which the daemon's worker process for this connection will be pinned. Return a server object." - (let ((port (or port (open-unix-domain-socket file)))) - (write-int %worker-magic-1 port) - (let ((r (read-int port))) - (and (eqv? r %worker-magic-2) - (let ((v (read-int port))) - (and (eqv? (protocol-major %protocol-version) - (protocol-major v)) - (begin - (write-int %protocol-version port) - (when (>= (protocol-minor v) 14) - (write-int (if cpu-affinity 1 0) port) - (when cpu-affinity - (write-int cpu-affinity port))) - (when (>= (protocol-minor v) 11) - (write-int (if reserve-space? 1 0) port)) - (let ((conn (%make-nix-server port - (protocol-major v) - (protocol-minor v) - (make-hash-table 100) - (make-hash-table 100)))) - (let loop ((done? (process-stderr conn))) - (or done? (process-stderr conn))) - conn)))))))) + (guard (c ((nar-error? c) + ;; One of the 'write-' or 'read-' calls below failed, but this is + ;; really a connection error. + (raise (condition + (&nix-connection-error (file (or port file)) + (errno EPROTO)) + (&message (message "build daemon handshake failed")))))) + (let ((port (or port (open-unix-domain-socket file)))) + (write-int %worker-magic-1 port) + (let ((r (read-int port))) + (and (eqv? r %worker-magic-2) + (let ((v (read-int port))) + (and (eqv? (protocol-major %protocol-version) + (protocol-major v)) + (begin + (write-int %protocol-version port) + (when (>= (protocol-minor v) 14) + (write-int (if cpu-affinity 1 0) port) + (when cpu-affinity + (write-int cpu-affinity port))) + (when (>= (protocol-minor v) 11) + (write-int (if reserve-space? 1 0) port)) + (let ((conn (%make-nix-server port + (protocol-major v) + (protocol-minor v) + (make-hash-table 100) + (make-hash-table 100)))) + (let loop ((done? (process-stderr conn))) + (or done? (process-stderr conn))) + conn))))))))) (define (close-connection server) "Close the connection to SERVER." diff --git a/tests/store.scm b/tests/store.scm index 38b8efce96..123ea8a787 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -48,6 +48,15 @@ (test-begin "store") +(test-equal "connection handshake error" + EPROTO + (let ((port (%make-void-port "rw"))) + (guard (c ((nix-connection-error? c) + (and (eq? port (nix-connection-error-file c)) + (nix-connection-error-code c)))) + (open-connection #f #:port port) + 'broken))) + (test-equal "store-path-hash-part" "283gqy39v3g9dxjy26rynl0zls82fmcg" (store-path-hash-part -- cgit v1.2.3