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 (defun call-with-lfp-spawn-arguments (thunk)
 106   (with-foreign-objects ((attributes 'lfp-spawnattr-t)
 107                          (file-actions 'lfp-spawn-file-actions-t))
 108     (let ((spawnattr-initialized-p nil)
 109           (file-actions-initialized-p nil))
 110       (unwind-protect
 111            (progn
 112              (setf spawnattr-initialized-p
 113                    (lfp-spawnattr-init attributes))
 114              (setf file-actions-initialized-p
 115                    (lfp-spawn-file-actions-init file-actions))
 116              (funcall thunk attributes file-actions))
 117         (when spawnattr-initialized-p
 118           (lfp-spawnattr-destroy attributes))
 119         (when file-actions-initialized-p
 120           (lfp-spawn-file-actions-destroy file-actions))))))
 121
 122 (defmacro with-lfp-spawn-arguments ((attributes file-actions) &body body)
 123   `(call-with-lfp-spawn-arguments
 124     (lambda (,attributes ,file-actions) ,@body)))
 125
 126 (defun allocate-argv (argv program arglist)
 127   ;; copy program name
 128   (setf (mem-aref argv :pointer 0)
 129         (foreign-string-alloc program))
 130   ;; copy program arguments
 131   (loop :for i :from 1
 132         :for arg :in arglist :do
 133         (setf (mem-aref argv :pointer i)
 134               (foreign-string-alloc arg))))
 135
 136 (defun find-program (program)
 137   (cond
 138     ((eql :shell program)
 139      (list "/bin/sh" "-c"))
 140     (t
 141      (list (file-path-namestring program)))))
 142
 143 (defmacro with-argv (((arg0 argv) program arguments) &body body)
 144   (with-gensyms (argc)
 145     `(let* ((,program (find-program ,program))
 146             (,arguments (append (cdr ,program) ,arguments))
 147             (,argc (+ 2 (length ,arguments))))
 148        (with-foreign-object (,argv :pointer ,argc)
 149          (isys:bzero ,argv (* ,argc (isys:sizeof :pointer)))
 150          (unwind-protect
 151               (progn
 152                 (allocate-argv ,argv (car ,program) ,arguments)
 153                 (let ((,arg0 (mem-ref ,argv :pointer)))
 154                   ,@body))
 155            (delocate-null-ended-list ,argv))))))
 156
 157 (defun redirect-one-stream (file-actions fd stream
 158                             &optional flags (mode #o644) close-old-fd)
 159   (flet ((dup-from-path (path)
 160            (lfp-spawn-file-actions-addopen file-actions fd path flags mode))
 161          (dup-from-fd (oldfd)
 162            (lfp-spawn-file-actions-adddup2 file-actions oldfd fd)
 163            (when close-old-fd
 164              (lfp-spawn-file-actions-addclose file-actions oldfd))))
 165     (etypecase stream
 166       ((eql t) nil)
 167       ((or string file-path pathname)
 168        (dup-from-path (file-path-namestring stream)))
 169       ((eql :null)
 170        (dup-from-path "/dev/null"))
 171       (unsigned-byte
 172        (dup-from-fd stream))
 173       (iolib/streams:dual-channel-fd-mixin
 174        (dup-from-fd (iolib/streams:fd-of stream)))
 175       (null
 176        (lfp-spawn-file-actions-addclose file-actions fd)))))
 177
 178 (defun redirect-to-pipes (file-actions fd keep-write-fd)
 179   (multiple-value-bind (pipe-parent pipe-child)
 180       (isys:pipe)
 181     (when keep-write-fd (rotatef pipe-parent pipe-child))
 182     (lfp-spawn-file-actions-adddup2 file-actions pipe-child fd)
 183     (lfp-spawn-file-actions-addclose file-actions pipe-parent)
 184     (lfp-spawn-file-actions-addclose file-actions pipe-child)
 185     (values pipe-parent pipe-child)))
 186
 187 (defun setup-redirections (file-actions stdin stdout stderr ptmfd pts)
 188   (let (infd infd-child outfd outfd-child errfd errfd-child)
 189     ;; Standard input
 190     (case stdin
 191       (:pipe
 192        (setf (values infd infd-child)
 193              (redirect-to-pipes file-actions +stdin+ t)))
 194       (:pty
 195        (setf infd (isys:dup ptmfd))
 196        (redirect-one-stream file-actions +stdin+ pts isys:o-rdonly))
 197       (t (redirect-one-stream file-actions +stdin+ stdin isys:o-rdonly)))
 198     ;; Standard output
 199     (case stdout
 200       (:pipe
 201        (setf (values outfd outfd-child)
 202              (redirect-to-pipes file-actions +stdout+ nil)))
 203       (:pty
 204        (setf outfd (isys:dup ptmfd))
 205        (redirect-one-stream file-actions +stdout+ pts (logior isys:o-wronly
 206                                                               isys:o-creat)))
 207       (t (redirect-one-stream file-actions +stdout+ stdout (logior isys:o-wronly
 208                                                                    isys:o-creat))))
 209     ;; Standard error
 210     (case stderr
 211       (:pipe
 212        (setf (values errfd errfd-child)
 213              (redirect-to-pipes file-actions +stderr+ nil)))
 214       (:pty
 215        (setf errfd (isys:dup ptmfd))
 216        (redirect-one-stream file-actions +stderr+ pts (logior isys:o-wronly
 217                                                               isys:o-creat)))
 218       (t (redirect-one-stream file-actions +stderr+ stderr (logior isys:o-wronly
 219                                                                    isys:o-creat))))
 220     (values infd infd-child outfd outfd-child errfd errfd-child)))
 221
 222 (defun close-fds (&rest fds)
 223   (dolist (fd fds)
 224     (when fd (isys:close fd))))
 225
 226 (defun setup-slave-pty (new-ctty-p)
 227   (if new-ctty-p
 228       (let (ptmfd)
 229         (unwind-protect-case ()
 230             (progn
 231               (setf ptmfd (isys:openpt (logior isys:o-rdwr isys:o-noctty isys:o-cloexec)))
 232               (isys:grantpt ptmfd)
 233               (isys:unlockpt ptmfd)
 234               (values ptmfd (isys:ptsname ptmfd)))
 235           (:abort (when ptmfd (isys:close ptmfd)))))
 236       (values nil nil)))
 237
 238 (defmacro with-pty ((new-ctty-p ptmfd pts) &body body)
 239   `(multiple-value-bind (,ptmfd ,pts)
 240        (setup-slave-pty ,new-ctty-p)
 241      (unwind-protect
 242           (locally ,@body)
 243        (unless ,new-ctty-p
 244          (close-fds ,ptmfd)))))
 245
 246 (defmacro with-redirections (((infd outfd errfd)
 247                               (file-actions stdin stdout stderr ptyfd pts))
 248                              &body body)
 249   (with-gensyms (infd-child outfd-child errfd-child)
 250     `(multiple-value-bind (,infd ,infd-child ,outfd ,outfd-child ,errfd ,errfd-child)
 251          (setup-redirections ,file-actions ,stdin ,stdout ,stderr ,ptyfd ,pts)
 252        (unwind-protect-case ()
 253            (locally ,@body)
 254          (:always
 255           (close-fds ,infd-child ,outfd-child ,errfd-child))
 256          (:abort
 257           (close-fds ,infd ,outfd ,errfd))))))
 258
 259 (defun process-other-spawn-args (attributes new-session pts current-directory
 260                                  uid gid resetids vfork)
 261   (when new-session
 262     (lfp-spawnattr-setsid attributes))
 263   (when pts
 264     (lfp-spawnattr-setctty attributes pts))
 265   (when current-directory
 266     (lfp-spawnattr-setcwd attributes current-directory))
 267   (when uid
 268     (lfp-spawnattr-setuid attributes uid))
 269   (when gid
 270     (lfp-spawnattr-setgid attributes gid))
 271   (when resetids
 272     (lfp-spawnattr-setflags attributes lfp-spawn-resetids))
 273   (when vfork
 274     (lfp-spawnattr-setflags attributes lfp-spawn-usevfork)))
 275
 276 ;; program: :shell - the system shell
 277 ;;          file-path designator - a path
 278 ;; arguments: list
 279 ;; environment: t - inherit environment
 280 ;;              nil - NULL environment
 281 ;;              alist - the environment to use
 282 ;; stdin, stdout, stderr:
 283 ;;         file-path designator - open file, redirect to it
 284 ;;         :null - redirect to /dev/null - useful because /dev/null doesn't exist on Windows
 285 ;;         file-descriptor designator(integer or stream) - file descriptor, redirecto to it
 286 ;;         :pipe - create pipe, redirect the child descriptor to one end and wrap the other end
 287 ;;                 into a stream which goes into PROCESS slot
 288 ;;         t - inherit
 289 ;;         nil - close
 290 ;; pty: boolean - spawn a new controlling tty. it is also implicitly T if
 291 ;;                either stdin, stdout or stderr is :pty
 292 ;; new-session: boolean - create a new session using setsid(). it is also implicitly T
 293 ;;                        if a PTY is requested
 294 ;; current-directory: path - a directory to switch to before executing
 295 ;; uid: user id - unsigned-byte or string
 296 ;; gid: group id - unsigned-byte or string
 297 ;; resetids: boolean - reset effective UID and GID to saved IDs
 298
 299 (defun create-process (program-and-args &key (environment t)
 300                        (stdin :pipe) (stdout :pipe) (stderr :pipe) pty
 301                        new-session current-directory uid gid resetids vfork
 302                        (external-format :utf-8))
 303   (let ((new-ctty-p
 304            (or pty
 305                (eql :pty stdin)
 306                (eql :pty stdout)
 307                (eql :pty stderr))))
 308     (destructuring-bind (program &rest arguments)
 309         (ensure-list program-and-args)
 310       (with-argv ((arg0 argv) program arguments)
 311         (with-c-environment (envp environment)
 312           (with-lfp-spawn-arguments (attributes file-actions)
 313             (with-pty (new-ctty-p ptyfd pts)
 314               (with-redirections ((infd outfd errfd)
 315                                   (file-actions stdin stdout stderr ptyfd pts))
 316                 (process-other-spawn-args attributes
 317                                           new-session pts
 318                                           current-directory
 319                                           uid gid resetids vfork)
 320                 (with-foreign-object (pid 'pid-t)
 321                   (lfp-spawnp pid arg0 argv envp file-actions attributes)
 322                   (make-instance 'process :pid (mem-ref pid 'pid-t)
 323                                           :stdin infd :stdout outfd :stderr errfd :tty ptyfd
 324                                           :external-format external-format))))))))))
 325
 326 (defun slurp-char-stream (stream)
 327   (with-output-to-string (s)
 328     (loop :for c := (read-char stream nil nil)
 329           :while c :do (write-char c s))))
 330
 331 (defun slurp-octet-stream (stream)
 332   (let ((dynbuffer (make-instance 'dynamic-buffer :size 4096 :growth-size 2))
 333         (iobuffer (make-array 4096 :element-type '(unsigned-byte 8))))
 334     (handler-case
 335         (loop :for pos := (read-sequence iobuffer stream)
 336               :while (plusp pos) :do
 337           (write-vector dynbuffer iobuffer 0 pos))
 338       (end-of-file () nil))
 339     (subseq (sequence-of dynbuffer)
 340             (read-cursor-of dynbuffer)
 341             (write-cursor-of dynbuffer))))
 342
 343 (defun run-program (program-and-args &key (environment t)
 344                     (stdin :null) (stdout :pipe) (stderr :pipe)
 345                     (external-format :utf-8))
 346   (flet ((slurp (stream)
 347            (if external-format
 348                (slurp-char-stream stream)
 349                (slurp-octet-stream stream)))
 350          (make-empty-output ()
 351            (if external-format
 352                (make-array 0 :element-type 'character)
 353                (make-array 0 :element-type '(unsigned-byte 8)))))
 354     (let ((process
 355             (create-process program-and-args
 356                             :environment environment
 357                             :stdin stdin
 358                             :stdout stdout
 359                             :stderr stderr
 360                             :external-format external-format)))
 361       (unwind-protect
 362            (let ((stdout (if (eql :pipe stdout)
 363                              (slurp (process-stdout process))
 364                              (make-empty-output)))
 365                  (stderr (if (eql :pipe stderr)
 366                              (slurp (process-stderr process))
 367                              (make-empty-output))))
 368              (values (process-status process :wait t)
 369                      stdout stderr))
 370         (close process)))))