guix/scripts/processes.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix scripts processes)
  20   #:use-module ((guix store) #:select (%store-prefix))
  21   #:use-module (guix scripts)
  22   #:use-module (guix ui)
  23   #:use-module (srfi srfi-1)
  24   #:use-module (srfi srfi-9)
  25   #:use-module (srfi srfi-9 gnu)
  26   #:use-module (srfi srfi-37)
  27   #:use-module (ice-9 ftw)
  28   #:use-module (ice-9 match)
  29   #:use-module (ice-9 rdelim)
  30   #:use-module (ice-9 format)
  31   #:export (process?
  32             process-id
  33             process-parent-id
  34             process-command
  35             processes
  36
  37             daemon-session?
  38             daemon-session-process
  39             daemon-session-client
  40             daemon-session-children
  41             daemon-session-locks-held
  42             daemon-sessions
  43
  44             guix-processes))
  45
  46 ;; Process as can be found in /proc on GNU/Linux.
  47 (define-record-type <process>
  48   (process id parent command)
  49   process?
  50   (id       process-id)                           ;integer
  51   (parent   process-parent-id)                    ;integer | #f
  52   (command  process-command))                     ;list of strings
  53
  54 (define (write-process process port)
  55   (format port "#<process ~a>" (process-id process)))
  56
  57 (set-record-type-printer! <process> write-process)
  58
  59 (define (read-status-ppid port)
  60   "Read the PPID from PORT, an input port on a /proc/PID/status file.  Return
  61 #f for PID 1 and kernel pseudo-processes."
  62   (let loop ()
  63     (match (read-line port)
  64       ((? eof-object?) #f)
  65       (line
  66        (if (string-prefix? "PPid:" line)
  67            (string->number (string-trim-both (string-drop line 5)))
  68            (loop))))))
  69
  70 (define %not-nul
  71   (char-set-complement (char-set #\nul)))
  72
  73 (define (read-command-line port)
  74   "Read the zero-split command line from PORT, a /proc/PID/cmdline file, and
  75 return it as a list."
  76   (string-tokenize (read-string port) %not-nul))
  77
  78 (define (processes)
  79   "Return a list of process records representing the currently alive
  80 processes."
  81   ;; This assumes a Linux-compatible /proc file system.  There exists one for
  82   ;; GNU/Hurd.
  83   (filter-map (lambda (pid)
  84                 ;; There's a TOCTTOU race here.  If we get ENOENT, simply
  85                 ;; ignore PID.
  86                 (catch 'system-error
  87                   (lambda ()
  88                     (define ppid
  89                       (call-with-input-file (string-append "/proc/" pid "/status")
  90                         read-status-ppid))
  91                     (define command
  92                       (call-with-input-file (string-append "/proc/" pid "/cmdline")
  93                         read-command-line))
  94                     (process (string->number pid) ppid command))
  95                   (lambda args
  96                     (if (= ENOENT (system-error-errno args))
  97                         #f
  98                         (apply throw args)))))
  99               (scandir "/proc" string->number)))
 100
 101 (define (process-open-files process)
 102   "Return the list of files currently open by PROCESS."
 103   (let ((directory (string-append "/proc/"
 104                                   (number->string (process-id process))
 105                                   "/fd")))
 106     (filter-map (lambda (fd)
 107                   ;; There's a TOCTTOU race here, hence the 'catch'.
 108                   (catch 'system-error
 109                     (lambda ()
 110                       (readlink (string-append directory "/" fd)))
 111                     (lambda args
 112                       (if (= ENOENT (system-error-errno args))
 113                           #f
 114                           (apply throw args)))))
 115                 (or (scandir directory string->number) '()))))
 116
 117 ;; Daemon session.
 118 (define-record-type <daemon-session>
 119   (daemon-session process client children locks)
 120   daemon-session?
 121   (process    daemon-session-process)             ;<process>
 122   (client     daemon-session-client)              ;<process>
 123   (children   daemon-session-children)            ;list of <process>
 124   (locks      daemon-session-locks-held))         ;list of strings
 125
 126 (define (daemon-sessions)
 127   "Return two values: the list of <daemon-session> denoting the currently
 128 active sessions, and the master 'guix-daemon' process."
 129   (define (lock-file? file)
 130     (and (string-prefix? (%store-prefix) file)
 131          (string-suffix? ".lock" file)))
 132
 133   (let* ((processes (processes))
 134          (daemons   (filter (lambda (process)
 135                               (match (process-command process)
 136                                 ((argv0 _ ...)
 137                                  (string=? (basename argv0) "guix-daemon"))
 138                                 (_ #f)))
 139                             processes))
 140          (children  (filter (lambda (process)
 141                               (match (process-command process)
 142                                 ((argv0 (= string->number argv1) _ ...)
 143                                  (integer? argv1))
 144                                 (_ #f)))
 145                             daemons))
 146          (master    (remove (lambda (process)
 147                               (memq process children))
 148                             daemons)))
 149     (define (lookup-process pid)
 150       (find (lambda (process)
 151               (and (process-id process)
 152                    (= pid (process-id process))))
 153             processes))
 154
 155     (define (lookup-children pid)
 156       (filter (lambda (process)
 157                 (and (process-parent-id process)
 158                      (= pid (process-parent-id process))))
 159               processes))
 160
 161     (define (child-process->session process)
 162       (match (process-command process)
 163         ((argv0 (= string->number client) _ ...)
 164          (let ((files  (process-open-files process))
 165                (client (lookup-process client)))
 166            ;; After a client has died, there's a window during which its
 167            ;; corresponding 'guix-daemon' process is still alive, in which
 168            ;; case 'lookup-process' returns #f.  In that case ignore the
 169            ;; session.
 170            (and client
 171                 (daemon-session process client
 172                                 (lookup-children
 173                                  (process-id process))
 174                                 (filter lock-file? files)))))))
 175
 176     (values (filter-map child-process->session children)
 177             master)))
 178
 179 (define (daemon-session->recutils session port)
 180   "Display SESSION information in recutils format on PORT."
 181   (format port "SessionPID: ~a~%"
 182           (process-id (daemon-session-process session)))
 183   (format port "ClientPID: ~a~%"
 184           (process-id (daemon-session-client session)))
 185   (format port "ClientCommand:~{ ~a~}~%"
 186           (process-command (daemon-session-client session)))
 187   (for-each (lambda (lock)
 188               (format port "LockHeld: ~a~%" lock))
 189             (daemon-session-locks-held session))
 190   (for-each (lambda (process)
 191               (format port "ChildProcess: ~a:~{ ~a~}~%"
 192                       (process-id process)
 193                       (process-command process)))
 194             (daemon-session-children session)))
 195
 196 \f
 197 ;;;
 198 ;;; Options.
 199 ;;;
 200
 201 (define %options
 202   (list (option '(#\h "help") #f #f
 203                 (lambda args
 204                   (show-help)
 205                   (exit 0)))
 206         (option '(#\V "version") #f #f
 207                 (lambda args
 208                   (show-version-and-exit "guix processes")))))
 209
 210 (define (show-help)
 211   (display (G_ "Usage: guix processes
 212 List the current Guix sessions and their processes."))
 213   (newline)
 214   (display (G_ "
 215   -h, --help             display this help and exit"))
 216   (display (G_ "
 217   -V, --version          display version information and exit"))
 218   (newline)
 219   (show-bug-report-information))
 220
 221 \f
 222 ;;;
 223 ;;; Entry point.
 224 ;;;
 225
 226 (define (guix-processes . args)
 227   (define options
 228     (args-fold* args %options
 229                 (lambda (opt name arg result)
 230                   (leave (G_ "~A: unrecognized option~%") name))
 231                 cons
 232                 '()))
 233
 234   (for-each (lambda (session)
 235               (daemon-session->recutils session (current-output-port))
 236               (newline))
 237             (daemon-sessions)))