path: root/scsh-process.scm

;;
;; SCSH process form notation
;;
;; See http://www.scsh.net/docu/html/man-Z-H-3.html#node_chap_2
;;
;; Some minor changes due to Chicken- and R7RS-incompatible identifiers:
;; | was changed to pipe, |+ was changed to pipe+
;;
;; || wasn't changed, but it's really the zero-length symbol
;;
;; WARNING: Don't mix with threading unless you're using
;;          Chicken 4.8.1 rev 47b5be71 or later.
;;
;;; Copyright (c) 2012-2018, Peter Bex
;; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions
; are met:
;
; 1. Redistributions of source code must retain the above copyright
;    notice, this list of conditions and the following disclaimer.
; 2. Redistributions in binary form must reproduce the above copyright
;    notice, this list of conditions and the following disclaimer in the
;    documentation and/or other materials provided with the distribution.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
; OF THE POSSIBILITY OF SUCH DAMAGE.

(declare
  ;; Avoid FD leaks due to context switch between create-pipe and fork
  (disable-interrupts))

(module scsh-process
  (;; procedures
   exec-path exec-path* fork %fork fork/pipe %fork/pipe fork/pipe+ %fork/pipe+
   run/collecting* run/string* run/strings* run/port* run/file* run/sexp* run/sexps*

   ;; macros
   run/collecting run/string run/strings run/port run/file run/sexp run/sexps
   || && (& run-final-thunk maybe->string) (run maybe->string) (exec-epf maybe->string)

   process? proc:pid proc? wait signal-process process-sleep)

(import scheme)

(cond-expand
  (chicken-5 (import (chicken base) (chicken condition) (chicken io)
                     (chicken port) (chicken file) (chicken file posix)
                     (chicken fixnum) (chicken string) (chicken process)
                     (chicken process signal) srfi-18 llrb-fixnum-table))
  (else (import chicken)
        (use data-structures (rename extras (read-file read-list))
             utils files ports posix srfi-1 srfi-18)
        (use llrb-fixnum-table)))

;;;;;;;;;;;;;;;;;;;;;;;;;
;; Process bookkeeping ;;
;;;;;;;;;;;;;;;;;;;;;;;;;

;; This stuff is all required so we can more cleanly and simply run
;; processes without having to wait for all of them in user code.  We
;; need to keep a hash table around so that the user can still wait
;; for his own processes without the signal/chld handler interfering
;; with those.  It's a bit of hack the way we overwrite the regular
;; process-wait procedure from POSIX, but this allows us to
;; transparently mark off processes which were waited on by the user.

(define-record scsh-process pid exit-status ok? child-condition)

;; Aaaand another hack to avoid getting "deadlock detected" when all
;; threads are waiting for a child condition.  We can still get woken
;; up by the signal/chld handler (see below).
(define (install-deadlock-workaround!)
  (thread-start!
   (make-thread (lambda () (let lp () (thread-sleep! 100) (lp)))
                'work-around-broken-deadlock-detection)))

(install-deadlock-workaround!) ;; And again on fork

(define proc:pid scsh-process-pid)
(define proc? scsh-process?)

;; Deprecated
(define process? scsh-process?)

(define *scsh-pending-processes* (make-table))

(define (clear-scsh-pending-processes!)
  (set! *scsh-pending-processes* (make-table)))

(define (add-scsh-pending-process! pid)
  (let* ((c (make-condition-variable pid))
         (process (make-scsh-process pid #f #f c)))
    (table-update! *scsh-pending-processes* pid (lambda (x) process) (lambda () #f))
    process))

(define (scsh-pending-process-ref/default pid default)
  (table-ref/default *scsh-pending-processes* pid default))

(define (remove-scsh-pending-process! pid)
  (table-delete! *scsh-pending-processes* pid))

(define (scsh-pending-process-fold proc nil)
  (table-fold *scsh-pending-processes* proc nil))

(define (snapshot-scsh-pending-process)
  (let ((copy (table-copy *scsh-pending-processes*)))
    (lambda (pid) (table-ref/default copy pid #f))))

(define wait #f)

(let ((posix-process-wait process-wait))
  (set! process-wait
        (lambda (#!optional pid nohang)
          (receive (status ok? pid) (wait pid nohang) (values pid ok? status))))

  (set! wait
        (lambda (#!optional pid-or-process nohang)
          (unless (or (not pid-or-process)
                      (scsh-process? pid-or-process)
                      (number? pid-or-process))
            (error 'process-wait
                   "Not a scsh-type process object or pid"
                   pid-or-process))
          ;; We need to make a copy when waiting for #f, because we
          ;; can't predict which pid we'll receive, and the SIGCHLD
          ;; handler will drop the pid from the pending list.
          (let ((pending-before
                 (if pid-or-process
                     #f
                     (snapshot-scsh-pending-process)))
                (p (if (and pid-or-process (number? pid-or-process))
                       (scsh-pending-process-ref/default pid-or-process #f)
                       pid-or-process)))
            (if (and p (scsh-process-exit-status p))
                (values (scsh-process-exit-status p)
                        (scsh-process-ok? p)
                        (scsh-process-pid p))
		(handle-exceptions exn
                    (if (and p (scsh-process-exit-status p)) ; Signal might've occurred
                        (values (scsh-process-exit-status p)
                                (scsh-process-ok? p)
                                (scsh-process-pid p))
                        (abort exn))
                  (let lp ()
                    (receive (pid ok? status)
                        (posix-process-wait
                         (if p (scsh-process-pid p) pid-or-process)
                         ;; When we have p, "nohang" is ignored because
                         ;; the thread will hang on the condition var
                         ;; rather than letting the entire process hang.
                         (if p #t nohang))
                      (cond
                       ((zero? pid)
                        (if nohang
                            (values #f #f #f)
                            (let ((m (make-mutex)))
                              (mutex-unlock! m (scsh-process-child-condition p))
                              (if (not (scsh-process-exit-status p))
                                  (lp)  ; could be forcibly unblocked
                                  (values (scsh-process-exit-status p)
                                          (scsh-process-ok? p)
                                          (scsh-process-pid p))))))
                       (else
                        (and-let* ((p (or p (pending-before pid))))
                          (scsh-process-exit-status-set! p status)
                          (scsh-process-ok?-set! p ok?)
                          (condition-variable-broadcast!
                           (scsh-process-child-condition p)))

                        (remove-scsh-pending-process! pid)
                        (values status ok? pid))))))))))

  (set-signal-handler!
   signal/chld
   ;; This workaround fixes the "signal-hander" type in the types.db of 4.8.0
   (let-syntax ((workaround
                 (cond-expand
                  (chicken-4.8
                   (syntax-rules ()
                     ((_ val) (the (or boolean (procedure (fixnum) . *)) val))))
                  (else (syntax-rules () ((_ val) val))))))
     (let* ((old-handler (workaround (signal-handler signal/chld)))
            (rst #f) ;; restart scan if true
            (handler
             ;; Run the signal handler in another thread. This is needed
             ;; because the current thread may be waiting on a condition
             ;; variable, and we can't wake ourselves up.
             (thread-start!
              (lambda ()
                (do () (#f)
                  (set! rst #f)
                  (scsh-pending-process-fold
                   (lambda (pid p i)
                     (and
                      p
                      (not (scsh-process-exit-status p))
                      (receive (pid ok? status)
                               (posix-process-wait pid #t)
                               (if (and (not (zero? pid)) p)
                                   (begin
                                     (scsh-process-exit-status-set! p status)
                                     (scsh-process-ok?-set! p ok?)
                                     (condition-variable-broadcast!
                                      (scsh-process-child-condition p))
                                     ;; The GC can clean it up
                                     (remove-scsh-pending-process! pid))))))
                   #f)
                  (unless rst (thread-suspend! (current-thread))))))
             ))
       (lambda (signal)
         (set! rst #t)
         (thread-resume! handler)
         (when old-handler (old-handler signal)))))))

(define (signal-process proc sig)
  (process-signal (scsh-process-pid proc) sig))

(define process-sleep sleep)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Execution and forking helpers ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; TODO: Perhaps expose environment, and mess around with the path so that
;; execve can be used in a sensible way?  Scsh has its own PATH, so we could
;; use something similar to that, but it's more work.
(define (exec-path prog . args)
  (exec-path* prog args))

;; Internal variant, collecting args
(define (exec-path* prog args)
  (process-execute (maybe->string prog) (map maybe->string args)))

(define (fork/pipe #!optional thunk continue-threads?)
  (fork/pipe+ '((1 0)) thunk continue-threads?))

;; Run a thunk and exit 0 after the thunk returns.
;; If an exception occurs, handle it and exit 1.
(define (run-final-thunk thunk)
  (handle-exceptions exn
    ;; TODO: Figure out how SCSH does this.  It shows the error
    ;; on stderr in the REPL, but then still quits it.
    ;; If we just invoke current-handler, it'll get a second REPL
    (begin (print-error-message exn) (exit 1))
    (thunk)
    (exit 0)))

(define (fork #!optional thunk continue-threads?)
  (let ((sigchld-was-masked? (signal-masked? signal/chld)))
    (dynamic-wind
        ;; If we're really unlucky, sigchld might be delivered
        ;; immediately after forking, but before we added the child's
        ;; pid to the pending processes table.  This means we'll lose
        ;; the event and won't mark the process as finished, resulting
        ;; in an endless loop in process-wait.  So, mask it.
        (lambda ()
          (unless sigchld-was-masked? (signal-mask! signal/chld)))
        (lambda ()
          (let* ((maybe-reinstall-deadlock-workaround!
                  (lambda ()
                    (cond-expand
                      (has-thread-killer
                       (unless continue-threads? (install-deadlock-workaround!)))
                      (else (void)))))
                 (thunk (and thunk (lambda ()
                                     (clear-scsh-pending-processes!)
                                     (maybe-reinstall-deadlock-workaround!)
                                     (unless sigchld-was-masked?
                                       (signal-unmask! signal/chld))
                                     (thunk))))
                 (pid (cond-expand
                        (has-thread-killer
                         (process-fork thunk (not continue-threads?)))
                        (else ;; Ignore both args if thunk is #f, so #f won't be applied
                         (if thunk (process-fork thunk) (process-fork))))))
            (cond ((zero? pid)
                   (clear-scsh-pending-processes!)
                   (maybe-reinstall-deadlock-workaround!)
                   #f)
                  (else (add-scsh-pending-process! pid)))))
        (lambda ()
          (unless sigchld-was-masked? (signal-unmask! signal/chld))))))

(define %fork fork)

(define (fork/pipe+ conns #!optional thunk continue-threads?)
  ;; Blergh, this is silly overhead we don't really need
  (let* ((revconns (map reverse conns))
         ;; from-fds is everything but the last, to-fds the last of
         ;; each connection spec.
         (from-fds (map (lambda (x) (reverse (cdr x))) revconns))
         (to-fds (map car revconns))
         (pipe-pairs (map (lambda _ (receive (create-pipe))) to-fds))
         (proc (fork #f continue-threads?)))
    (if (not proc)                      ; Child
        (begin
          (for-each (lambda (p from-fds-for-this-p)
                      ;; Close receiving ends of pipes in child.
                      (file-close (car p))
                      ;; Set up linkage from output fds to created pipes.
                      (for-each (lambda (from-fd)
                                  (duplicate-fileno (cadr p) from-fd))
                                from-fds-for-this-p)
                      ;; Not needed anymore after duplication is complete.
                      (file-close (cadr p)))
                    pipe-pairs from-fds)
          (if thunk (run-final-thunk thunk) #f))
        (begin                          ; Parent
          (for-each (lambda (p to-fd)
                      ;; Close sending end in parent.
                      (file-close (cadr p))
                      ;; Set up linkage from created pipes to the input fds.
                      (duplicate-fileno (car p) to-fd)
                      ;; No longer needed after duplication.
                      (file-close (car p)))
                    pipe-pairs to-fds)
          proc))))

;; TODO: Differentiate between fork and %fork
(define %fork/pipe fork/pipe)
(define %fork/pipe+ fork/pipe+)

(define (maybe->string s)
  (cond ((string? s) s)
        ((or (symbol? s) (number? s)) (->string s))
        (else (error "Expected a string, symbol or number"))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Baroque procedural interface ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Documented under http://www.scsh.net/docu/html/man-Z-H-3.html#node_sec_2.4.2
(define (run/collecting* fds thunk)
  (let* ((temp-files (map (lambda (fd)
                            (let* ((file-name (create-temporary-file))
                                   (port (open-input-file file-name)))
                              (delete-file file-name)
                              port))
                          fds))
         (conns (map (lambda (from-fd temp-file)
                       (list from-fd (port->fileno temp-file)))
                     fds temp-files)))
    (apply values (wait (fork/pipe+ conns thunk)) temp-files)))

(define (run/port* thunk)
  (receive (in out)
    (create-pipe)
    (fork
     (lambda ()
       (run-final-thunk
        (lambda ()
          (file-close in)
          (duplicate-fileno out 1)
          (with-output-to-port (open-output-file* out) thunk)))))
    (file-close out)
    (open-input-file* in)))

(define (run/file* thunk)
  (let ((temp-file (create-temporary-file)))
    (wait (fork (lambda ()
                  (let ((fd (file-open temp-file open/wronly)))
                    (duplicate-fileno fd 1)
                    (with-output-to-port (open-output-file* 1) thunk)))))
    temp-file))

(define (call-with-run/port* thunk consumer)
  (let ((in (run/port* thunk)))
    ;; This is really more like unwind-protect
    (dynamic-wind
        void
        (lambda () (consumer in))
        (lambda () (close-input-port in)))))

(define (run/string* thunk)
  (call-with-run/port* thunk (lambda (in)
                               (let ((result (read-string #f in)))
                                 (if (eof-object? result)
                                     ""
                                     result)))))
(define (run/strings* thunk)
  (call-with-run/port* thunk read-lines))
(define (run/sexp* thunk)
  (call-with-run/port* thunk read))
(define (run/sexps* thunk)
  (call-with-run/port* thunk read-list))

;;;;;;;;;;;;
;; Syntax ;;
;;;;;;;;;;;;

(define-syntax run/collecting
  (syntax-rules ()
    ((_ ?fds ?epf ...) (run/collecting* `?fds (lambda () (exec-epf ?epf ...))))))
(define-syntax run/file
  (syntax-rules ()
    ((_ ?epf ...) (run/file* (lambda () (exec-epf ?epf ...))))))
(define-syntax run/port
  (syntax-rules ()
    ((_ ?epf ...) (run/port* (lambda () (exec-epf ?epf ...))))))
(define-syntax run/string
  (syntax-rules ()
    ((_ ?epf ...) (run/string* (lambda () (exec-epf ?epf ...))))))
(define-syntax run/strings
  (syntax-rules ()
    ((_ ?epf ...) (run/strings* (lambda () (exec-epf ?epf ...))))))
(define-syntax run/sexp
  (syntax-rules ()
    ((_ ?epf ...) (run/sexp* (lambda () (exec-epf ?epf ...))))))
(define-syntax run/sexps
  (syntax-rules ()
    ((_ ?epf ...) (run/sexps* (lambda () (exec-epf ?epf ...))))))

(define-syntax &&
  (syntax-rules ()
    ((_ ?epf ...) (and (zero? (run ?epf)) ...))))
(define-syntax ||
  (syntax-rules ()
    ((_ ?epf ...) (or (zero? (run ?epf)) ...))))

(define-syntax &
  (syntax-rules ()
    ((_ ?epf ...)
     (fork (lambda () (run-final-thunk (lambda () (exec-epf ?epf ...))))))))

(define-syntax run
  (syntax-rules ()
    ((_ ?epf ...)
     (wait (& ?epf ...)))))

;; Perhaps this should really be a procedure?
(define-syntax setup-redirection
  (syntax-rules (< > << >> = - stdports)
    ((_ (< ?file-name)) (setup-redirection (< 0 ?file-name)))
    ((_ (<< ?object)) (setup-redirection (<< 0 ?object)))
    ((_ (> ?file-name)) (setup-redirection (> 1 ?file-name)))
    ((_ (>> ?file-name)) (setup-redirection (>> 1 ?file-name)))
    ((_ (> ?fd ?file-name))
     (duplicate-fileno
      (file-open (maybe->string `?file-name)
                 (fx+ (fx+ open/wronly open/creat) open/trunc))
      `?fd))
    ((_ (>> ?fd ?file-name))
     (duplicate-fileno (file-open (maybe->string `?file-name)
                                  (fx+ open/wronly (fx+ open/append open/creat)))
                       `?fd))
    ((_ (< ?fd ?file-name))
     (duplicate-fileno (file-open (maybe->string `?file-name) open/rdonly)
                       `?fd))
    ((_ (<< ?fd ?object))
     (fork/pipe+ `((1 ?fd)) (lambda () (display `?object (open-output-file* 1)))))
    ((_ (= ?fd-from ?fd/port-to))
     (let* ((fd/port-to ?fd/port-to)    ; Evaluate once
            (fd-to (if (port? fd/port-to)
                       (port->fileno fd/port-to)
                       fd/port-to)))
       (duplicate-fileno fd-to ?fd-from)))
    ((_ (- ?fd/port))
     (let ((o `?fd/port))
       (cond
        ((fixnum? ?fd/port) (file-close o))
        ((output-port? ?fd/port) (close-output-port o))
        ((input-port? ?fd/port) (close-input-port o))
        (else (error "Can only close i/o-ports and file descriptor numbers" o)))))
    ((_ stdports)
     (begin (setup-redirection (= 0 (current-input-port)))
            (setup-redirection (= 1 (current-output-port)))
            (setup-redirection (= 2 (current-error-port)))))
    ((_ ?arg0 ...)
     (syntax-error "Invalid redirection pattern: " `?arg0 ...))))

;; The most "core" syntax form
(define-syntax exec-epf
  ;; The nested let-syntaxes exist to let us pre-empt the fallthrough
  ;; whenever we see one of the recognised special rules so we don't end up
  ;; with the generic one if we happen to make a small mistake
  (syntax-rules (pipe pipe+ begin epf)
    ((_ (pipe ?pf0 ...) ?redir0 ...)
     (exec-epf (pipe+ ((1 0)) ?pf0 ...) ?redir0 ...))
    ((_ (pipe+ ?args ...) ?redir0 ...)
     (let-syntax
         ((pipe+
           (syntax-rules ___ ()
             ((_ ((?from0 ?from1 ___ ?to) ___) ?pf0 ___ ?last-pf)
              (let ((conns `((?from0 ?from1 ___ ?to) ___)))
                 (setup-redirection ?redir0) ...
                 (begin (fork/pipe+ conns (lambda () (exec-epf (epf ?pf0))))
                        ___
                        (exec-epf (epf ?last-pf))))))))
       (pipe+ ?args ...)))
    ((_ (begin ?expr0 ...))
     (begin (setup-redirection stdports) ?expr0 ...))
    ((_ (epf ?args ...))              ; This disambiguates redirection
     (exec-epf ?args ...))
    ((_ (?prog ?arg0 ...) ?redir0 ...)
     (begin
       (setup-redirection ?redir0) ...
       (exec-path* `?prog `(?arg0 ...))))))

)