src/os/create-process-unix.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Wrapper over lfp_spawn(3)
   4 ;;;
   5
   6 (in-package :iolib.os)
   7
   8 (defun tty-read-fn (fd buf nbytes)
   9   (handler-case
  10       (isys:read fd buf nbytes)
  11     (isys:eio () 0)))
  12
  13 (defun tty-write-fn (fd buf nbytes)
  14   (handler-case
  15       (isys:write fd buf nbytes)
  16     (isys:eio ()
  17       (error 'isys:epipe
  18              :handle fd
  19              :syscall "write"))))
  20
  21 (defclass tty-stream (iolib.streams:dual-channel-gray-stream)
  22   ()
  23   (:default-initargs :read-fn  #'tty-read-fn
  24                      :write-fn #'tty-write-fn))
  25
  26 (defclass process ()
  27   ((pid    :initarg :pid :reader process-pid)
  28    (status :initform :running)
  29    (closed :initform nil)
  30    (stdin  :reader process-stdin)
  31    (stdout :reader process-stdout)
  32    (stderr :reader process-stderr)
  33    (pty    :reader process-pty)))
  34
  35 (defmethod initialize-instance :after ((process process) &key
  36                                        stdin stdout stderr tty external-format)
  37   (with-slots ((in stdin) (out stdout) (err stderr) pty)
  38       process
  39     (when stdin
  40       (setf in  (make-instance 'tty-stream :fd stdin
  41                                :external-format external-format)))
  42     (when stdout
  43       (setf out (make-instance 'tty-stream :fd stdout
  44                                :external-format external-format)))
  45     (when stderr
  46       (setf err (make-instance 'tty-stream :fd stderr
  47                                :external-format external-format)))
  48     (when tty
  49       (setf pty (make-instance 'tty-stream :fd tty
  50                                :external-format external-format)))))
  51
  52 (defmethod close ((process process) &key abort)
  53   (if (slot-value process 'closed)
  54       nil
  55       (macrolet ((close-process-stream (slot)
  56                    `(when (slot-boundp process ',slot)
  57                       (close (slot-value process ',slot) :abort abort)
  58                       (slot-makunbound process ',slot))))
  59         (close-process-stream stdin)
  60         (close-process-stream stdout)
  61         (close-process-stream stderr)
  62         (close-process-stream pty)
  63         (process-status process :wait (not abort))
  64         (setf (slot-value process 'closed) t)
  65         t)))
  66
  67 (defmethod print-object ((o process) s)
  68   (print-unreadable-object (o s :type t :identity nil)
  69     (format s "~S ~S ~S ~S"
  70             :pid (process-pid o)
  71             :status (process-status o))))
  72
  73 (defun exit-status (status)
  74   (cond
  75     ((isys:wifexited status)
  76      (isys:wexitstatus status))
  77     ((isys:wifsignaled status)
  78      (values (isys:wtermsig* status)
  79              (isys:wcoredump status)))))
  80
  81 (defgeneric process-status (process &key wait)
  82   (:method ((process process) &key wait)
  83     (if (integerp (slot-value process 'status))
  84         (exit-status (slot-value process 'status))
  85         (multiple-value-bind (pid status)
  86             (isys:waitpid (process-pid process)
  87                           (if wait 0 isys:wnohang))
  88           (cond
  89             ((zerop pid)
  90              :running)
  91             (t
  92              (setf (slot-value process 'status) status)
  93              (exit-status status)))))))
  94
  95 (defgeneric process-activep (process)
  96   (:method ((process process))
  97     (eql :running (process-status process))))
  98
  99 (defgeneric process-kill (process &optional signum)
 100   (:method ((process process) &optional (signum :sigterm))
 101     (isys:kill (process-pid process) signum)
 102     process))
 103 \f
 104
 105 (defmacro with-lfp-spawn-arguments ((attributes file-actions pid) &body body)
 106   (with-gensyms (spawnattr-initialized-p file-actions-initialized-p)
 107     `(with-foreign-objects ((,attributes 'lfp-spawnattr-t)
 108                             (,file-actions 'lfp-spawn-file-actions-t)
 109                             (,pid 'pid-t))
 110        (let ((,spawnattr-initialized-p nil)
 111              (,file-actions-initialized-p nil))
 112          (unwind-protect
 113               (progn
 114                 (setf ,spawnattr-initialized-p
 115                       (lfp-spawnattr-init ,attributes))
 116                 (setf ,file-actions-initialized-p
 117                       (lfp-spawn-file-actions-init ,file-actions))
 118                 ,@body)
 119            (when ,spawnattr-initialized-p
 120              (lfp-spawnattr-destroy ,attributes))
 121            (when ,file-actions-initialized-p
 122              (lfp-spawn-file-actions-destroy ,file-actions)))))))
 123
 124 (defun allocate-argv (argv program arglist)
 125   ;; copy program name
 126   (setf (mem-aref argv :pointer 0)
 127         (foreign-string-alloc program))
 128   ;; copy program arguments
 129   (loop :for i :from 1
 130         :for arg :in arglist :do
 131         (setf (mem-aref argv :pointer i)
 132               (foreign-string-alloc arg))))
 133
 134 (defun find-program (program)
 135   (cond
 136     ((eql :shell program)
 137      (list "/bin/sh" "-c"))
 138     (t
 139      (file-path-namestring program))))
 140
 141 (defmacro with-argv (((arg0 argv) program arguments) &body body)
 142   (with-gensyms (argc)
 143     `(let* ((,program (ensure-list (find-program ,program)))
 144             (arguments (append (cdr ,program) arguments))
 145             (,argc (+ 2 (length ,arguments))))
 146        (with-foreign-object (,argv :pointer ,argc)
 147          (isys:bzero ,argv (* ,argc (isys:sizeof :pointer)))
 148          (unwind-protect
 149               (progn
 150                 (allocate-argv ,argv (car ,program) ,arguments)
 151                 (let ((,arg0 (mem-ref ,argv :pointer)))
 152                   ,@body))
 153            (delocate-null-ended-list ,argv))))))
 154
 155 (defun redirect-one-stream (file-actions fd stream
 156                             &optional flags (mode #o644) close-old-fd)
 157   (flet ((dup-from-path (path)
 158            (lfp-spawn-file-actions-addopen file-actions fd path flags mode))
 159          (dup-from-fd (oldfd)
 160            (lfp-spawn-file-actions-adddup2 file-actions oldfd fd)
 161            (when close-old-fd
 162              (lfp-spawn-file-actions-addclose file-actions oldfd))))
 163     (etypecase stream
 164       ((eql t) nil)
 165       ((or string file-path pathname)
 166        (dup-from-path (file-path-namestring stream)))
 167       ((eql :null)
 168        (dup-from-path "/dev/null"))
 169       (unsigned-byte
 170        (dup-from-fd stream))
 171       (iolib.streams:dual-channel-fd-mixin
 172        (dup-from-fd (iolib.streams:fd-of stream)))
 173       (null
 174        (lfp-spawn-file-actions-addclose file-actions fd)))))
 175
 176 (defun redirect-to-pipes (file-actions fd keep-write-fd)
 177   (multiple-value-bind (pipe-parent pipe-child)
 178       (isys:pipe)
 179     (when keep-write-fd (rotatef pipe-parent pipe-child))
 180     (lfp-spawn-file-actions-adddup2 file-actions pipe-child fd)
 181     (lfp-spawn-file-actions-addclose file-actions pipe-parent)
 182     (lfp-spawn-file-actions-addclose file-actions pipe-child)
 183     (values pipe-parent pipe-child)))
 184
 185 (defun setup-redirections (file-actions stdin stdout stderr ptmfd pts)
 186   (let (infd infd-child outfd outfd-child errfd errfd-child)
 187     ;; Standard input
 188     (case stdin
 189       (:pipe
 190        (setf (values infd infd-child)
 191              (redirect-to-pipes file-actions +stdin+ t)))
 192       (:pty
 193        (setf infd (isys:dup ptmfd))
 194        (redirect-one-stream file-actions +stdin+ pts isys:o-rdonly))
 195       (t (redirect-one-stream file-actions +stdin+ stdin isys:o-rdonly)))
 196     ;; Standard output
 197     (case stdout
 198       (:pipe
 199        (setf (values outfd outfd-child)
 200              (redirect-to-pipes file-actions +stdout+ nil)))
 201       (:pty
 202        (setf outfd (isys:dup ptmfd))
 203        (redirect-one-stream file-actions +stdout+ pts (logior isys:o-wronly
 204                                                               isys:o-creat)))
 205       (t (redirect-one-stream file-actions +stdout+ stdout (logior isys:o-wronly
 206                                                                    isys:o-creat))))
 207     ;; Standard error
 208     (case stderr
 209       (:pipe
 210        (setf (values errfd errfd-child)
 211              (redirect-to-pipes file-actions +stderr+ nil)))
 212       (:pty
 213        (setf errfd (isys:dup ptmfd))
 214        (redirect-one-stream file-actions +stderr+ pts (logior isys:o-wronly
 215                                                               isys:o-creat)))
 216       (t (redirect-one-stream file-actions +stderr+ stderr (logior isys:o-wronly
 217                                                                    isys:o-creat))))
 218     (values infd infd-child outfd outfd-child errfd errfd-child)))
 219
 220 (defun close-fds (&rest fds)
 221   (dolist (fd fds)
 222     (when fd (isys:close fd))))
 223
 224 (defun setup-slave-pty (new-ctty-p)
 225   (if new-ctty-p
 226       (let ((ptmfd (isys:openpt (logior isys:o-rdwr isys:o-noctty isys:o-cloexec))))
 227         (isys:grantpt ptmfd)
 228         (isys:unlockpt ptmfd)
 229         (values ptmfd (isys:ptsname ptmfd)))
 230       (values nil nil)))
 231
 232 (defmacro with-pty ((new-ctty-p ptmfd pts) &body body)
 233   `(multiple-value-bind (,ptmfd ,pts)
 234        (setup-slave-pty ,new-ctty-p)
 235      (unwind-protect
 236           (locally ,@body)
 237        (unless ,new-ctty-p
 238          (close-fds ,ptmfd)))))
 239
 240 (defmacro with-redirections (((infd outfd errfd)
 241                               (file-actions stdin stdout stderr ptyfd pts))
 242                              &body body)
 243   (with-gensyms (infd-child outfd-child errfd-child)
 244     `(multiple-value-bind (,infd ,infd-child ,outfd ,outfd-child ,errfd ,errfd-child)
 245          (setup-redirections ,file-actions ,stdin ,stdout ,stderr ,ptyfd ,pts)
 246        (unwind-protect-case ()
 247            (locally ,@body)
 248          (:always
 249           (close-fds ,infd-child ,outfd-child ,errfd-child))
 250          (:abort
 251           (close-fds ,infd ,outfd ,errfd))))))
 252
 253 (defun process-other-spawn-args (attributes new-session pts current-directory
 254                                  uid gid resetids)
 255   (when new-session
 256     (lfp-spawnattr-setsid attributes))
 257   (when pts
 258     (lfp-spawnattr-setctty attributes pts))
 259   (when current-directory
 260     (lfp-spawnattr-setcwd attributes current-directory))
 261   (when uid
 262     (lfp-spawnattr-setuid attributes uid))
 263   (when gid
 264     (lfp-spawnattr-setgid attributes gid))
 265   (when resetids
 266     (lfp-spawnattr-setflags attributes lfp-spawn-resetids)))
 267
 268 ;; program: :shell - the system shell
 269 ;;          file-path designator - a path
 270 ;; arguments: list
 271 ;; environment: t - inherit environment
 272 ;;              nil - NULL environment
 273 ;;              alist - the environment to use
 274 ;; stdin, stdout, stderr:
 275 ;;         file-path designator - open file, redirect to it
 276 ;;         :null - redirect to /dev/null - useful because /dev/null doesn't exist on Windows
 277 ;;         file-descriptor designator(integer or stream) - file descriptor, redirecto to it
 278 ;;         :pipe - create pipe, redirect the child descriptor to one end and wrap the other end
 279 ;;                 into a stream which goes into PROCESS slot
 280 ;;         t - inherit
 281 ;;         nil - close
 282 ;; pty: boolean - spawn a new controlling tty. it is also implicitly T if
 283 ;;                either stdin, stdout or stderr is :pty
 284 ;; new-session: boolean - create a new session using setsid(). it is also implicitly T
 285 ;;                        if a PTY is requested
 286 ;; current-directory: path - a directory to switch to before executing
 287 ;; uid: user id - unsigned-byte or string
 288 ;; gid: group id - unsigned-byte or string
 289 ;; resetids: boolean - reset effective UID and GID to saved IDs
 290
 291 (defun create-process (program-and-args &key (environment t)
 292                        (stdin :pipe) (stdout :pipe) (stderr :pipe) pty
 293                        new-session current-directory uid gid resetids
 294                        (external-format :utf-8))
 295   (let ((new-ctty-p
 296            (or pty
 297                (eql :pty stdin)
 298                (eql :pty stdout)
 299                (eql :pty stderr))))
 300     (destructuring-bind (program &rest arguments)
 301         (ensure-list program-and-args)
 302       (with-argv ((arg0 argv) program arguments)
 303         (with-c-environment (envp environment)
 304           (with-lfp-spawn-arguments (attributes file-actions pid)
 305             (with-pty (new-ctty-p ptyfd pts)
 306               (with-redirections ((infd outfd errfd)
 307                                   (file-actions stdin stdout stderr ptyfd pts))
 308                 (process-other-spawn-args attributes
 309                                           new-session pts
 310                                           current-directory
 311                                           uid gid resetids)
 312                 (lfp-spawnp pid arg0 argv envp file-actions attributes)
 313                 (make-instance 'process :pid (mem-ref pid 'pid-t)
 314                                :stdin infd :stdout outfd :stderr errfd :tty ptyfd
 315                                :external-format external-format)))))))))
 316
 317 (defun slurp-char-stream (stream)
 318   (with-output-to-string (s)
 319     (loop :for c := (read-char stream nil nil)
 320           :while c :do (write-char c s))))
 321
 322 (defun slurp-octet-stream (stream)
 323   (let ((dynbuffer (make-instance 'dynamic-buffer :size 4096 :growth-size 2))
 324         (iobuffer (make-array 4096 :element-type '(unsigned-byte 8))))
 325     (handler-case
 326         (loop :for pos := (read-sequence iobuffer stream)
 327               :while (plusp pos) :do
 328           (write-vector dynbuffer iobuffer 0 pos))
 329       (end-of-file () nil))
 330     (subseq (sequence-of dynbuffer)
 331             (read-cursor-of dynbuffer)
 332             (write-cursor-of dynbuffer))))
 333
 334 (defun run-program (program-and-args &key (environment t)
 335                     (stdin :null) (stdout :pipe) (stderr :pipe)
 336                     (external-format :utf-8))
 337   (flet ((slurp (stream)
 338            (if external-format
 339                (slurp-char-stream stream)
 340                (slurp-octet-stream stream)))
 341          (make-empty-output ()
 342            (if external-format
 343                (make-array 0 :element-type 'character)
 344                (make-array 0 :element-type '(unsigned-byte 8)))))
 345     (let ((process
 346             (create-process program-and-args
 347                             :environment environment
 348                             :stdin stdin
 349                             :stdout stdout
 350                             :stderr stderr
 351                             :external-format external-format)))
 352       (unwind-protect
 353            (let ((stdout (if (eql :pipe stdout)
 354                              (slurp (process-stdout process))
 355                              (make-empty-output)))
 356                  (stderr (if (eql :pipe stderr)
 357                              (slurp (process-stderr process))
 358                              (make-empty-output))))
 359              (values (process-status process :wait t)
 360                      stdout stderr))
 361         (close process)))))