diff options
| -rw-r--r-- | Makefile.am | 2 | ||||
| -rw-r--r-- | doc/guix.texi | 63 | ||||
| -rw-r--r-- | guix/scripts/processes.scm | 223 | ||||
| -rw-r--r-- | po/guix/POTFILES.in | 1 | ||||
| -rw-r--r-- | tests/processes.scm | 86 |
5 files changed, 375 insertions, 0 deletions
diff --git a/Makefile.am b/Makefile.am index 1acf0b12d0..8c3df8f396 100644 --- a/Makefile.am +++ b/Makefile.am @@ -201,6 +201,7 @@ MODULES = \ guix/scripts/hash.scm \ guix/scripts/pack.scm \ guix/scripts/pull.scm \ + guix/scripts/processes.scm \ guix/scripts/substitute.scm \ guix/scripts/authenticate.scm \ guix/scripts/refresh.scm \ @@ -343,6 +344,7 @@ SCM_TESTS = \ tests/ui.scm \ tests/status.scm \ tests/records.scm \ + tests/processes.scm \ tests/upstream.scm \ tests/combinators.scm \ tests/discovery.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 87579d414d..b41af61f12 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -194,6 +194,7 @@ Utilities * Invoking guix copy:: Copying to and from a remote store. * Invoking guix container:: Process isolation. * Invoking guix weather:: Assessing substitute availability. +* Invoking guix processes:: Listing client processes. Invoking @command{guix build} @@ -1239,6 +1240,12 @@ The build directory is automatically deleted upon completion, unless the build failed and the client specified @option{--keep-failed} (@pxref{Invoking guix build, @option{--keep-failed}}). +The daemon listens for connections and spawns one sub-process for each session +started by a client (one of the @command{guix} sub-commands.) The +@command{guix processes} command allows you to get an overview of the activity +on your system by viewing each of the active sessions and clients. +@xref{Invoking guix processes}, for more information. + The following command-line options are supported: @table @code @@ -6052,6 +6059,7 @@ the Scheme programming interface of Guix in a convenient way. * Invoking guix copy:: Copying to and from a remote store. * Invoking guix container:: Process isolation. * Invoking guix weather:: Assessing substitute availability. +* Invoking guix processes:: Listing client processes. @end menu @node Invoking guix build @@ -8752,6 +8760,61 @@ with the @code{-m} option of @command{guix package} (@pxref{Invoking guix package}). @end table +@node Invoking guix processes +@section Invoking @command{guix processes} + +The @command{guix processes} command can be useful to developers and system +administrators, especially on multi-user machines and on build farms: it lists +the current sessions (connections to the daemon), as well as information about +the processes involved@footnote{Remote sessions, when @command{guix-daemon} is +started with @option{--listen} specifying a TCP endpoint, are @emph{not} +listed.}. Here's an example of the information it returns: + +@example +$ sudo guix processes +SessionPID: 19002 +ClientPID: 19090 +ClientCommand: guix environment --ad-hoc python + +SessionPID: 19402 +ClientPID: 19367 +ClientCommand: guix publish -u guix-publish -p 3000 -C 9 @dots{} + +SessionPID: 19444 +ClientPID: 19419 +ClientCommand: cuirass --cache-directory /var/cache/cuirass @dots{} +LockHeld: /gnu/store/@dots{}-perl-ipc-cmd-0.96.lock +LockHeld: /gnu/store/@dots{}-python-six-bootstrap-1.11.0.lock +LockHeld: /gnu/store/@dots{}-libjpeg-turbo-2.0.0.lock +ChildProcess: 20495: guix offload x86_64-linux 7200 1 28800 +ChildProcess: 27733: guix offload x86_64-linux 7200 1 28800 +ChildProcess: 27793: guix offload x86_64-linux 7200 1 28800 +@end example + +In this example we see that @command{guix-daemon} has three clients: +@command{guix environment}, @command{guix publish}, and the Cuirass continuous +integration tool; their process identifier (PID) is given by the +@code{ClientPID} field. The @code{SessionPID} field gives the PID of the +@command{guix-daemon} sub-process of this particular session. + +The @code{LockHeld} fields show which store items are currently locked by this +session, which corresponds to store items being built or substituted (the +@code{LockHeld} field is not displayed when @command{guix processes} is not +running as root.) Last, by looking at the @code{ChildProcess} field, we +understand that these three builds are being offloaded (@pxref{Daemon Offload +Setup}). + +The output is in Recutils format so we can use the handy @command{recsel} +command to select sessions of interest (@pxref{Selection Expressions,,, +recutils, GNU recutils manual}). As an example, the command shows the command +line and PID of the client that triggered the build of a Perl package: + +@example +$ sudo guix processes | \ + recsel -p ClientPID,ClientCommand -e 'LockHeld ~ "perl"' +ClientPID: 19419 +ClientCommand: cuirass --cache-directory /var/cache/cuirass @dots{} +@end example @c ********************************************************************* @node GNU Distribution diff --git a/guix/scripts/processes.scm b/guix/scripts/processes.scm new file mode 100644 index 0000000000..6a2f603599 --- /dev/null +++ b/guix/scripts/processes.scm @@ -0,0 +1,223 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (guix scripts processes) + #:use-module ((guix store) #:select (%store-prefix)) + #:use-module (guix scripts) + #:use-module (guix ui) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-37) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 format) + #:export (process? + process-id + process-parent-id + process-command + processes + + daemon-session? + daemon-session-process + daemon-session-client + daemon-session-children + daemon-session-locks-held + daemon-sessions + + guix-processes)) + +;; Process as can be found in /proc on GNU/Linux. +(define-record-type <process> + (process id parent command) + process? + (id process-id) ;integer + (parent process-parent-id) ;integer | #f + (command process-command)) ;list of strings + +(define (write-process process port) + (format port "#<process ~a>" (process-id process))) + +(set-record-type-printer! <process> write-process) + +(define (read-status-ppid port) + "Read the PPID from PORT, an input port on a /proc/PID/status file. Return +#f for PID 1 and kernel pseudo-processes." + (let loop () + (match (read-line port) + ((? eof-object?) #f) + (line + (if (string-prefix? "PPid:" line) + (string->number (string-trim-both (string-drop line 5))) + (loop)))))) + +(define %not-nul + (char-set-complement (char-set #\nul))) + +(define (read-command-line port) + "Read the zero-split command line from PORT, a /proc/PID/cmdline file, and +return it as a list." + (string-tokenize (read-string port) %not-nul)) + +(define (processes) + "Return a list of process records representing the currently alive +processes." + ;; This assumes a Linux-compatible /proc file system. There exists one for + ;; GNU/Hurd. + (filter-map (lambda (pid) + ;; There's a TOCTTOU race here. If we get ENOENT, simply + ;; ignore PID. + (catch 'system-error + (lambda () + (define ppid + (call-with-input-file (string-append "/proc/" pid "/status") + read-status-ppid)) + (define command + (call-with-input-file (string-append "/proc/" pid "/cmdline") + read-command-line)) + (process (string->number pid) ppid command)) + (lambda args + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args))))) + (scandir "/proc" string->number))) + +(define (process-open-files process) + "Return the list of files currently open by PROCESS." + (let ((directory (string-append "/proc/" + (number->string (process-id process)) + "/fd"))) + (map (lambda (fd) + (readlink (string-append directory "/" fd))) + (or (scandir directory string->number) '())))) + +;; Daemon session. +(define-record-type <daemon-session> + (daemon-session process client children locks) + daemon-session? + (process daemon-session-process) ;<process> + (client daemon-session-client) ;<process> + (children daemon-session-children) ;list of <process> + (locks daemon-session-locks-held)) ;list of strings + +(define (daemon-sessions) + "Return two values: the list of <daemon-session> denoting the currently +active sessions, and the master 'guix-daemon' process." + (define (lock-file? file) + (and (string-prefix? (%store-prefix) file) + (string-suffix? ".lock" file))) + + (let* ((processes (processes)) + (daemons (filter (lambda (process) + (match (process-command process) + ((argv0 _ ...) + (string=? (basename argv0) "guix-daemon")) + (_ #f))) + processes)) + (children (filter (lambda (process) + (match (process-command process) + ((argv0 (= string->number argv1) _ ...) + (integer? argv1)) + (_ #f))) + daemons)) + (master (remove (lambda (process) + (memq process children)) + daemons))) + (define (lookup-process pid) + (find (lambda (process) + (and (process-id process) + (= pid (process-id process)))) + processes)) + + (define (lookup-children pid) + (filter (lambda (process) + (and (process-parent-id process) + (= pid (process-parent-id process)))) + processes)) + + (values (map (lambda (process) + (match (process-command process) + ((argv0 (= string->number client) _ ...) + (let ((files (process-open-files process))) + (daemon-session process + (lookup-process client) + (lookup-children (process-id process)) + (filter lock-file? files)))))) + children) + master))) + +(define (daemon-session->recutils session port) + "Display SESSION information in recutils format on PORT." + (format port "SessionPID: ~a~%" + (process-id (daemon-session-process session))) + (format port "ClientPID: ~a~%" + (process-id (daemon-session-client session))) + (format port "ClientCommand:~{ ~a~}~%" + (process-command (daemon-session-client session))) + (for-each (lambda (lock) + (format port "LockHeld: ~a~%" lock)) + (daemon-session-locks-held session)) + (for-each (lambda (process) + (format port "ChildProcess: ~a:~{ ~a~}~%" + (process-id process) + (process-command process))) + (daemon-session-children session))) + + +;;; +;;; Options. +;;; + +(define %options + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix processes"))))) + +(define (show-help) + (display (G_ "Usage: guix processes +List the current Guix sessions and their processes.")) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + + +;;; +;;; Entry point. +;;; + +(define (guix-processes . args) + (define options + (args-fold* args %options + (lambda (opt name arg result) + (leave (G_ "~A: unrecognized option~%") name)) + cons + '())) + + (for-each (lambda (session) + (daemon-session->recutils session (current-output-port)) + (newline)) + (daemon-sessions))) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 2e37a19407..74c223b283 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -32,6 +32,7 @@ guix/scripts/copy.scm guix/scripts/pack.scm guix/scripts/weather.scm guix/scripts/describe.scm +guix/scripts/processes.scm guix/gnu-maintenance.scm guix/scripts/container.scm guix/scripts/container/exec.scm diff --git a/tests/processes.scm b/tests/processes.scm new file mode 100644 index 0000000000..40454bcbc7 --- /dev/null +++ b/tests/processes.scm @@ -0,0 +1,86 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (test-processes) + #:use-module (guix scripts processes) + #:use-module (guix store) + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module (guix gexp) + #:use-module ((guix utils) #:select (call-with-temporary-directory)) + #:use-module (gnu packages bootstrap) + #:use-module (guix tests) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (ice-9 match) + #:use-module (ice-9 threads)) + +(test-begin "processes") + +(test-assert "not a client" + (not (find (lambda (session) + (= (getpid) + (process-id (daemon-session-client session)))) + (daemon-sessions)))) + +(test-assert "client" + (with-store store + (let* ((session (find (lambda (session) + (= (getpid) + (process-id (daemon-session-client session)))) + (daemon-sessions))) + (daemon (daemon-session-process session))) + (and (kill (process-id daemon) 0) + (string-suffix? "guix-daemon" (first (process-command daemon))))))) + +(test-assert "client + lock" + (with-store store + (call-with-temporary-directory + (lambda (directory) + (let* ((token1 (string-append directory "/token1")) + (token2 (string-append directory "/token2")) + (exp #~(begin #$(random-text) + (mkdir #$token1) + (let loop () + (unless (file-exists? #$token2) + (sleep 1) + (loop))) + (mkdir #$output))) + (guile (package-derivation store %bootstrap-guile)) + (drv (run-with-store store + (gexp->derivation "foo" exp + #:guile-for-build guile))) + (thread (call-with-new-thread + (lambda () + (build-derivations store (list drv))))) + (_ (let loop () + (unless (file-exists? token1) + (usleep 200) + (loop)))) + (session (find (lambda (session) + (= (getpid) + (process-id (daemon-session-client session)))) + (daemon-sessions))) + (locks (daemon-session-locks-held (pk 'session session)))) + (call-with-output-file token2 (const #t)) + (equal? (list (string-append (derivation->output-path drv) ".lock")) + locks)))))) + +(test-end "processes") |