From patchwork Fri Oct 26 09:42:22 2018 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 30 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 8AED916762; Fri, 26 Oct 2018 10:44:08 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-6.9 required=5.0 tests=BAYES_00,RCVD_IN_DNSWL_HI, URIBL_BLOCKED autolearn=ham autolearn_force=no version=3.4.0 Received: from lists.gnu.org (lists.gnu.org [IPv6:2001:4830:134:3::11]) by mira.cbaines.net (Postfix) with ESMTPS id 9C34616760 for ; Fri, 26 Oct 2018 10:44:07 +0100 (BST) Received: from localhost ([::1]:59168 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1gFyf0-0006mo-BX for patchwork@mira.cbaines.net; Fri, 26 Oct 2018 05:44:06 -0400 Received: from eggs.gnu.org ([2001:4830:134:3::10]:51969) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1gFye1-0005gZ-FJ for guix-patches@gnu.org; Fri, 26 Oct 2018 05:43:07 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1gFydy-0000H9-6K for guix-patches@gnu.org; Fri, 26 Oct 2018 05:43:05 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:38930) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1gFydx-0000H3-Ui for guix-patches@gnu.org; Fri, 26 Oct 2018 05:43:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1gFydx-0003B7-Nu for guix-patches@gnu.org; Fri, 26 Oct 2018 05:43:01 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#33161] [PATCH 1/1] Add 'guix processes'. References: <20181026092512.28810-1-ludo@gnu.org> In-Reply-To: <20181026092512.28810-1-ludo@gnu.org> Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 26 Oct 2018 09:43:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 33161 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 33161@debbugs.gnu.org Received: via spool by 33161-submit@debbugs.gnu.org id=B33161.154054697312203 (code B ref 33161); Fri, 26 Oct 2018 09:43:01 +0000 Received: (at 33161) by debbugs.gnu.org; 26 Oct 2018 09:42:53 +0000 Received: from localhost ([127.0.0.1]:43188 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1gFydo-0003Al-Au for submit@debbugs.gnu.org; Fri, 26 Oct 2018 05:42:52 -0400 Received: from eggs.gnu.org ([208.118.235.92]:42288) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1gFydm-0003AY-Cv for 33161@debbugs.gnu.org; Fri, 26 Oct 2018 05:42:51 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1gFydf-00086Q-16 for 33161@debbugs.gnu.org; Fri, 26 Oct 2018 05:42:45 -0400 Received: from fencepost.gnu.org ([2001:4830:134:3::e]:44703) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1gFydU-0007iv-SE; Fri, 26 Oct 2018 05:42:36 -0400 Received: from dhcp-64-177.ens-lyon.fr ([140.77.64.177]:58052 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1gFydS-0001jv-2g; Fri, 26 Oct 2018 05:42:31 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Fri, 26 Oct 2018 11:42:22 +0200 Message-Id: <20181026094222.29185-1-ludo@gnu.org> X-Mailer: git-send-email 2.19.1 MIME-Version: 1.0 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 208.118.235.43 X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * guix/scripts/processes.scm, tests/processes.scm: New files. * Makefile.am (MODULES): Add the former. (SCM_TESTS): Add the latter. * po/guix/POTFILES.in: Add guix/scripts/processes.scm. * doc/guix.texi (Invoking guix processes): New node. --- Makefile.am | 2 + doc/guix.texi | 56 ++++++++++ guix/scripts/processes.scm | 223 +++++++++++++++++++++++++++++++++++++ po/guix/POTFILES.in | 1 + tests/processes.scm | 86 ++++++++++++++ 5 files changed, 368 insertions(+) create mode 100644 guix/scripts/processes.scm create mode 100644 tests/processes.scm diff --git a/Makefile.am b/Makefile.am index 7fd29b90a8..c7171d8f5d 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 12346c4b8e..214e65a07e 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -193,6 +193,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} @@ -6051,6 +6052,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 @@ -8751,6 +8753,60 @@ 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 Guix sessions (connections to the daemon), as well as information +about the processes involved. 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 +;;; +;;; 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 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 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-id process))) + +(set-record-type-printer! 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 process client children locks) + daemon-session? + (process daemon-session-process) ; + (client daemon-session-client) ; + (children daemon-session-children) ;list of + (locks daemon-session-locks-held)) ;list of strings + +(define (daemon-sessions) + "Return two values: the list of 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 +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (test-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")