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
  34 (defmethod initialize-instance :after ((process process) &key
  35                                        stdin stdout stderr external-format)
  36   (with-slots ((in stdin) (out stdout) (err stderr))
  37       process
  38     (when stdin
  39       (setf in  (make-instance 'tty-stream :fd stdin
  40                                :external-format external-format)))
  41     (when stdout
  42       (setf out (make-instance 'tty-stream :fd stdout
  43                                :external-format external-format)))
  44     (when stderr
  45       (setf err (make-instance 'tty-stream :fd stderr
  46                                :external-format external-format)))))
  47
  48 (defmethod close ((process process) &key abort)
  49   (if (slot-value process 'closed)
  50       nil
  51       (macrolet ((close-process-stream (slot)
  52                    `(when (slot-boundp process ',slot)
  53                       (close (slot-value process ',slot) :abort abort)
  54                       (slot-makunbound process ',slot))))
  55         (close-process-stream stdin)
  56         (close-process-stream stdout)
  57         (close-process-stream stderr)
  58         (process-status process :wait (not abort))
  59         (setf (slot-value process 'closed) t)
  60         t)))
  61
  62 (defmethod print-object ((o process) s)
  63   (print-unreadable-object (o s :type t :identity t)
  64     (format s "~S ~S ~S ~S"
  65             :pid (process-pid o)
  66             :status (process-status o))))
  67
  68 (defun exit-status (status)
  69   (cond
  70     ((isys:wifexited status)
  71      (isys:wexitstatus status))
  72     ((isys:wifsignaled status)
  73      (values (isys:wtermsig* status)
  74              (isys:wcoredump status)))))
  75
  76 (defmethod process-status ((process process) &key wait)
  77   (if (integerp (slot-value process 'status))
  78       (exit-status (slot-value process 'status))
  79       (multiple-value-bind (pid status)
  80           (isys:waitpid (process-pid process)
  81                         (if wait 0 isys:wnohang))
  82         (cond
  83           ((zerop pid)
  84            :running)
  85           (t
  86            (setf (slot-value process 'status) status)
  87            (exit-status status))))))
  88
  89 (defmethod process-activep ((process process))
  90   (eql :running (process-status process)))
  91
  92 (defmethod process-kill ((process process) &optional (signum :sigterm))
  93   (isys:kill (process-pid process) signum)
  94   process)
  95 \f
  96
  97 (defmacro with-lfp-spawn-arguments ((attributes file-actions pid) &body body)
  98   (with-gensyms (spawnattr-initialized-p file-actions-initialized-p)
  99     `(with-foreign-objects ((,attributes 'lfp-spawnattr-t)
 100                             (,file-actions 'lfp-spawn-file-actions-t)
 101                             (,pid 'pid-t))
 102        (let ((,spawnattr-initialized-p nil)
 103              (,file-actions-initialized-p nil))
 104          (unwind-protect
 105               (progn
 106                 (setf ,spawnattr-initialized-p
 107                       (lfp-spawnattr-init ,attributes))
 108                 (setf ,file-actions-initialized-p
 109                       (lfp-spawn-file-actions-init ,file-actions))
 110                 ,@body)
 111            (when ,spawnattr-initialized-p
 112              (lfp-spawnattr-destroy ,attributes))
 113            (when ,file-actions-initialized-p
 114              (lfp-spawn-file-actions-destroy ,file-actions)))))))
 115
 116 (defun allocate-argv (argv program arglist)
 117   ;; copy program name
 118   (setf (mem-aref argv :pointer 0)
 119         (foreign-string-alloc program))
 120   ;; copy program arguments
 121   (loop :for i :from 1
 122         :for arg :in arglist :do
 123         (setf (mem-aref argv :pointer i)
 124               (foreign-string-alloc arg))))
 125
 126 (defun find-program (program)
 127   (cond
 128     ((eql :shell program)
 129      "/bin/sh")
 130     (t
 131      (file-path-namestring program))))
 132
 133 (defmacro with-argv (((arg0 argv) program arguments) &body body)
 134   (with-gensyms (argc)
 135     `(let ((,program (find-program ,program))
 136            (,argc (+ 2 (length ,arguments))))
 137        (with-foreign-object (,argv :pointer ,argc)
 138          (isys:bzero ,argv (* ,argc (isys:sizeof :pointer)))
 139          (unwind-protect
 140               (progn
 141                 (allocate-argv ,argv ,program ,arguments)
 142                 (let ((,arg0 (mem-ref ,argv :pointer)))
 143                   ,@body))
 144            (deallocate-null-ended-list ,argv))))))
 145
 146 (defun redirect-one-stream (file-actions fd stream &optional flags (mode #o644) close-old-fd)
 147   (flet ((dup-from-path (path)
 148            (lfp-spawn-file-actions-addopen file-actions fd path flags mode))
 149          (dup-from-fd (oldfd)
 150            (lfp-spawn-file-actions-adddup2 file-actions oldfd fd)
 151            (when close-old-fd
 152              (lfp-spawn-file-actions-addclose file-actions oldfd))))
 153     (etypecase stream
 154       ((eql t) nil)
 155       ((or string file-path pathname)
 156        (dup-from-path (file-path-namestring stream)))
 157       ((eql :null)
 158        (dup-from-path "/dev/null"))
 159       (unsigned-byte
 160        (dup-from-fd stream))
 161       (iolib.streams:dual-channel-fd-mixin
 162        (dup-from-fd (iolib.streams:fd-of stream)))
 163       (null
 164        (lfp-spawn-file-actions-addclose file-actions fd)))))
 165
 166 (defun redirect-to-pipes (file-actions fd keep-write-fd)
 167   (multiple-value-bind (pipe-parent pipe-child)
 168       (isys:pipe)
 169     (when keep-write-fd (rotatef pipe-parent pipe-child))
 170     (lfp-spawn-file-actions-adddup2 file-actions pipe-child fd)
 171     (lfp-spawn-file-actions-addclose file-actions pipe-parent)
 172     (lfp-spawn-file-actions-addclose file-actions pipe-child)
 173     (values pipe-parent pipe-child)))
 174
 175 (defun setup-redirections (file-actions stdin stdout stderr ptmfd pts)
 176   (let (infd infd-child outfd outfd-child errfd errfd-child)
 177     ;; Standard input
 178     (case stdin
 179       (:pipe
 180        (setf (values infd infd-child)
 181              (redirect-to-pipes file-actions +stdin+ t)))
 182       (:pty
 183        (setf infd (isys:dup ptmfd))
 184        (redirect-one-stream file-actions +stdin+ pts isys:o-rdonly))
 185       (t (redirect-one-stream file-actions +stdin+ stdin isys:o-rdonly)))
 186     ;; Standard output
 187     (case stdout
 188       (:pipe
 189        (setf (values outfd outfd-child)
 190              (redirect-to-pipes file-actions +stdout+ nil)))
 191       (:pty
 192        (setf outfd (isys:dup ptmfd))
 193        (redirect-one-stream file-actions +stdout+ pts (logior isys:o-wronly
 194                                                               isys:o-creat)))
 195       (t (redirect-one-stream file-actions +stdout+ stdout (logior isys:o-wronly
 196                                                                    isys:o-creat))))
 197     ;; Standard error
 198     (case stderr
 199       (:pipe
 200        (setf (values errfd errfd-child)
 201              (redirect-to-pipes file-actions +stderr+ nil)))
 202       (:pty
 203        (setf errfd (isys:dup ptmfd))
 204        (redirect-one-stream file-actions +stderr+ pts (logior isys:o-wronly
 205                                                               isys:o-creat)))
 206       (t (redirect-one-stream file-actions +stderr+ stderr (logior isys:o-wronly
 207                                                                    isys:o-creat))))
 208     (values infd infd-child outfd outfd-child errfd errfd-child)))
 209
 210 (defun close-fds (&rest fds)
 211   (dolist (fd fds)
 212     (when fd (isys:close fd))))
 213
 214 (defun setup-slave-pty ()
 215   (let ((ptmfd (isys:openpt (logior isys:o-rdwr isys:o-noctty isys:o-cloexec))))
 216     (isys:grantpt ptmfd)
 217     (isys:unlockpt ptmfd)
 218     (values ptmfd (isys:ptsname ptmfd))))
 219
 220 (defmacro with-pty ((ptmfd pts) &body body)
 221   `(multiple-value-bind (,ptmfd ,pts)
 222        (setup-slave-pty)
 223      (unwind-protect
 224           (locally ,@body)
 225        (close-fds ,ptmfd))))
 226
 227 (defmacro with-redirections (((infd outfd errfd)
 228                               (file-actions stdin stdout stderr))
 229                              &body body)
 230   (with-gensyms (infd-child outfd-child errfd-child ptmfd pts)
 231     `(with-pty (,ptmfd ,pts)
 232        (multiple-value-bind (,infd ,infd-child ,outfd ,outfd-child ,errfd ,errfd-child)
 233            (setup-redirections ,file-actions ,stdin ,stdout ,stderr ,ptmfd ,pts)
 234          (unwind-protect-case ()
 235              (locally ,@body)
 236            (:always
 237             (close-fds ,infd-child ,outfd-child ,errfd-child))
 238            (:abort
 239             (close-fds ,infd ,outfd ,errfd)))))))
 240
 241 (defun process-other-spawn-args (attributes new-session current-directory
 242                                  uid gid resetids)
 243   (when new-session
 244     (lfp-spawnattr-setsid attributes))
 245   (when current-directory
 246     (lfp-spawnattr-setcwd attributes current-directory))
 247   (when uid
 248     (lfp-spawnattr-setuid attributes uid))
 249   (when gid
 250     (lfp-spawnattr-setgid attributes gid))
 251   (when resetids
 252     (lfp-spawnattr-setflags attributes lfp-spawn-resetids)))
 253
 254 ;; program: :shell - the system shell
 255 ;;          file-path designator - a path
 256 ;; arguments: list
 257 ;; environment: t - inherit environment
 258 ;;              nil - NULL environment
 259 ;;              alist - the environment to use
 260 ;; stdin, stdout, stderr:
 261 ;;         file-path designator - open file, redirect to it
 262 ;;         :null - redirect to /dev/null - useful because /dev/null doesn't exist on Windows
 263 ;;         file-descriptor designator(integer or stream) - file descriptor, redirecto to it
 264 ;;         :pipe - create pipe, redirect the child descriptor to one end and wrap the other end
 265 ;;                 into a stream which goes into PROCESS slot
 266 ;;         t - inherit
 267 ;;         nil - close
 268 ;; new-session: boolean - create a new session using setsid()
 269 ;; current-directory: path - a directory to switch to before executing
 270 ;; uid: user id - unsigned-byte or string
 271 ;; gid: group id - unsigned-byte or string
 272 ;; resetids: boolean - reset effective UID and GID to saved IDs
 273
 274 (defun create-process (program-and-args &key (environment t)
 275                        (stdin :pipe) (stdout :pipe) (stderr :pipe)
 276                        new-session current-directory uid gid resetids
 277                        (external-format :utf-8))
 278   (flet ((new-ctty-p (stdin stdout stderr)
 279            (or (eql :pty stdin)
 280                (eql :pty stdout)
 281                (eql :pty stderr))))
 282     (destructuring-bind (program &rest arguments)
 283         (ensure-list program-and-args)
 284       (when (new-ctty-p stdin stdout stderr)
 285         (setf new-session t))
 286       (with-argv ((arg0 argv) program arguments)
 287         (with-c-environment (envp environment)
 288           (with-lfp-spawn-arguments (attributes file-actions pid)
 289             (with-redirections ((infd outfd errfd)
 290                                 (file-actions stdin stdout stderr))
 291               (process-other-spawn-args attributes new-session current-directory
 292                                         uid gid resetids)
 293               (lfp-spawnp pid arg0 argv envp file-actions attributes)
 294               (make-instance 'process :pid (mem-ref pid 'pid-t)
 295                              :stdin infd :stdout outfd :stderr errfd
 296                              :external-format external-format))))))))
 297
 298 (defun run-program (program-and-args &key (environment t) (stderr :pipe)
 299                     (external-format :utf-8))
 300   (flet ((slurp (stream)
 301            (with-output-to-string (s)
 302              (loop :for c := (read-char stream nil nil)
 303                    :while c :do (write-char c s)))))
 304     (let ((process (create-process program-and-args
 305                                    :environment environment
 306                                    :stdin nil
 307                                    :stdout :pipe
 308                                    :stderr stderr
 309                                    :external-format external-format)))
 310       (unwind-protect
 311            (values (process-status process :wait t)
 312                    (slurp (process-stdout process))
 313                    (if (eql :pipe stderr)
 314                        (slurp (process-stderr process))
 315                        (make-string 0)))
 316         (close process)))))