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            (delocate-null-ended-list ,argv))))))
 145
 146 (defun redirect-one-stream (file-actions fd stream
 147                             &optional flags (mode #o644) close-old-fd)
 148   (flet ((dup-from-path (path)
 149            (lfp-spawn-file-actions-addopen file-actions fd path flags mode))
 150          (dup-from-fd (oldfd)
 151            (lfp-spawn-file-actions-adddup2 file-actions oldfd fd)
 152            (when close-old-fd
 153              (lfp-spawn-file-actions-addclose file-actions oldfd))))
 154     (etypecase stream
 155       ((eql t) nil)
 156       ((or string file-path pathname)
 157        (dup-from-path (file-path-namestring stream)))
 158       ((eql :null)
 159        (dup-from-path "/dev/null"))
 160       (unsigned-byte
 161        (dup-from-fd stream))
 162       (iolib.streams:dual-channel-fd-mixin
 163        (dup-from-fd (iolib.streams:fd-of stream)))
 164       (null
 165        (lfp-spawn-file-actions-addclose file-actions fd)))))
 166
 167 (defun redirect-to-pipes (file-actions fd keep-write-fd)
 168   (multiple-value-bind (pipe-parent pipe-child)
 169       (isys:pipe)
 170     (when keep-write-fd (rotatef pipe-parent pipe-child))
 171     (lfp-spawn-file-actions-adddup2 file-actions pipe-child fd)
 172     (lfp-spawn-file-actions-addclose file-actions pipe-parent)
 173     (lfp-spawn-file-actions-addclose file-actions pipe-child)
 174     (values pipe-parent pipe-child)))
 175
 176 (defun setup-redirections (file-actions stdin stdout stderr ptmfd pts)
 177   (let (infd infd-child outfd outfd-child errfd errfd-child)
 178     ;; Standard input
 179     (case stdin
 180       (:pipe
 181        (setf (values infd infd-child)
 182              (redirect-to-pipes file-actions +stdin+ t)))
 183       (:pty
 184        (setf infd (isys:dup ptmfd))
 185        (redirect-one-stream file-actions +stdin+ pts isys:o-rdonly))
 186       (t (redirect-one-stream file-actions +stdin+ stdin isys:o-rdonly)))
 187     ;; Standard output
 188     (case stdout
 189       (:pipe
 190        (setf (values outfd outfd-child)
 191              (redirect-to-pipes file-actions +stdout+ nil)))
 192       (:pty
 193        (setf outfd (isys:dup ptmfd))
 194        (redirect-one-stream file-actions +stdout+ pts (logior isys:o-wronly
 195                                                               isys:o-creat)))
 196       (t (redirect-one-stream file-actions +stdout+ stdout (logior isys:o-wronly
 197                                                                    isys:o-creat))))
 198     ;; Standard error
 199     (case stderr
 200       (:pipe
 201        (setf (values errfd errfd-child)
 202              (redirect-to-pipes file-actions +stderr+ nil)))
 203       (:pty
 204        (setf errfd (isys:dup ptmfd))
 205        (redirect-one-stream file-actions +stderr+ pts (logior isys:o-wronly
 206                                                               isys:o-creat)))
 207       (t (redirect-one-stream file-actions +stderr+ stderr (logior isys:o-wronly
 208                                                                    isys:o-creat))))
 209     (values infd infd-child outfd outfd-child errfd errfd-child)))
 210
 211 (defun close-fds (&rest fds)
 212   (dolist (fd fds)
 213     (when fd (isys:close fd))))
 214
 215 (defun setup-slave-pty ()
 216   (let ((ptmfd (isys:openpt (logior isys:o-rdwr isys:o-noctty isys:o-cloexec))))
 217     (isys:grantpt ptmfd)
 218     (isys:unlockpt ptmfd)
 219     (values ptmfd (isys:ptsname ptmfd))))
 220
 221 (defmacro with-pty ((ptmfd pts) &body body)
 222   `(multiple-value-bind (,ptmfd ,pts)
 223        (setup-slave-pty)
 224      (unwind-protect
 225           (locally ,@body)
 226        (close-fds ,ptmfd))))
 227
 228 (defmacro with-redirections (((infd outfd errfd)
 229                               (file-actions stdin stdout stderr))
 230                              &body body)
 231   (with-gensyms (infd-child outfd-child errfd-child ptmfd pts)
 232     `(with-pty (,ptmfd ,pts)
 233        (multiple-value-bind (,infd ,infd-child ,outfd ,outfd-child ,errfd ,errfd-child)
 234            (setup-redirections ,file-actions ,stdin ,stdout ,stderr ,ptmfd ,pts)
 235          (unwind-protect-case ()
 236              (locally ,@body)
 237            (:always
 238             (close-fds ,infd-child ,outfd-child ,errfd-child))
 239            (:abort
 240             (close-fds ,infd ,outfd ,errfd)))))))
 241
 242 (defun process-other-spawn-args (attributes new-session current-directory
 243                                  uid gid resetids)
 244   (when new-session
 245     (lfp-spawnattr-setsid attributes))
 246   (when current-directory
 247     (lfp-spawnattr-setcwd attributes current-directory))
 248   (when uid
 249     (lfp-spawnattr-setuid attributes uid))
 250   (when gid
 251     (lfp-spawnattr-setgid attributes gid))
 252   (when resetids
 253     (lfp-spawnattr-setflags attributes lfp-spawn-resetids)))
 254
 255 ;; program: :shell - the system shell
 256 ;;          file-path designator - a path
 257 ;; arguments: list
 258 ;; environment: t - inherit environment
 259 ;;              nil - NULL environment
 260 ;;              alist - the environment to use
 261 ;; stdin, stdout, stderr:
 262 ;;         file-path designator - open file, redirect to it
 263 ;;         :null - redirect to /dev/null - useful because /dev/null doesn't exist on Windows
 264 ;;         file-descriptor designator(integer or stream) - file descriptor, redirecto to it
 265 ;;         :pipe - create pipe, redirect the child descriptor to one end and wrap the other end
 266 ;;                 into a stream which goes into PROCESS slot
 267 ;;         t - inherit
 268 ;;         nil - close
 269 ;; new-session: boolean - create a new session using setsid()
 270 ;; current-directory: path - a directory to switch to before executing
 271 ;; uid: user id - unsigned-byte or string
 272 ;; gid: group id - unsigned-byte or string
 273 ;; resetids: boolean - reset effective UID and GID to saved IDs
 274
 275 (defun create-process (program-and-args &key (environment t)
 276                        (stdin :pipe) (stdout :pipe) (stderr :pipe)
 277                        new-session current-directory uid gid resetids
 278                        (external-format :utf-8))
 279   (flet ((new-ctty-p (stdin stdout stderr)
 280            (or (eql :pty stdin)
 281                (eql :pty stdout)
 282                (eql :pty stderr))))
 283     (destructuring-bind (program &rest arguments)
 284         (ensure-list program-and-args)
 285       (when (new-ctty-p stdin stdout stderr)
 286         (setf new-session t))
 287       (with-argv ((arg0 argv) program arguments)
 288         (with-c-environment (envp environment)
 289           (with-lfp-spawn-arguments (attributes file-actions pid)
 290             (with-redirections ((infd outfd errfd)
 291                                 (file-actions stdin stdout stderr))
 292               (process-other-spawn-args attributes new-session current-directory
 293                                         uid gid resetids)
 294               (lfp-spawnp pid arg0 argv envp file-actions attributes)
 295               (make-instance 'process :pid (mem-ref pid 'pid-t)
 296                              :stdin infd :stdout outfd :stderr errfd
 297                              :external-format external-format))))))))
 298
 299 (defun run-program (program-and-args &key (environment t) (stderr :pipe)
 300                     (external-format :utf-8))
 301   (flet ((slurp (stream)
 302            (with-output-to-string (s)
 303              (loop :for c := (read-char stream nil nil)
 304                    :while c :do (write-char c s)))))
 305     (let ((process (create-process program-and-args
 306                                    :environment environment
 307                                    :stdin nil
 308                                    :stdout :pipe
 309                                    :stderr stderr
 310                                    :external-format external-format)))
 311       (unwind-protect
 312            (values (process-status process :wait t)
 313                    (slurp (process-stdout process))
 314                    (if (eql :pipe stderr)
 315                        (slurp (process-stderr process))
 316                        (make-string 0)))
 317         (close process)))))