From 0865d8a8f6c229fef5bcba647cc7b37c2f3d3dae Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Fri, 21 Dec 2018 17:48:55 +0530 Subject: guix: lint: Check for source URIs redirecting to GitHub. * guix/scripts/lint.scm (check-github-uri): New procedure. (%checkers): Add it. * doc/guix.texi (Invoking guix lint): Document it. * tests/lint.scm ("github-url", "github-url: one suggestion"): New tests. --- doc/guix.texi | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 33f5c63420..484a29f2e1 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7660,12 +7660,14 @@ Identify inputs that should most likely be native inputs. @item source @itemx home-page @itemx mirror-url +@itemx github-url @itemx source-file-name Probe @code{home-page} and @code{source} URLs and report those that are -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}). +invalid. Suggest a @code{mirror://} URL when applicable. If the +@code{source} URL redirects to a GitHub URL, recommend usage of the GitHub +URL. 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}). @item cve @cindex security vulnerabilities -- cgit 1.4.1 From dcad57d5fca43a111e1b314264171c80d4d9a75b Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Wed, 12 Dec 2018 10:15:08 +0200 Subject: services: Add quassel. * gnu/services/messaging.scm (): New record type. (%quassel-account, %quassel-activation): New procedures. (quassel-service-type): New variable. * gnu/tests/messaging.scm (%test-quassel): New variable. (run-quassel-test): New procedure. * doc/guix.texi (Messaging): Document quassel service. --- doc/guix.texi | 31 ++++++++++++++++ gnu/services/messaging.scm | 90 +++++++++++++++++++++++++++++++++++++++++++++- gnu/tests/messaging.scm | 54 +++++++++++++++++++++++++++- 3 files changed, 173 insertions(+), 2 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 484a29f2e1..2553ba7fe0 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -16298,6 +16298,37 @@ Configuration snippet added as-is to the BitlBee configuration file. @end table @end deftp +@subsubheading Quassel Service + +@cindex IRC (Internet Relay Chat) +@url{https://quassel-irc.org/,Quassel} is a distributed IRC client, +meaning that one or more clients can attach to and detach from the +central core. + +@defvr {Scheme Variable} quassel-service-type +This is the service type for the @url{https://quassel-irc.org/,Quassel} +IRC backend daemon. Its value is a @code{quassel-configuration} +(see below). +@end defvr + +@deftp {Data Type} quassel-configuration +This is the configuration for Quassel, with the following fields: + +@table @asis +@item @code{quassel} (default: @code{quassel}) +The Quassel package to use. + +@item @code{interface} (default: @code{"::,0.0.0.0"}) +@item @code{port} (default: @code{4242}) +Listen on the network interface(s) corresponding to the IPv4 or IPv6 +interfaces specified in the comma delimited @var{interface}, on +@var{port}. + +@item @code{loglevel} (default: @code{"Info"}) +The level of logging desired. Accepted values are Debug, Info, Warning +and Error. +@end table +@end deftp @node Telephony Services @subsubsection Telephony Services diff --git a/gnu/services/messaging.scm b/gnu/services/messaging.scm index 1108006411..92f86a1b83 100644 --- a/gnu/services/messaging.scm +++ b/gnu/services/messaging.scm @@ -22,6 +22,8 @@ (define-module (gnu services messaging) #:use-module (gnu packages messaging) #:use-module (gnu packages admin) + #:use-module (gnu packages irc) + #:use-module (gnu packages tls) #:use-module (gnu services) #:use-module (gnu services shepherd) #:use-module (gnu services configuration) @@ -50,7 +52,10 @@ bitlbee-configuration bitlbee-configuration? bitlbee-service - bitlbee-service-type)) + bitlbee-service-type + + quassel-configuration + quassel-service-type)) ;;; Commentary: ;;; @@ -895,3 +900,86 @@ configuration file." (bitlbee bitlbee) (interface interface) (port port) (extra-settings extra-settings)))) + + +;;; +;;; Quassel. +;;; + +(define-record-type* + quassel-configuration make-quassel-configuration + quassel-configuration? + (quassel quassel-configuration-quassel + (default quassel)) + (interface quassel-configuration-interface + (default "::,0.0.0.0")) + (port quassel-configuration-port + (default 4242)) + (loglevel quassel-configuration-loglevel + (default "Info"))) + +(define quassel-shepherd-service + (match-lambda + (($ quassel interface port loglevel) + (with-imported-modules (source-module-closure + '((gnu build shepherd) + (gnu system file-systems))) + (list (shepherd-service + (provision '(quassel)) + (requirement '(user-processes networking)) + (modules '((gnu build shepherd) + (gnu system file-systems))) + (start #~(make-forkexec-constructor/container + (list #$(file-append quassel "/bin/quasselcore") + "--configdir=/var/lib/quassel" + "--logfile=/var/log/quassel/core.log" + (string-append "--loglevel=" #$loglevel) + (string-append "--port=" (number->string #$port)) + (string-append "--listen=" #$interface)) + #:mappings (list (file-system-mapping + (source "/var/lib/quassel") + (target source) + (writable? #t)) + (file-system-mapping + (source "/var/log/quassel") + (target source) + (writable? #t))))) + (stop #~(make-kill-destructor)))))))) + +(define %quassel-account + (list (user-group (name "quassel") (system? #t)) + (user-account + (name "quasselcore") + (group "quassel") + (system? #t) + (comment "Quassel daemon user") + (home-directory "/var/lib/quassel") + (shell (file-append shadow "/sbin/nologin"))))) + +(define %quassel-activation + #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/lib/quassel") + (mkdir-p "/var/log/quassel") + (let ((cert "/var/lib/quassel/quasselCert.pem")) + (unless (file-exists? cert) + (invoke #$(file-append openssl "/bin/openssl") + "req" "-x509" "-nodes" "-batch" "-days" "680" "-newkey" + "rsa" "-keyout" cert "-out" cert))))) + +(define quassel-service-type + (service-type (name 'quassel) + (extensions + (list (service-extension shepherd-root-service-type + quassel-shepherd-service) + (service-extension profile-service-type + (compose list quassel-configuration-quassel)) + (service-extension account-service-type + (const %quassel-account)) + (service-extension activation-service-type + (const %quassel-activation)))) + (default-value (quassel-configuration)) + (description + "Run @url{https://quassel-irc.org/,quasselcore}, the backend +for the distributed IRC client quassel, which allows you to connect from +multiple machines simultaneously."))) diff --git a/gnu/tests/messaging.scm b/gnu/tests/messaging.scm index 36afb987af..176e3d08cb 100644 --- a/gnu/tests/messaging.scm +++ b/gnu/tests/messaging.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2018 Clément Lassieur ;;; Copyright © 2017, 2018 Ludovic Courtès +;;; Copyright © 2018 Efraim Flashner ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,7 +30,8 @@ #:use-module (guix store) #:use-module (guix modules) #:export (%test-prosody - %test-bitlbee)) + %test-bitlbee + %test-quassel)) (define (run-xmpp-test name xmpp-service pid-file create-account) "Run a test of an OS running XMPP-SERVICE, which writes its PID to PID-FILE." @@ -239,3 +241,53 @@ (name "bitlbee") (description "Connect to a BitlBee IRC server.") (value (run-bitlbee-test)))) + +(define (run-quassel-test) + (define os + (marionette-operating-system + (simple-operating-system (service dhcp-client-service-type) + (service quassel-service-type)) + #:imported-modules (source-module-closure + '((gnu services herd))))) + + (define vm + (virtual-machine + (operating-system os) + (port-forwardings `((4242 . 4242))))) + + (define test + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (srfi srfi-64) + (gnu build marionette)) + + (define marionette + (make-marionette (list #$vm))) + + (mkdir #$output) + (chdir #$output) + + (test-begin "quassel") + + (test-assert "service started" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'quassel)) + marionette)) + + (test-assert "certificate file" + (marionette-eval + '(file-exists? "/var/lib/quassel/quasselCert.pem") + marionette)) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation "quassel-test" test)) + +(define %test-quassel + (system-test + (name "quassel") + (description "Connect to a quassel IRC server.") + (value (run-quassel-test)))) -- cgit 1.4.1 From c39491829a0c1d870f8133b8f7a699152fc71503 Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Wed, 19 Dec 2018 22:08:18 +0200 Subject: scripts: refresh: Allow searching recursively. * guix/scripts/refresh.scm (refresh-recursive, list-transitive): New procedures. (show-help): Document it. (guix-refresh): Add flags and checks for new options. * doc/guix.texi (Invoking guix refresh): Document new options. --- doc/guix.texi | 32 ++++++++++++++++++++++++++++ guix/scripts/refresh.scm | 55 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 87 insertions(+) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 2553ba7fe0..514ee3e6a8 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7392,6 +7392,22 @@ are many packages, though, for which it lacks a method to determine whether a new upstream release is available. However, the mechanism is extensible, so feel free to get in touch with us to add a new method! +@table @code + +@item --recursive +Consider the packages specified, and all the packages upon which they depend. + +@example +$ guix refresh --recursive coreutils +gnu/packages/acl.scm:35:2: warning: no updater for acl +gnu/packages/m4.scm:30:12: info: 1.4.18 is already the latest version of m4 +gnu/packages/xml.scm:68:2: warning: no updater for expat +gnu/packages/multiprecision.scm:40:12: info: 6.1.2 is already the latest version of gmp +@dots{} +@end example + +@end table + Sometimes the upstream name differs from the package name used in Guix, and @command{guix refresh} needs a little help. Most updaters honor the @code{upstream-name} property in package definitions, which can be used @@ -7565,6 +7581,22 @@ hop@@2.4.0 geiser@@0.4 notmuch@@0.18 mu@@0.9.9.5 cflow@@1.4 idutils@@4.6 @dots{} The command above lists a set of packages that could be built to check for compatibility with an upgraded @code{flex} package. +@table @code + +@item --list-transitive +List all the packages which one or more packages depend upon. + +@example +$ guix refresh --list-transitive flex +flex@2.6.4 depends on the following 25 packages: perl@5.28.0 help2man@1.47.6 +bison@3.0.5 indent@2.2.10 tar@1.30 gzip@1.9 bzip2@1.0.6 xz@5.2.4 file@5.33 @dote{} +@end example + +@end table + +The command above lists a set of packages which, when changed, would cause +@code{flex} to be rebuilt. + The following options can be used to customize GnuPG operation: @table @code diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 1d86f949c8..003c915da3 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2015 Alex Kost ;;; Copyright © 2016 Ben Woodcroft ;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2018 Efraim Flashner ;;; ;;; This file is part of GNU Guix. ;;; @@ -40,6 +41,7 @@ #:use-module (ice-9 regex) #:use-module (ice-9 vlist) #:use-module (ice-9 format) + #:use-module (ice-9 threads) ; par-for-each #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -88,6 +90,12 @@ (option '(#\l "list-dependent") #f #f (lambda (opt name arg result) (alist-cons 'list-dependent? #t result))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive? #t result))) + (option '("list-transitive") #f #f + (lambda (opt name arg result) + (alist-cons 'list-transitive? #t result))) (option '("keyring") #t #f (lambda (opt name arg result) @@ -140,6 +148,10 @@ specified with `--select'.\n")) (display (G_ " -l, --list-dependent list top-level dependent packages that would need to be rebuilt as a result of upgrading PACKAGE...")) + (display (G_ " + -r, --recursive check the PACKAGE and its inputs for upgrades")) + (display (G_ " + --list-transitive list all the packages that PACKAGE depends on")) (newline) (display (G_ " --keyring=FILE use FILE as the keyring of upstream OpenPGP keys")) @@ -323,6 +335,43 @@ dependent packages are rebuilt: ~{~a~^ ~}~%" (map full-name covering)))) (return #t)))) +(define (refresh-recursive packages) + "Check all of the package inputs of PACKAGES for newer upstream versions." + (mlet %store-monad ((edges (node-edges %bag-node-type + ;; Here we don't want the -boot0 packages. + (fold-packages cons '())))) + (let ((dependent (node-transitive-edges packages edges))) + ;; par-for-each has an undefined return value, so packages which cause + ;; errors can be ignored. + (par-for-each (lambda (package) + (guix-refresh package)) + (map package-name dependent))) + (return #t))) + +(define (list-transitive packages) + "List all the packages that would cause PACKAGES to be rebuilt if they are changed." + ;; Using %BAG-NODE-TYPE is more accurate than using %PACKAGE-NODE-TYPE + ;; because it includes implicit dependencies. + (define (full-name package) + (string-append (package-name package) "@" + (package-version package))) + + (mlet %store-monad ((edges (node-edges %bag-node-type + ;; Here we don't want the -boot0 packages. + (fold-packages cons '())))) + (let ((dependent (node-transitive-edges packages edges))) + (match packages + ((x) + (format (current-output-port) + (G_ "~a depends on the following ~d packages: ~{~a~^ ~}~%.") + (full-name x) (length dependent) (map full-name dependent))) + (lst + (format (current-output-port) + (G_ "The following ~d packages \ +all are dependent packages: ~{~a~^ ~}~%") + (length dependent) (map full-name dependent)))) + (return #t)))) + ;;; ;;; Manifest. @@ -402,7 +451,9 @@ update would trigger a complete rebuild." (let* ((opts (parse-options)) (update? (assoc-ref opts 'update?)) (updaters (options->updaters opts)) + (recursive? (assoc-ref opts 'recursive?)) (list-dependent? (assoc-ref opts 'list-dependent?)) + (list-transitive? (assoc-ref opts 'list-transitive?)) (key-download (assoc-ref opts 'key-download)) ;; Warn about missing updaters when a package is explicitly given on @@ -441,6 +492,10 @@ update would trigger a complete rebuild." (cond (list-dependent? (list-dependents packages)) + (list-transitive? + (list-transitive packages)) + (recursive? + (refresh-recursive packages)) (update? (parameterize ((%openpgp-key-server (or (assoc-ref opts 'key-server) -- cgit 1.4.1 From b599fed5b0be2abcc9ff3cd421e431adf86391ea Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Mon, 24 Dec 2018 12:38:59 +0200 Subject: doc: Fix typo. This is a follow-up to c39491829a0c1d870f8133b8f7a699152fc71503 * doc/guix.texi (Invoking guix refresh): Fix texinfo markup --- doc/guix.texi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 514ee3e6a8..f86a2885a7 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7588,8 +7588,8 @@ List all the packages which one or more packages depend upon. @example $ guix refresh --list-transitive flex -flex@2.6.4 depends on the following 25 packages: perl@5.28.0 help2man@1.47.6 -bison@3.0.5 indent@2.2.10 tar@1.30 gzip@1.9 bzip2@1.0.6 xz@5.2.4 file@5.33 @dote{} +flex@@2.6.4 depends on the following 25 packages: perl@@5.28.0 help2man@@1.47.6 +bison@@3.0.5 indent@@2.2.10 tar@@1.30 gzip@@1.9 bzip2@@1.0.6 xz@@5.2.4 file@@5.33 @dots{} @end example @end table -- cgit 1.4.1 From ed7b44370f71126087eb953f36aad8dc4c44109f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 24 Dec 2018 15:40:04 +0100 Subject: offload: Use (guix inferior) instead of (ssh dist node). Using inferiors and thus 'guix repl' simplifies setup on build machines (no need to worry about GUILE_LOAD_PATH etc.) Furthermore, the 'guix repl -t machine' protocol running in a remote pipe addresses several issues with the current implementation of nodes and RREPLs in Guile-SSH: fewer round trips, doesn't leave a 'guile --listen' process behind it, stateless (since a new process is started each time), more efficient (the SSH channel can be reused), more reliable (no 'pgrep', 'pkill', and shellology; see as an example.) * guix/ssh.scm (inferior-remote-eval): New procedure. (send-files): Use it instead of 'make-node' and 'node-eval'. * guix/scripts/offload.scm (node-guile-version): New procedure. (node-free-disk-space, transfer-and-offload, node-load) (choose-build-machine, assert-node-has-guix): Use 'remote-inferior' instead of 'make-node' and 'inferior-eval' instead of 'node-eval'. (assert-node-can-import, assert-node-can-export): Likewise, and add 'session' parameter. (check-machine-availability): Likewise, and add calls to 'close-inferior' and 'disconnect!'. (check-machine-status): Likewise. * doc/guix.texi (Daemon Offload Setup): Remove bit related to 'guile' in $PATH and $GUILE_LOAD_PATH; mention 'guix' alone. --- doc/guix.texi | 8 ++-- guix/scripts/offload.scm | 107 +++++++++++++++++++++++++---------------------- guix/ssh.scm | 34 ++++++++++----- 3 files changed, 83 insertions(+), 66 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index f86a2885a7..c182995b2b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1051,13 +1051,11 @@ name, and they will be scheduled on matching build machines. @end table @end deftp -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: +The @command{guix} command must be in the search path on the build +machines. You can check whether this is the case by running: @example -ssh build-machine guile -c "'(use-modules (guix config))'" +ssh build-machine guix repl --version @end example There is one last thing to do once @file{machines.scm} is in place. As diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index bfdaa3c011..b472d202a9 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -23,13 +23,12 @@ #:use-module (ssh session) #:use-module (ssh channel) #:use-module (ssh popen) - #:use-module (ssh dist) - #:use-module (ssh dist node) #:use-module (ssh version) #:use-module (guix config) #:use-module (guix records) #:use-module (guix ssh) #:use-module (guix store) + #:use-module (guix inferior) #:use-module (guix derivations) #:use-module ((guix serialization) #:select (nar-error? nar-error-file)) @@ -321,12 +320,15 @@ hook." (set-port-revealed! port 1) port)) +(define (node-guile-version node) + (inferior-eval '(version) node)) + (define (node-free-disk-space node) "Return the free disk space, in bytes, in NODE's store." - (node-eval node - `(begin - (use-modules (guix build syscalls)) - (free-disk-space ,(%store-prefix))))) + (inferior-eval `(begin + (use-modules (guix build syscalls)) + (free-disk-space ,(%store-prefix))) + node)) (define* (transfer-and-offload drv machine #:key @@ -367,8 +369,12 @@ MACHINE." (derivation-file-name drv) (build-machine-name machine) (nix-protocol-error-message c)) - (let* ((space (false-if-exception - (node-free-disk-space (make-node session))))) + (let* ((inferior (false-if-exception (remote-inferior session))) + (space (false-if-exception + (node-free-disk-space inferior)))) + + (when inferior + (close-inferior inferior)) ;; Use exit code 100 for a permanent build failure. The daemon ;; interprets other non-zero codes as transient build failures. @@ -417,11 +423,11 @@ of free disk space on '~a'~%") (define (node-load node) "Return the load on NODE. Return +∞ if NODE is misbehaving." - (let ((line (node-eval node - '(begin - (use-modules (ice-9 rdelim)) - (call-with-input-file "/proc/loadavg" - read-string))))) + (let ((line (inferior-eval '(begin + (use-modules (ice-9 rdelim)) + (call-with-input-file "/proc/loadavg" + read-string)) + node))) (if (eof-object? line) +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded (match (string-tokenize line) @@ -508,9 +514,10 @@ slot (which must later be released with 'release-build-slot'), or #f and #f." ;; Note: We call 'node-load' only as a last resort because it is ;; too costly to call it once for every machine. (let* ((session (false-if-exception (open-ssh-session best))) - (node (and session (make-node session))) + (node (and session (remote-inferior session))) (load (and node (normalized-load best (node-load node)))) (space (and node (node-free-disk-space node)))) + (when node (close-inferior node)) (when session (disconnect! session)) (if (and node (< load 2.) (>= space %minimum-disk-space)) (match others @@ -613,18 +620,17 @@ If TIMEOUT is #f, simply evaluate EXP..." (#f (report-guile-error name)) ((? string? version) - ;; Note: The version string already contains the word "Guile". - (info (G_ "'~a' is running ~a~%") + (info (G_ "'~a' is running GNU Guile ~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." (catch 'node-repl-error (lambda () - (match (node-eval node - '(begin - (use-modules (guix)) - (and add-text-to-store 'alright))) + (match (inferior-eval '(begin + (use-modules (guix)) + (and add-text-to-store 'alright)) + node) ('alright #t) (_ (report-module-error name)))) (lambda (key . args) @@ -632,12 +638,12 @@ If TIMEOUT is #f, simply evaluate EXP..." (catch 'node-repl-error (lambda () - (match (node-eval node - '(begin - (use-modules (guix)) - (with-store store - (add-text-to-store store "test" - "Hello, build machine!")))) + (match (inferior-eval '(begin + (use-modules (guix)) + (with-store store + (add-text-to-store store "test" + "Hello, build machine!"))) + node) ((? string? str) (info (G_ "Guix is usable on '~a' (test returned ~s)~%") name str)) @@ -656,25 +662,23 @@ If TIMEOUT is #f, simply evaluate EXP..." (string-append name "-" (number->string (random 1000000 (force %random-state))))) -(define (assert-node-can-import node name daemon-socket) +(define (assert-node-can-import session 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))) - (with-store local - (send-files local (list item) remote)) - - (if (valid-path? remote item) - (info (G_ "'~a' successfully imported '~a'~%") - name item) - (leave (G_ "'~a' was not properly imported on '~a'~%") - item name)))))) - -(define (assert-node-can-export node name daemon-socket) + (with-store store + (let* ((item (add-text-to-store store "export-test" (nonce))) + (remote (connect-to-remote-daemon session daemon-socket))) + (with-store local + (send-files local (list item) remote)) + + (if (valid-path? remote item) + (info (G_ "'~a' successfully imported '~a'~%") + name item) + (leave (G_ "'~a' was not properly imported on '~a'~%") + item name))))) + +(define (assert-node-can-export session 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)) + (let* ((remote (connect-to-remote-daemon session daemon-socket)) (item (add-text-to-store remote "import-test" (nonce name)))) (with-store store (if (and (retrieve-files store (list item) remote) @@ -701,11 +705,13 @@ machine." (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))) + (nodes (map remote-inferior 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)))) + (for-each assert-node-can-import sessions nodes names sockets) + (for-each assert-node-can-export sessions nodes names sockets) + (for-each close-inferior nodes) + (for-each disconnect! sessions)))) (define (check-machine-status machine-file pred) "Print the load of each machine matching PRED in MACHINE-FILE." @@ -722,10 +728,11 @@ machine." (length machines) machine-file) (for-each (lambda (machine) (let* ((session (open-ssh-session machine)) - (node (make-node session)) - (uts (node-eval node '(uname))) - (load (node-load node)) - (free (node-free-disk-space node))) + (inferior (remote-inferior session)) + (uts (inferior-eval '(uname) inferior)) + (load (node-load inferior)) + (free (node-free-disk-space inferior))) + (close-inferior inferior) (disconnect! session) (format #t "~a~% kernel: ~a ~a~% architecture: ~a~%\ host name: ~a~% normalized load: ~a~% free disk space: ~,2f MiB~%" diff --git a/guix/ssh.scm b/guix/ssh.scm index b8bea8028a..1ed8406633 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -27,8 +27,6 @@ #:use-module (ssh channel) #:use-module (ssh popen) #:use-module (ssh session) - #:use-module (ssh dist) - #:use-module (ssh dist node) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -102,6 +100,20 @@ Throw an error on failure." "guix" "repl" "-t" "machine"))) (port->inferior pipe))) +(define (inferior-remote-eval exp session) + "Evaluate EXP in a new inferior running in SESSION, and close the inferior +right away." + (let ((inferior (remote-inferior session))) + (dynamic-wind + (const #t) + (lambda () + (inferior-eval exp inferior)) + (lambda () + ;; Close INFERIOR right away to prevent finalization from happening in + ;; another thread at the wrong time (see + ;; .) + (close-inferior inferior))))) + (define* (remote-daemon-channel session #:optional (socket-name @@ -277,15 +289,15 @@ Return the list of store items actually sent." ;; Compute the subset of FILES missing on SESSION and send them. (let* ((files (if recursive? (requisites local files) files)) (session (channel-get-session (nix-server-socket remote))) - (node (make-node session)) - (missing (node-eval node - `(begin - (use-modules (guix) - (srfi srfi-1) (srfi srfi-26)) - - (with-store store - (remove (cut valid-path? store <>) - ',files))))) + (missing (inferior-remote-eval + `(begin + (use-modules (guix) + (srfi srfi-1) (srfi srfi-26)) + + (with-store store + (remove (cut valid-path? store <>) + ',files))) + session)) (count (length missing)) (sizes (map (lambda (item) (path-info-nar-size (query-path-info local item))) -- cgit 1.4.1