From 1bcc87bb685b7985512add221f10e4cb58b5f6f7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 29 Oct 2016 01:16:24 +0200 Subject: guix download: Add '-o' option. * guix/scripts/download.scm (download-to-file, download-to-store*): New procedures. (%default-options): Add 'download-proc'. (show-help): Adjust description and document '-o'. (%options): Add '-o'. (guix-download): Remove 'store' variable. Add 'fetch' and define 'path' to as its result. * tests/guix-download.sh: Add test. --- tests/guix-download.sh | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/tests/guix-download.sh b/tests/guix-download.sh index 6283772c48..ebc853c7fa 100644 --- a/tests/guix-download.sh +++ b/tests/guix-download.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2015 Ludovic Courtès +# Copyright © 2012, 2015, 2016 Ludovic Courtès # # This file is part of GNU Guix. # @@ -35,6 +35,13 @@ then false; else true; fi # This one should succeed. guix download "file://$abs_top_srcdir/README" +# This one too, even if it cannot talk to the daemon. +output="t-download-$$" +trap 'rm -f "$output"' EXIT +GUIX_DAEMON_SOCKET="/nowhere" guix download -o "$output" \ + "file://$abs_top_srcdir/README" +cmp "$output" "$abs_top_srcdir/README" + # This one should fail. if guix download "file:///does-not-exist" "file://$abs_top_srcdir/README" then false; else true; fi -- cgit v1.2.3 From 17ab08bcf0ae27ec6a1f07766080ebfbea8837d9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 16 Nov 2016 16:34:17 +0100 Subject: tests: Move HTTP server to (guix tests http). * tests/lint.scm (%http-server-port, %local-url) (%http-server-socket, http-write, %http-server-lock) (%http-server-ready, http-open, stub-http-server) (call-with-http-server, with-http-server): Move to (guix tests http). Adjust tests for %HTTP-SERVER-SOCKET as a promise and %LOCAL-URL as a parameter. * guix/tests/http.scm: New file. * Makefile.am (dist_noinst_DATA): Add it. (GOBJECTS): Add .go files for all of $(dist_noinst_DATA). (make-go): Depend on $(dist_noinst_DATA). --- Makefile.am | 8 ++-- guix/tests/http.scm | 120 ++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/lint.scm | 114 ++++++++----------------------------------------- 3 files changed, 141 insertions(+), 101 deletions(-) create mode 100644 guix/tests/http.scm (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index 908eaf6ec0..5d3639747f 100644 --- a/Makefile.am +++ b/Makefile.am @@ -171,8 +171,8 @@ MODULES += \ endif BUILD_DAEMON_OFFLOAD -# Internal module with test suite support. -dist_noinst_DATA = guix/tests.scm +# Internal modules with test suite support. +dist_noinst_DATA = guix/tests.scm guix/tests/http.scm # Linux-Libre configurations. KCONFIGS = \ @@ -189,7 +189,7 @@ EXAMPLES = \ gnu/system/examples/desktop.tmpl \ gnu/system/examples/lightweight-desktop.tmpl -GOBJECTS = $(MODULES:%.scm=%.go) guix/config.go guix/tests.go +GOBJECTS = $(MODULES:%.scm=%.go) guix/config.go $(dist_noinst_DATA:%.scm=%.go) nobase_dist_guilemodule_DATA = \ $(MODULES) $(KCONFIGS) $(EXAMPLES) \ @@ -407,7 +407,7 @@ CLEANFILES = \ # the whole thing. Likewise, set 'XDG_CACHE_HOME' to avoid loading possibly # stale files from ~/.cache/guile/ccache. %.go: make-go ; @: -make-go: $(MODULES) guix/config.scm guix/tests.scm +make-go: $(MODULES) guix/config.scm $(dist_noinst_DATA) $(AM_V_at)echo "Compiling Scheme modules..." ; \ unset GUILE_LOAD_COMPILED_PATH ; \ XDG_CACHE_HOME=/nowhere \ diff --git a/guix/tests/http.scm b/guix/tests/http.scm new file mode 100644 index 0000000000..fe1e120c5d --- /dev/null +++ b/guix/tests/http.scm @@ -0,0 +1,120 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014, 2015, 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 tests http) + #:use-module (ice-9 threads) + #:use-module (web server) + #:use-module (web server http) + #:use-module (web response) + #:use-module (srfi srfi-39) + #:export (with-http-server + call-with-http-server + %http-server-port + %http-server-socket + %local-url)) + +;;; Commentary: +;;; +;;; Code to spawn a Web server for testing purposes. +;;; +;;; Code: + +(define %http-server-port + ;; TCP port to use for the stub HTTP server. + (make-parameter 9999)) + +(define (%local-url) + ;; URL to use for 'home-page' tests. + (string-append "http://localhost:" (number->string (%http-server-port)) + "/foo/bar")) + +(define %http-server-socket + ;; Listening socket for the web server. It is useful to export it so that + ;; tests can check whether we succeeded opening the socket and tests skip if + ;; needed. + (delay + (catch 'system-error + (lambda () + (let ((sock (socket PF_INET SOCK_STREAM 0))) + (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) + (bind sock + (make-socket-address AF_INET INADDR_LOOPBACK + (%http-server-port))) + sock)) + (lambda args + (let ((err (system-error-errno args))) + (format (current-error-port) + "warning: cannot run Web server for tests: ~a~%" + (strerror err)) + #f))))) + +(define (http-write server client response body) + "Write RESPONSE." + (let* ((response (write-response response client)) + (port (response-port response))) + (cond + ((not body)) ;pass + (else + (write-response-body response body))) + (close-port port) + (quit #t) ;exit the server thread + (values))) + +;; Mutex and condition variable to synchronize with the HTTP server. +(define %http-server-lock (make-mutex)) +(define %http-server-ready (make-condition-variable)) + +(define (http-open . args) + "Start listening for HTTP requests and signal %HTTP-SERVER-READY." + (with-mutex %http-server-lock + (let ((result (apply (@@ (web server http) http-open) args))) + (signal-condition-variable %http-server-ready) + result))) + +(define-server-impl stub-http-server + ;; Stripped-down version of Guile's built-in HTTP server. + http-open + (@@ (web server http) http-read) + http-write + (@@ (web server http) http-close)) + +(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") + data)) + + (catch 'quit + (lambda () + (run-server handle stub-http-server + `(#:socket ,(force %http-server-socket)))) + (const #t))) + + (with-mutex %http-server-lock + (let ((server (make-thread server-body))) + (wait-condition-variable %http-server-ready %http-server-lock) + ;; Normally SERVER exits automatically once it has received a request. + (thunk)))) + +(define-syntax-rule (with-http-server code data body ...) + (call-with-http-server code data (lambda () body ...))) + +;;; http.scm ends here diff --git a/tests/lint.scm b/tests/lint.scm index fa2d19b2a6..cf1b95ee69 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -24,6 +24,7 @@ (define-module (test-lint) #:use-module (guix tests) + #:use-module (guix tests http) #:use-module (guix download) #:use-module (guix git-download) #:use-module (guix build-system gnu) @@ -33,101 +34,20 @@ #:use-module (gnu packages) #:use-module (gnu packages glib) #:use-module (gnu packages pkg-config) - #:use-module (web server) - #:use-module (web server http) - #:use-module (web response) #:use-module (ice-9 match) - #:use-module (ice-9 threads) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-64)) ;; Test the linter. -(define %http-server-port - ;; TCP port to use for the stub HTTP server. - 9999) - -(define %local-url - ;; URL to use for 'home-page' tests. - (string-append "http://localhost:" (number->string %http-server-port) - "/foo/bar")) +;; Avoid collisions with other tests. +(%http-server-port 9999) (define %null-sha256 ;; SHA256 of the empty string. (base32 "0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73")) -(define %http-server-socket - ;; Socket used by the Web server. - (catch 'system-error - (lambda () - (let ((sock (socket PF_INET SOCK_STREAM 0))) - (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) - (bind sock - (make-socket-address AF_INET INADDR_LOOPBACK - %http-server-port)) - sock)) - (lambda args - (let ((err (system-error-errno args))) - (format (current-error-port) - "warning: cannot run Web server for tests: ~a~%" - (strerror err)) - #f)))) - -(define (http-write server client response body) - "Write RESPONSE." - (let* ((response (write-response response client)) - (port (response-port response))) - (cond - ((not body)) ;pass - (else - (write-response-body response body))) - (close-port port) - (quit #t) ;exit the server thread - (values))) - -;; Mutex and condition variable to synchronize with the HTTP server. -(define %http-server-lock (make-mutex)) -(define %http-server-ready (make-condition-variable)) - -(define (http-open . args) - "Start listening for HTTP requests and signal %HTTP-SERVER-READY." - (with-mutex %http-server-lock - (let ((result (apply (@@ (web server http) http-open) args))) - (signal-condition-variable %http-server-ready) - result))) - -(define-server-impl stub-http-server - ;; Stripped-down version of Guile's built-in HTTP server. - http-open - (@@ (web server http) http-read) - http-write - (@@ (web server http) http-close)) - -(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") - data)) - - (catch 'quit - (lambda () - (run-server handle stub-http-server - `(#:socket ,%http-server-socket))) - (const #t))) - - (with-mutex %http-server-lock - (let ((server (make-thread server-body))) - (wait-condition-variable %http-server-ready %http-server-lock) - ;; Normally SERVER exits automatically once it has received a request. - (thunk)))) - -(define-syntax-rule (with-http-server code data body ...) - (call-with-http-server code data (lambda () body ...))) - (define %long-string (make-string 2000 #\a)) @@ -423,28 +343,28 @@ string) on HTTP requests." (check-home-page pkg))) "domain not found"))) -(test-skip (if %http-server-socket 0 1)) +(test-skip (if (force %http-server-socket) 0 1)) (test-assert "home-page: Connection refused" (->bool (string-contains (with-warnings (let ((pkg (package (inherit (dummy-package "x")) - (home-page %local-url)))) + (home-page (%local-url))))) (check-home-page pkg))) "Connection refused"))) -(test-skip (if %http-server-socket 0 1)) +(test-skip (if (force %http-server-socket) 0 1)) (test-equal "home-page: 200" "" (with-warnings (with-http-server 200 %long-string (let ((pkg (package (inherit (dummy-package "x")) - (home-page %local-url)))) + (home-page (%local-url))))) (check-home-page pkg))))) -(test-skip (if %http-server-socket 0 1)) +(test-skip (if (force %http-server-socket) 0 1)) (test-assert "home-page: 200 but short length" (->bool (string-contains @@ -452,11 +372,11 @@ string) on HTTP requests." (with-http-server 200 "This is too small." (let ((pkg (package (inherit (dummy-package "x")) - (home-page %local-url)))) + (home-page (%local-url))))) (check-home-page pkg)))) "suspiciously small"))) -(test-skip (if %http-server-socket 0 1)) +(test-skip (if (force %http-server-socket) 0 1)) (test-assert "home-page: 404" (->bool (string-contains @@ -464,7 +384,7 @@ string) on HTTP requests." (with-http-server 404 %long-string (let ((pkg (package (inherit (dummy-package "x")) - (home-page %local-url)))) + (home-page (%local-url))))) (check-home-page pkg)))) "not reachable: 404"))) @@ -545,7 +465,7 @@ string) on HTTP requests." (check-source-file-name pkg))) "file name should contain the package name")))) -(test-skip (if %http-server-socket 0 1)) +(test-skip (if (force %http-server-socket) 0 1)) (test-equal "source: 200" "" (with-warnings @@ -554,11 +474,11 @@ string) on HTTP requests." (inherit (dummy-package "x")) (source (origin (method url-fetch) - (uri %local-url) + (uri (%local-url)) (sha256 %null-sha256)))))) (check-source pkg))))) -(test-skip (if %http-server-socket 0 1)) +(test-skip (if (force %http-server-socket) 0 1)) (test-assert "source: 200 but short length" (->bool (string-contains @@ -568,12 +488,12 @@ string) on HTTP requests." (inherit (dummy-package "x")) (source (origin (method url-fetch) - (uri %local-url) + (uri (%local-url)) (sha256 %null-sha256)))))) (check-source pkg)))) "suspiciously small"))) -(test-skip (if %http-server-socket 0 1)) +(test-skip (if (force %http-server-socket) 0 1)) (test-assert "source: 404" (->bool (string-contains @@ -583,7 +503,7 @@ string) on HTTP requests." (inherit (dummy-package "x")) (source (origin (method url-fetch) - (uri %local-url) + (uri (%local-url)) (sha256 %null-sha256)))))) (check-source pkg)))) "not reachable: 404"))) -- cgit v1.2.3 From 94d92c7796a3dd50c27d532315f7d497ac99f08e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 20 Jul 2015 04:30:16 +0200 Subject: daemon: Add "builtin:download" derivation builder. This ensures that 1) the derivation doesn't change when Guix changes; 2) the derivation closure doesn't contain Guix and its dependencies; 3) we don't have to rely on ugly chroot hacks. Adapted from Nix commit 0a2bee307b20411f5b0dda0c662b1f9bb9e0e131. * nix/libstore/build.cc (DerivationGoal::runChild): Add special case for 'isBuiltin(drv)'. Disable chroot when 'isBuiltin(drv)'. * nix/libstore/builtins.cc, nix/libstore/builtins.hh, nix/scripts/download.in, guix/scripts/perform-download.scm: New files. * guix/ui.scm (show-guix-help)[internal?]: Add 'perform-download'. * nix/local.mk (libstore_a_SOURCES): Add builtins.cc. (libstore_headers): Add builtins.hh. (nodist_pkglibexec_SCRIPTS): Add 'scripts/download'. * config-daemon.ac: Emit 'scripts/download'. * Makefile.am (MODULES): Add 'guix/scripts/perform-download.scm'. * tests/derivations.scm ("unknown built-in builder") ("'download' built-in builder") ("'download' built-in builder, invalid hash") ("'download' built-in builder, not found") ("'download' built-in builder, not fixed-output"): New tests. Co-authored-by: Eelco Dolstra --- .gitignore | 1 + Makefile.am | 1 + config-daemon.ac | 2 + guix/scripts/perform-download.scm | 113 ++++++++++++++++++++++++++++++++++++++ guix/ui.scm | 3 +- nix/libstore/build.cc | 36 +++++++++--- nix/libstore/builtins.cc | 69 +++++++++++++++++++++++ nix/libstore/builtins.hh | 41 ++++++++++++++ nix/local.mk | 5 +- nix/scripts/download.in | 11 ++++ tests/derivations.scm | 70 +++++++++++++++++++++++ 11 files changed, 343 insertions(+), 9 deletions(-) create mode 100644 guix/scripts/perform-download.scm create mode 100644 nix/libstore/builtins.cc create mode 100644 nix/libstore/builtins.hh create mode 100644 nix/scripts/download.in (limited to 'tests') diff --git a/.gitignore b/.gitignore index 6e892ca687..329d489713 100644 --- a/.gitignore +++ b/.gitignore @@ -125,3 +125,4 @@ config.cache stamp-h[0-9] tmp /doc/os-config-lightweight-desktop.texi +/nix/scripts/download diff --git a/Makefile.am b/Makefile.am index 5d3639747f..9d62f48024 100644 --- a/Makefile.am +++ b/Makefile.am @@ -123,6 +123,7 @@ MODULES = \ guix/import/elpa.scm \ guix/scripts.scm \ guix/scripts/download.scm \ + guix/scripts/perform-download.scm \ guix/scripts/build.scm \ guix/scripts/archive.scm \ guix/scripts/import.scm \ diff --git a/config-daemon.ac b/config-daemon.ac index f66f31269d..8a3e6d8b60 100644 --- a/config-daemon.ac +++ b/config-daemon.ac @@ -144,6 +144,8 @@ if test "x$guix_build_daemon" = "xyes"; then AC_CONFIG_FILES([nix/scripts/list-runtime-roots], [chmod +x nix/scripts/list-runtime-roots]) + AC_CONFIG_FILES([nix/scripts/download], + [chmod +x nix/scripts/download]) AC_CONFIG_FILES([nix/scripts/substitute], [chmod +x nix/scripts/substitute]) AC_CONFIG_FILES([nix/scripts/guix-authenticate], diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm new file mode 100644 index 0000000000..0d2e7089aa --- /dev/null +++ b/guix/scripts/perform-download.scm @@ -0,0 +1,113 @@ +;;; 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 scripts perform-download) + #:use-module (guix ui) + #:use-module (guix derivations) + #:use-module ((guix store) #:select (derivation-path?)) + #:use-module (guix build download) + #:use-module (ice-9 match) + #:export (guix-perform-download)) + +;; This program is a helper for the daemon's 'download' built-in builder. + +(define-syntax derivation-let + (syntax-rules () + ((_ drv ((id name) rest ...) body ...) + (let ((id (assoc-ref (derivation-builder-environment-vars drv) + name))) + (derivation-let drv (rest ...) body ...))) + ((_ drv () body ...) + (begin body ...)))) + +(define %user-module + ;; Module in which content-address mirror procedures are evaluated. + (let ((module (make-fresh-user-module))) + (module-use! module (resolve-interface '(guix base32))) + module)) + +(define (perform-download drv) + "Perform the download described by DRV, a fixed-output derivation." + (derivation-let drv ((url "url") + (output "out") + (executable "executable") + (mirrors "mirrors") + (content-addressed-mirrors "content-addressed-mirrors")) + (unless url + (leave (_ "~a: missing URL~%") (derivation-file-name drv))) + + (let* ((url (call-with-input-string url read)) + (drv-output (assoc-ref (derivation-outputs drv) "out")) + (algo (derivation-output-hash-algo drv-output)) + (hash (derivation-output-hash drv-output))) + (unless (and algo hash) + (leave (_ "~a is not a fixed-output derivation~%") + (derivation-file-name drv))) + + ;; We're invoked by the daemon, which gives us write access to OUTPUT. + (when (url-fetch url output + #:mirrors (if mirrors + (call-with-input-file mirrors read) + '()) + #:content-addressed-mirrors + (if content-addressed-mirrors + (call-with-input-file content-addressed-mirrors + (lambda (port) + (eval (read port) %user-module))) + '()) + #:hashes `((,algo . ,hash)) + + ;; Since DRV's output hash is known, X.509 certificate + ;; validation is pointless. + #:verify-certificate? #f) + (when (and executable (string=? executable "1")) + (chmod output #o755)))))) + +(define (assert-low-privileges) + (when (zero? (getuid)) + (leave (_ "refusing to run with elevated privileges (UID ~a)~%") + (getuid)))) + +(define (guix-perform-download . args) + "Perform the download described by the given fixed-output derivation. + +This is an \"out-of-band\" download in that this code is executed directly by +the daemon and not explicitly described as an input of the derivation. This +allows us to sidestep bootstrapping problems, such downloading the source code +of GnuTLS over HTTPS, before we have built GnuTLS. See +." + (with-error-handling + (match args + (((? derivation-path? drv)) + ;; This program must be invoked by guix-daemon under an unprivileged + ;; UID to prevent things downloading from 'file:///etc/shadow' or + ;; arbitrary code execution via the content-addressed mirror + ;; procedures. (That means we exclude users who did not pass + ;; '--build-users-group'.) + (assert-low-privileges) + (perform-download (call-with-input-file drv read-derivation))) + (("--version") + (show-version-and-exit)) + (x + (leave (_ "fixed-output derivation name expected~%")))))) + +;; Local Variables: +;; eval: (put 'derivation-let 'scheme-indent-function 2) +;; End: + +;; perform-download.scm ends here diff --git a/guix/ui.scm b/guix/ui.scm index 9af8648211..b9fbbfd0e3 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1184,7 +1184,8 @@ optionally contain a version number and an output name, as in these examples: (define (show-guix-help) (define (internal? command) - (member command '("substitute" "authenticate" "offload"))) + (member command '("substitute" "authenticate" "offload" + "perform-download"))) (format #t (_ "Usage: guix COMMAND ARGS... Run COMMAND with ARGS.\n")) diff --git a/nix/libstore/build.cc b/nix/libstore/build.cc index ae78e65199..889ee3d2bd 100644 --- a/nix/libstore/build.cc +++ b/nix/libstore/build.cc @@ -8,6 +8,7 @@ #include "util.hh" #include "archive.hh" #include "affinity.hh" +#include "builtins.hh" #include #include @@ -2047,7 +2048,12 @@ void DerivationGoal::runChild() commonChildInit(builderOut); #if CHROOT_ENABLED - if (useChroot) { + /* Note: built-in builders are *not* running in a chroot environment + so that we can easily implement them in Guile without having it as + a derivation input (they are running under a separate build user, + though). */ + + if (useChroot && !isBuiltin(drv)) { /* Initialise the loopback interface. */ AutoCloseFD fd(socket(PF_INET, SOCK_DGRAM, IPPROTO_IP)); if (fd == -1) throw SysError("cannot open IP socket"); @@ -2255,6 +2261,28 @@ void DerivationGoal::runChild() throw SysError("setuid failed"); } + restoreSIGPIPE(); + + /* Indicate that we managed to set up the build environment. */ + writeFull(STDERR_FILENO, "\n"); + + /* Execute the program. This should not return. */ + if (isBuiltin(drv)) { + try { + logType = ltFlat; + + auto buildDrv = lookupBuiltinBuilder(drv.builder); + if (buildDrv != NULL) + buildDrv(drv, drvPath); + else + throw Error(format("unsupported builtin function '%1%'") % string(drv.builder, 8)); + _exit(0); + } catch (std::exception & e) { + writeFull(STDERR_FILENO, "error: " + string(e.what()) + "\n"); + _exit(1); + } + } + /* Fill in the arguments. */ Strings args; string builderBasename = baseNameOf(drv.builder); @@ -2262,12 +2290,6 @@ void DerivationGoal::runChild() foreach (Strings::iterator, i, drv.args) args.push_back(rewriteHashes(*i, rewritesToTmp)); - restoreSIGPIPE(); - - /* Indicate that we managed to set up the build environment. */ - writeFull(STDERR_FILENO, "\n"); - - /* Execute the program. This should not return. */ execve(drv.builder.c_str(), stringsToCharPtrs(args).data(), stringsToCharPtrs(envStrs).data()); throw SysError(format("executing `%1%'") % drv.builder); diff --git a/nix/libstore/builtins.cc b/nix/libstore/builtins.cc new file mode 100644 index 0000000000..605e44079a --- /dev/null +++ b/nix/libstore/builtins.cc @@ -0,0 +1,69 @@ +/* GNU Guix --- Functional package management for GNU + Copyright (C) 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 . */ + +#include +#include +#include + +#include + +namespace nix { + +static void builtinDownload(const Derivation &drv, + const std::string &drvPath) +{ + /* Invoke 'guix perform-download'. */ + Strings args; + args.push_back("perform-download"); + args.push_back(drvPath); + + /* Close all other file descriptors. */ + closeMostFDs(set()); + + const char *const argv[] = { "download", drvPath.c_str(), NULL }; + + /* XXX: Hack our way to use the 'download' script from 'LIBEXECDIR/guix' + or just 'LIBEXECDIR', depending on whether we're running uninstalled or + not. */ + const string subdir = getenv("GUIX_UNINSTALLED") != NULL + ? "" : "/guix"; + + const string program = settings.nixLibexecDir + subdir + "/download"; + execv(program.c_str(), (char *const *) argv); + + throw SysError(format("failed to run download program '%1%'") % program); +} + +static const std::map builtins = +{ + { "download", builtinDownload } +}; + +derivationBuilder lookupBuiltinBuilder(const std::string & name) +{ + if (name.substr(0, 8) == "builtin:") + { + auto realName = name.substr(8); + auto builder = builtins.find(realName); + return builder == builtins.end() ? NULL : builder->second; + } + else + return NULL; +} + +} diff --git a/nix/libstore/builtins.hh b/nix/libstore/builtins.hh new file mode 100644 index 0000000000..0c6db651ab --- /dev/null +++ b/nix/libstore/builtins.hh @@ -0,0 +1,41 @@ +/* GNU Guix --- Functional package management for GNU + Copyright (C) 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 . */ + +/* Interface to built-in derivation builders. */ + +#pragma once + +#include +#include +#include + +namespace nix { + + inline bool isBuiltin(const Derivation & drv) + { + return string(drv.builder, 0, 8) == "builtin:"; + } + + /* Build DRV, which lives at DRVPATH. */ + typedef void (*derivationBuilder) (const Derivation &drv, + const std::string &drvPath); + + /* Return the built-in builder called BUILDER, or NULL if none was + found. */ + derivationBuilder lookupBuiltinBuilder(const std::string &builder); +} diff --git a/nix/local.mk b/nix/local.mk index c666edd033..86ef769549 100644 --- a/nix/local.mk +++ b/nix/local.mk @@ -87,6 +87,7 @@ libstore_a_SOURCES = \ %D%/libstore/build.cc \ %D%/libstore/pathlocks.cc \ %D%/libstore/derivations.cc \ + %D%/libstore/builtins.cc \ %D%/libstore/sqlite.cc libstore_headers = \ @@ -98,6 +99,7 @@ libstore_headers = \ %D%/libstore/misc.hh \ %D%/libstore/local-store.hh \ %D%/libstore/sqlite.hh \ + %D%/libstore/builtins.hh \ %D%/libstore/store-api.hh libstore_a_CPPFLAGS = \ @@ -166,7 +168,8 @@ noinst_HEADERS = \ nodist_pkglibexec_SCRIPTS = \ %D%/scripts/list-runtime-roots \ - %D%/scripts/substitute + %D%/scripts/substitute \ + %D%/scripts/download if BUILD_DAEMON_OFFLOAD diff --git a/nix/scripts/download.in b/nix/scripts/download.in new file mode 100644 index 0000000000..4d7088a993 --- /dev/null +++ b/nix/scripts/download.in @@ -0,0 +1,11 @@ +#!@SHELL@ +# A shorthand for "guix perform-download", for use by the daemon. + +if test "x$GUIX_UNINSTALLED" = "x" +then + prefix="@prefix@" + exec_prefix="@exec_prefix@" + exec "@bindir@/guix" perform-download "$@" +else + exec guix perform-download "$@" +fi diff --git a/tests/derivations.scm b/tests/derivations.scm index d8553b223e..449fb47832 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -16,6 +16,8 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . +(unsetenv "http_proxy") + (define-module (test-derivations) #:use-module (guix derivations) #:use-module (guix grafts) @@ -24,6 +26,7 @@ #:use-module (guix hash) #:use-module (guix base32) #:use-module (guix tests) + #:use-module (guix tests http) #:use-module ((guix packages) #:select (package-derivation base32)) #:use-module ((guix build utils) #:select (executable-file?)) #:use-module ((gnu packages) #:select (search-bootstrap-binary)) @@ -75,6 +78,9 @@ (lambda (e1 e2) (stringstring (%local-url)))) + #:hash-algo 'sha256 + #:hash (sha256 (string->utf8 text))))) + (and (build-derivations %store (list drv)) + (string=? (call-with-input-file (derivation->output-path drv) + get-string-all) + text)))))) + +(unless (force %http-server-socket) + (test-skip 1)) +(test-assert "'download' built-in builder, invalid hash" + (with-http-server 200 "hello, world!" + (let* ((drv (derivation %store "world" + "builtin:download" '() + #:env-vars `(("url" + . ,(object->string (%local-url)))) + #:hash-algo 'sha256 + #:hash (sha256 (random-bytevector 100))))) ;wrong + (guard (c ((nix-protocol-error? c) + (string-contains (nix-protocol-error-message c) "failed"))) + (build-derivations %store (list drv)) + #f)))) + +(unless (force %http-server-socket) + (test-skip 1)) +(test-assert "'download' built-in builder, not found" + (with-http-server 404 "not found" + (let* ((drv (derivation %store "will-never-be-found" + "builtin:download" '() + #:env-vars `(("url" + . ,(object->string (%local-url)))) + #:hash-algo 'sha256 + #:hash (sha256 (random-bytevector 100))))) + (guard (c ((nix-protocol-error? c) + (string-contains (nix-protocol-error-message (pk c)) "failed"))) + (build-derivations %store (list drv)) + #f)))) + +(test-assert "'download' built-in builder, not fixed-output" + (let* ((source (add-text-to-store %store "hello" "hi!")) + (url (string-append "file://" source)) + (drv (derivation %store "world" + "builtin:download" '() + #:env-vars `(("url" . ,(object->string url)))))) + (guard (c ((nix-protocol-error? c) + (string-contains (nix-protocol-error-message c) "failed"))) + (build-derivations %store (list drv)) + #f))) + (test-equal "derivation-name" "foo-0.0" (let ((drv (derivation %store "foo-0.0" %bash '()))) -- cgit v1.2.3 From f9aefa2d5fb3f6aad25a907939ee872c828b33d0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 13 Nov 2016 22:59:54 +0100 Subject: daemon: Add 'built-in-builders' RPC. * nix/libstore/builtins.cc (builtinBuilderNames): New function. * nix/libstore/builtins.hh (builtinBuilderNames): New declaration. * nix/libstore/worker-protocol.hh (PROTOCOL_VERSION): Bump to 0x160. (WorkerOp)[wopBuiltinBuilders]: New value. * nix/nix-daemon/nix-daemon.cc (performOp): Handle it. * guix/store.scm (operation-id)[built-in-builders]: New value. * guix/store.scm (read-arg): Add 'string-list'. (built-in-builders): New procedure. * tests/derivations.scm ("built-in-builders"): New test. --- guix/store.scm | 25 +++++++++++++++++++++++-- nix/libstore/builtins.cc | 10 ++++++++++ nix/libstore/builtins.hh | 3 +++ nix/libstore/worker-protocol.hh | 5 +++-- nix/nix-daemon/nix-daemon.cc | 9 +++++++++ tests/derivations.scm | 4 ++++ 6 files changed, 52 insertions(+), 4 deletions(-) (limited to 'tests') diff --git a/guix/store.scm b/guix/store.scm index 43cfda9214..3047dc39b9 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -95,6 +95,7 @@ path-info-registration-time path-info-nar-size + built-in-builders references references/substitutes requisites @@ -187,7 +188,8 @@ (query-substitutable-paths 32) (query-valid-derivers 33) (optimize-store 34) - (verify-store 35)) + (verify-store 35) + (built-in-builders 80)) (define-enumerate-type hash-algo ;; hash.hh @@ -283,7 +285,7 @@ (write-string (bytevector->base16-string arg) p)))) (define-syntax read-arg - (syntax-rules (integer boolean string store-path store-path-list + (syntax-rules (integer boolean string store-path store-path-list string-list substitutable-path-list path-info base16) ((_ integer p) (read-int p)) @@ -295,6 +297,8 @@ (read-store-path p)) ((_ store-path-list p) (read-store-path-list p)) + ((_ string-list p) + (read-string-list p)) ((_ substitutable-path-list p) (read-substitutable-path-list p)) ((_ path-info p) @@ -914,6 +918,23 @@ that there is no guarantee that the order of the resulting list matches the order of PATHS." substitutable-path-list)) +(define built-in-builders + (let ((builders (operation (built-in-builders) + "Return the built-in builders." + string-list))) + (lambda (store) + "Return the names of the supported built-in derivation builders +supported by STORE." + ;; Check whether STORE's version supports this RPC and built-in + ;; derivation builders in general, which appeared in Guix > 0.11.0. + ;; Return the empty list if it doesn't. Note that this RPC does not + ;; exist in 'nix-daemon'. + (if (or (> (nix-server-major-version store) #x100) + (and (= (nix-server-major-version store) #x100) + (>= (nix-server-minor-version store) #x60))) + (builders store) + '())))) + (define-operation (optimize-store) "Optimize the store by hard-linking identical files (\"deduplication\".) Return #t on success." diff --git a/nix/libstore/builtins.cc b/nix/libstore/builtins.cc index 605e44079a..32af767dc4 100644 --- a/nix/libstore/builtins.cc +++ b/nix/libstore/builtins.cc @@ -66,4 +66,14 @@ derivationBuilder lookupBuiltinBuilder(const std::string & name) return NULL; } +std::list builtinBuilderNames() +{ + std::list result; + for(auto&& iter: builtins) + { + result.push_back(iter.first); + } + return result; +} + } diff --git a/nix/libstore/builtins.hh b/nix/libstore/builtins.hh index 0c6db651ab..79171fcb6c 100644 --- a/nix/libstore/builtins.hh +++ b/nix/libstore/builtins.hh @@ -38,4 +38,7 @@ namespace nix { /* Return the built-in builder called BUILDER, or NULL if none was found. */ derivationBuilder lookupBuiltinBuilder(const std::string &builder); + + /* Return the list of supported built-in builder names. */ + std::list builtinBuilderNames(); } diff --git a/nix/libstore/worker-protocol.hh b/nix/libstore/worker-protocol.hh index 7b7be4a8a0..bdeaca2e3a 100644 --- a/nix/libstore/worker-protocol.hh +++ b/nix/libstore/worker-protocol.hh @@ -6,7 +6,7 @@ namespace nix { #define WORKER_MAGIC_1 0x6e697863 #define WORKER_MAGIC_2 0x6478696f -#define PROTOCOL_VERSION 0x10f +#define PROTOCOL_VERSION 0x160 #define GET_PROTOCOL_MAJOR(x) ((x) & 0xff00) #define GET_PROTOCOL_MINOR(x) ((x) & 0x00ff) @@ -43,7 +43,8 @@ typedef enum { wopQuerySubstitutablePaths = 32, wopQueryValidDerivers = 33, wopOptimiseStore = 34, - wopVerifyStore = 35 + wopVerifyStore = 35, + wopBuiltinBuilders = 80 } WorkerOp; diff --git a/nix/nix-daemon/nix-daemon.cc b/nix/nix-daemon/nix-daemon.cc index 35c284f7e1..9b29b3e91d 100644 --- a/nix/nix-daemon/nix-daemon.cc +++ b/nix/nix-daemon/nix-daemon.cc @@ -6,6 +6,7 @@ #include "archive.hh" #include "affinity.hh" #include "globals.hh" +#include "builtins.hh" #include @@ -671,6 +672,14 @@ static void performOp(bool trusted, unsigned int clientVersion, break; } + case wopBuiltinBuilders: { + startWork(); + auto names = builtinBuilderNames(); + stopWork(); + writeStrings(names, to); + break; + } + default: throw Error(format("invalid operation %1%") % op); } diff --git a/tests/derivations.scm b/tests/derivations.scm index 449fb47832..2b5aa796d4 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -211,6 +211,10 @@ (= (stat:ino (lstat file1)) (stat:ino (lstat file2)))))))) +(test-equal "built-in-builders" + '("download") + (built-in-builders %store)) + (test-assert "unknown built-in builder" (let ((drv (derivation %store "ohoh" "builtin:does-not-exist" '()))) (guard (c ((nix-protocol-error? c) -- cgit v1.2.3 From 67e5f3b71d87d0a0e444df2e039c458629708cd4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 16 Nov 2016 23:36:29 +0100 Subject: syscalls: Add bindings for SIOCGIFNETMASK and SIOCSIFNETMASK. * guix/build/syscalls.scm (SIOCGIFNETMASK, SIOCSIFNETMASK): New variables. (set-network-interface-netmask, network-interface-netmask): New procedures. * tests/syscalls.scm ("network-interface-netmask lo") ("set-network-interface-netmask"): New tests. --- guix/build/syscalls.scm | 42 ++++++++++++++++++++++++++++++++++++++++++ tests/syscalls.scm | 21 +++++++++++++++++++++ 2 files changed, 63 insertions(+) (limited to 'tests') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 1ad6cb4618..f4d4d155ec 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -87,10 +87,12 @@ all-network-interface-names network-interface-names network-interface-flags + network-interface-netmask loopback-network-interface? network-interface-address set-network-interface-flags set-network-interface-address + set-network-interface-netmask set-network-interface-up configure-network-interface @@ -764,6 +766,14 @@ exception if it's already taken." (if (string-contains %host-type "linux") #x8916 ;GNU/Linux -1)) ;FIXME: GNU/Hurd? +(define SIOCGIFNETMASK + (if (string-contains %host-type "linux") + #x891b ;GNU/Linux + -1)) ;FIXME: GNU/Hurd? +(define SIOCSIFNETMASK + (if (string-contains %host-type "linux") + #x891c ;GNU/Linux + -1)) ;FIXME: GNU/Hurd? ;; Flags and constants from . @@ -970,6 +980,22 @@ interface NAME." (list name (strerror err)) (list err)))))) +(define (set-network-interface-netmask socket name sockaddr) + "Set the network mask of interface NAME to SOCKADDR." + (let ((req (make-bytevector ifreq-struct-size))) + (bytevector-copy! (string->utf8 name) 0 req 0 + (min (string-length name) (- IF_NAMESIZE 1))) + ;; Set the 'ifr_addr' field. + (write-socket-address! sockaddr req IF_NAMESIZE) + (let-values (((ret err) + (%ioctl (fileno socket) SIOCSIFNETMASK + (bytevector->pointer req)))) + (unless (zero? ret) + (throw 'system-error "set-network-interface-netmask" + "set-network-interface-netmask on ~A: ~A" + (list name (strerror err)) + (list err)))))) + (define (network-interface-address socket name) "Return the address of network interface NAME. The result is an object of the same type as that returned by 'make-socket-address'." @@ -986,6 +1012,22 @@ the same type as that returned by 'make-socket-address'." (list name (strerror err)) (list err)))))) +(define (network-interface-netmask socket name) + "Return the netmask of network interface NAME. The result is an object of +the same type as that returned by 'make-socket-address'." + (let ((req (make-bytevector ifreq-struct-size))) + (bytevector-copy! (string->utf8 name) 0 req 0 + (min (string-length name) (- IF_NAMESIZE 1))) + (let-values (((ret err) + (%ioctl (fileno socket) SIOCGIFNETMASK + (bytevector->pointer req)))) + (if (zero? ret) + (read-socket-address req IF_NAMESIZE) + (throw 'system-error "network-interface-netmask" + "network-interface-netmask on ~A: ~A" + (list name (strerror err)) + (list err)))))) + (define (configure-network-interface name sockaddr flags) "Configure network interface NAME to use SOCKADDR, an address as returned by 'make-socket-address', and FLAGS, a bitwise-or of IFF_* constants." diff --git a/tests/syscalls.scm b/tests/syscalls.scm index 9eb19f9c80..fd177265f0 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -326,6 +326,27 @@ ;; We get EPERM with Linux 3.18ish and EACCES with 2.6.32. (memv (system-error-errno args) (list EPERM EACCES)))))) +(test-equal "network-interface-netmask lo" + (make-socket-address AF_INET (inet-pton AF_INET "255.0.0.0") 0) + (let* ((sock (socket AF_INET SOCK_STREAM 0)) + (addr (network-interface-netmask sock "lo"))) + (close-port sock) + addr)) + +(test-skip (if (zero? (getuid)) 1 0)) +(test-assert "set-network-interface-netmask" + (let ((sock (socket AF_INET SOCK_STREAM 0))) + (catch 'system-error + (lambda () + (set-network-interface-netmask sock "nonexistent" + (make-socket-address + AF_INET + (inet-pton AF_INET "255.0.0.0") + 0))) + (lambda args + (close-port sock) + (memv (system-error-errno args) (list EPERM EACCES)))))) + (test-equal "network-interfaces returns one or more interfaces" '(#t #t #t) (match (network-interfaces) -- cgit v1.2.3 From e74f64b9e55cbc3052698830001238d2407fed19 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 19 Nov 2016 17:05:07 +0100 Subject: store: Add 'references*'. * guix/store.scm (references*): New procedure. * guix/profiles.scm (manifest-lookup-package)[references*]: Remove. * guix/scripts/system.scm (references*): Remove. * tests/gexp.scm ("gexp->file", "gexp->file + file-append") ("gexp->derivation", "gexp->derivation, cross-compilation") ("gexp->derivation, ungexp + ungexp-native") ("scheme-file", "text-file*", "mixed-text-file"): Remove 'references*' instead of (store-lift references). --- guix/profiles.scm | 4 ---- guix/scripts/system.scm | 3 --- guix/store.scm | 4 ++++ tests/gexp.scm | 59 ++++++++++++++++++++++++------------------------- 4 files changed, 33 insertions(+), 37 deletions(-) (limited to 'tests') diff --git a/guix/profiles.scm b/guix/profiles.scm index b56b8f4c79..0b317ef51e 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -501,10 +501,6 @@ if not found." #t)))) items)) - ;; TODO: Factorize. - (define references* - (store-lift references)) - (with-monad %store-monad (match (manifest-entry-item entry) ((? package? package) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 71ddccfa61..bb373a6726 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -77,9 +77,6 @@ ;;; Installation. ;;; -;; TODO: Factorize. -(define references* - (store-lift references)) (define topologically-sorted* (store-lift topologically-sorted)) diff --git a/guix/store.scm b/guix/store.scm index 3047dc39b9..7f54b87db1 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -98,6 +98,7 @@ built-in-builders references references/substitutes + references* requisites referrers optimize-store @@ -1170,6 +1171,9 @@ where FILE is the entry's absolute file name and STAT is the result of (define set-build-options* (store-lift set-build-options)) +(define references* + (store-lift references)) + (define-inlinable (current-system) ;; Consult the %CURRENT-SYSTEM fluid at bind time. This is equivalent to ;; (lift0 %current-system %store-monad), but inlinable, thus avoiding diff --git a/tests/gexp.scm b/tests/gexp.scm index 214e7a5302..354d28f014 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -375,7 +375,7 @@ (drv (gexp->file "foo" exp)) (out -> (derivation->output-path drv)) (done (built-derivations (list drv))) - (refs ((store-lift references) out))) + (refs (references* out))) (return (and (equal? sexp (call-with-input-file out read)) (equal? (list guile) refs))))) @@ -386,7 +386,7 @@ (drv (gexp->file "foo" exp)) (out -> (derivation->output-path drv)) (done (built-derivations (list drv))) - (refs ((store-lift references) out))) + (refs (references* out))) (return (and (equal? (string-append guile "/bin/guile") (call-with-input-file out read)) (equal? (list guile) refs))))) @@ -407,8 +407,8 @@ (out -> (derivation->output-path drv)) (out2 -> (derivation->output-path drv "2nd")) (done (built-derivations (list drv))) - (refs ((store-lift references) out)) - (refs2 ((store-lift references) out2)) + (refs (references* out)) + (refs2 (references* out2)) (guile (package-file %bootstrap-guile "bin/guile"))) (return (and (string=? (readlink (string-append out "/foo")) guile) (string=? (readlink out2) file) @@ -481,7 +481,7 @@ (ungexp output)))) (xdrv (gexp->derivation "foo" exp #:target target)) - (refs ((store-lift references) + (refs (references* (derivation-file-name xdrv))) (xcu (package->cross-derivation coreutils target)) @@ -506,7 +506,7 @@ (ungexp output)))) (xdrv (gexp->derivation "foo" exp #:target target)) - (refs ((store-lift references) + (refs (references* (derivation-file-name xdrv))) (xglibc (package->cross-derivation glibc target)) (cu (package->derivation coreutils))) @@ -808,34 +808,33 @@ (out -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) - (mlet %store-monad ((refs ((store-lift references) out))) + (mlet %store-monad ((refs (references* out))) (return (and (equal? refs (list text)) (equal? `(list "foo" ,text) (call-with-input-file out read))))))))) (test-assert "text-file*" - (let ((references (store-lift references))) - (run-with-store %store - (mlet* %store-monad - ((drv (package->derivation %bootstrap-guile)) - (guile -> (derivation->output-path drv)) - (file (text-file "bar" "This is bar.")) - (text (text-file* "foo" - %bootstrap-guile "/bin/guile " - (gexp-input %bootstrap-guile "out") "/bin/guile " - drv "/bin/guile " - file)) - (done (built-derivations (list text))) - (out -> (derivation->output-path text)) - (refs (references out))) - ;; Make sure we get the right references and the right content. - (return (and (lset= string=? refs (list guile file)) - (equal? (call-with-input-file out get-string-all) - (string-append guile "/bin/guile " - guile "/bin/guile " - guile "/bin/guile " - file))))) - #:guile-for-build (package-derivation %store %bootstrap-guile)))) + (run-with-store %store + (mlet* %store-monad + ((drv (package->derivation %bootstrap-guile)) + (guile -> (derivation->output-path drv)) + (file (text-file "bar" "This is bar.")) + (text (text-file* "foo" + %bootstrap-guile "/bin/guile " + (gexp-input %bootstrap-guile "out") "/bin/guile " + drv "/bin/guile " + file)) + (done (built-derivations (list text))) + (out -> (derivation->output-path text)) + (refs (references* out))) + ;; Make sure we get the right references and the right content. + (return (and (lset= string=? refs (list guile file)) + (equal? (call-with-input-file out get-string-all) + (string-append guile "/bin/guile " + guile "/bin/guile " + guile "/bin/guile " + file))))) + #:guile-for-build (package-derivation %store %bootstrap-guile))) (test-assertm "mixed-text-file" (mlet* %store-monad ((file -> (mixed-text-file "mixed" @@ -847,7 +846,7 @@ (guile -> (derivation->output-path guile-drv))) (mbegin %store-monad (built-derivations (list drv)) - (mlet %store-monad ((refs ((store-lift references) out))) + (mlet %store-monad ((refs (references* out))) (return (and (string=? (string-append "export PATH=" guile "/bin") (call-with-input-file out get-string-all)) (equal? refs (list guile)))))))) -- cgit v1.2.3 From fac46e3f5e55f9de6fa2ab8082bc418139590fc0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 19 Nov 2016 18:06:46 +0100 Subject: lint: Add 'mirror-url' checker. * guix/scripts/lint.scm (origin-uris): New procedure. (check-source): Use it. (check-mirror-url): New procedure. (%checkers): Add 'mirror-url' checker. * tests/lint.scm ("mirror-url") ("mirror-url: one suggestion"): New tests. * doc/guix.texi (Invoking guix lint): Document it. --- doc/guix.texi | 4 +++- guix/scripts/lint.scm | 43 +++++++++++++++++++++++++++++++++++++++---- tests/lint.scm | 19 +++++++++++++++++++ 3 files changed, 61 insertions(+), 5 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 0e70830d02..7352ea973f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5379,9 +5379,11 @@ Identify inputs that should most likely be native inputs. @item source @itemx home-page +@itemx mirror-url @itemx source-file-name Probe @code{home-page} and @code{source} URLs and report those that are -invalid. Check that the source file name is meaningful, e.g. is not +invalid. Suggest a @code{mirror://} URL when applicable. Check that +the source file name is meaningful, e.g. is not just a version number or ``git-checkout'', without a declared @code{file-name} (@pxref{origin Reference}). diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 6e6f550941..9641d3926a 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -65,6 +65,7 @@ check-home-page check-source check-source-file-name + check-mirror-url check-license check-vulnerabilities check-formatting @@ -567,6 +568,14 @@ descriptions maintained upstream." (location->string loc) (package-full-name package) (fill-paragraph (escape-quotes upstream) 77 7))))))) +(define (origin-uris origin) + "Return the list of URIs (strings) for ORIGIN." + (match (origin-uri origin) + ((? string? uri) + (list uri)) + ((uris ...) + uris))) + (define (check-source package) "Emit a warning if PACKAGE has an invalid 'source' field, or if that 'source' is not reachable." @@ -583,10 +592,7 @@ descriptions maintained upstream." (let ((origin (package-source package))) (when (and origin (eqv? (origin-method origin) url-fetch)) - (let* ((strings (origin-uri origin)) - (uris (if (list? strings) - (map string->uri strings) - (list (string->uri strings))))) + (let ((uris (map string->uri (origin-uris origin)))) ;; Just make sure that at least one of the URIs is valid. (call-with-values @@ -626,6 +632,31 @@ descriptions maintained upstream." (_ "the source file name should contain the package name") 'source)))) +(define (check-mirror-url package) + "Check whether PACKAGE uses source URLs that should be 'mirror://'." + (define (check-mirror-uri uri) ;XXX: could be optimized + (let loop ((mirrors %mirrors)) + (match mirrors + (() + #t) + (((mirror-id mirror-urls ...) rest ...) + (match (find (cut string-prefix? <> uri) mirror-urls) + (#f + (loop rest)) + (prefix + (emit-warning package + (format #f (_ "URL should be \ +'mirror://~a/~a'") + mirror-id + (string-drop uri (string-length prefix))) + 'source))))))) + + (let ((origin (package-source package))) + (when (and (origin? origin) + (eqv? (origin-method origin) url-fetch)) + (let ((uris (origin-uris origin))) + (for-each check-mirror-uri uris))))) + (define (check-derivation package) "Emit a warning if we fail to compile PACKAGE to a derivation." (catch #t @@ -863,6 +894,10 @@ or a list thereof") (name 'source) (description "Validate source URLs") (check check-source)) + (lint-checker + (name 'mirror-url) + (description "Suggest 'mirror://' URLs") + (check check-mirror-url)) (lint-checker (name 'source-file-name) (description "Validate file names of sources") diff --git a/tests/lint.scm b/tests/lint.scm index cf1b95ee69..0c534562a4 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -508,6 +508,25 @@ (check-source pkg)))) "not reachable: 404"))) +(test-assert "mirror-url" + (string-null? + (with-warnings + (let ((source (origin + (method url-fetch) + (uri "http://example.org/foo/bar.tar.gz") + (sha256 %null-sha256)))) + (check-mirror-url (dummy-package "x" (source source))))))) + +(test-assert "mirror-url: one suggestion" + (string-contains + (with-warnings + (let ((source (origin + (method url-fetch) + (uri "http://ftp.gnu.org/pub/gnu/foo/foo.tar.gz") + (sha256 %null-sha256)))) + (check-mirror-url (dummy-package "x" (source source))))) + "mirror://gnu/foo/foo.tar.gz")) + (test-assert "cve" (mock ((guix scripts lint) package-vulnerabilities (const '())) (string-null? -- cgit v1.2.3 From 9e38e3cf527d907b499f8fc909aac5d0e25a5af7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 20 Nov 2016 23:35:25 +0100 Subject: syscalls: Add 'add-network-route/gateway' and 'delete-network-route'. * guix/build/syscalls.scm (SIOCADDRT, SIOCDELRT): New variables. (%rtentry): New C struct. (RTF_UP, RTF_GATEWAY, %sockaddr-any): New variables. (add-network-route/gateway, delete-network-route): New procedures. * tests/syscalls.scm ("add-network-route/gateway") ("delete-network-route"): New tests. --- guix/build/syscalls.scm | 110 ++++++++++++++++++++++++++++++++++++++++++++++++ tests/syscalls.scm | 24 +++++++++++ 2 files changed, 134 insertions(+) (limited to 'tests') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 85de47d26e..9386c0f5d0 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -95,6 +95,8 @@ set-network-interface-netmask set-network-interface-up configure-network-interface + add-network-route/gateway + delete-network-route interface? interface-name @@ -805,6 +807,14 @@ exception if it's already taken." (if (string-contains %host-type "linux") #x891c ;GNU/Linux -1)) ;FIXME: GNU/Hurd? +(define SIOCADDRT + (if (string-contains %host-type "linux") + #x890B ;GNU/Linux + -1)) ;FIXME: GNU/Hurd? +(define SIOCDELRT + (if (string-contains %host-type "linux") + #x890C ;GNU/Linux + -1)) ;FIXME: GNU/Hurd? ;; Flags and constants from . @@ -1088,6 +1098,106 @@ is true, it must be a socket address to use as the network mask." (lambda () (close-port sock))))) + +;;; +;;; Network routes. +;;; + +(define-c-struct %rtentry ;'struct rtentry' from + sizeof-rtentry + list + read-rtentry + write-rtentry! + (pad1 unsigned-long) + (destination (array uint8 16)) ;struct sockaddr + (gateway (array uint8 16)) ;struct sockaddr + (genmask (array uint8 16)) ;struct sockaddr + (flags unsigned-short) + (pad2 short) + (pad3 long) + (tos uint8) + (class uint8) + (pad4 (array uint8 (if (= 8 (sizeof* '*)) 3 1))) + (metric short) + (device '*) + (mtu unsigned-long) + (window unsigned-long) + (initial-rtt unsigned-short)) + +(define RTF_UP #x0001) ;'rtentry' flags from +(define RTF_GATEWAY #x0002) + +(define %sockaddr-any + (make-socket-address AF_INET INADDR_ANY 0)) + +(define add-network-route/gateway + ;; To allow field names to be matched as literals, we need to move them out + ;; of the lambda's body since the parameters have the same name. A lot of + ;; fuss for very little. + (let-syntax ((gateway-offset (identifier-syntax + (c-struct-field-offset %rtentry gateway))) + (destination-offset (identifier-syntax + (c-struct-field-offset %rtentry destination))) + (genmask-offset (identifier-syntax + (c-struct-field-offset %rtentry genmask)))) + (lambda* (socket gateway + #:key (destination %sockaddr-any) (genmask %sockaddr-any)) + "Add a network route for DESTINATION (a socket address as returned by +'make-socket-address') that goes through GATEWAY (a socket address). For +instance, the call: + + (add-network-route/gateway sock + (make-socket-address + AF_INET + (inet-pton AF_INET \"192.168.0.1\") + 0)) + +is equivalent to this 'net-tools' command: + + route add -net default gw 192.168.0.1 + +because the default value of DESTINATION is \"0.0.0.0\"." + (let ((route (make-bytevector sizeof-rtentry 0))) + (write-socket-address! gateway route gateway-offset) + (write-socket-address! destination route destination-offset) + (write-socket-address! genmask route genmask-offset) + (bytevector-u16-native-set! route + (c-struct-field-offset %rtentry flags) + (logior RTF_UP RTF_GATEWAY)) + (let-values (((ret err) + (%ioctl (fileno socket) SIOCADDRT + (bytevector->pointer route)))) + (unless (zero? ret) + (throw 'system-error "add-network-route/gateway" + "add-network-route/gateway: ~A" + (list (strerror err)) + (list err)))))))) + +(define delete-network-route + (let-syntax ((destination-offset (identifier-syntax + (c-struct-field-offset %rtentry destination)))) + (lambda* (socket destination) + "Delete the network route for DESTINATION. For instance, the call: + + (delete-network-route sock + (make-socket-address AF_INET INADDR_ANY 0)) + +is equivalent to the 'net-tools' command: + + route del -net default +" + + (let ((route (make-bytevector sizeof-rtentry 0))) + (write-socket-address! destination route destination-offset) + (let-values (((ret err) + (%ioctl (fileno socket) SIOCDELRT + (bytevector->pointer route)))) + (unless (zero? ret) + (throw 'system-error "delete-network-route" + "delete-network-route: ~A" + (list (strerror err)) + (list err)))))))) + ;;; ;;; Details about network interfaces---aka. 'getifaddrs'. diff --git a/tests/syscalls.scm b/tests/syscalls.scm index fd177265f0..e4ef32c522 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -374,6 +374,30 @@ (#f #f) (lo (interface-address lo))))))) +(test-skip (if (zero? (getuid)) 1 0)) +(test-assert "add-network-route/gateway" + (let ((sock (socket AF_INET SOCK_STREAM 0)) + (gateway (make-socket-address AF_INET + (inet-pton AF_INET "192.168.0.1") + 0))) + (catch 'system-error + (lambda () + (add-network-route/gateway sock gateway)) + (lambda args + (close-port sock) + (memv (system-error-errno args) (list EPERM EACCES)))))) + +(test-skip (if (zero? (getuid)) 1 0)) +(test-assert "delete-network-route" + (let ((sock (socket AF_INET SOCK_STREAM 0)) + (destination (make-socket-address AF_INET INADDR_ANY 0))) + (catch 'system-error + (lambda () + (delete-network-route sock destination)) + (lambda args + (close-port sock) + (memv (system-error-errno args) (list EPERM EACCES)))))) + (test-equal "tcgetattr ENOTTY" ENOTTY (catch 'system-error -- cgit v1.2.3