(module mailbox-process () (import scheme chicken) (use clot mailbox datatypes2) (use (prefix posix posix:)) (use (only posix signal/stop)) (use (only srfi-18 make-thread thread-start! thread-yield!)) (use (only extras read-line)) (use logging) (use/types ProcessEvent) (define-type (mb a) (struct mailbox (a))) (defn run-process (doc: "Sent messages:" "(Started pid)" "(StdOut line)" "(StdErr line)" "(Exit code)") clean: (: (pair (mb ProcessEvent) (struct mailbox))) [(cmd : string)] (let ([mb-in (make-mailbox)] [mb-out (make-mailbox)]) (-> (make-thread (fn [] (run-process* mb-in mb-out cmd))) thread-start!) (cons mb-out mb-in))) (defn- run-process* [(mb-in : (mb *)) (mb-out : (mb ProcessEvent)) (cmd : string)] (receive (in-port out-port pid err-port) (posix:process* cmd) (mailbox-send! mb-out (Started pid)) (define (do-line port f) (when (char-ready? port) ;; TODO: strictly wrong, we're reading lines (let ([l (read-line port)]) (if (eof-object? l) #f (f l))))) (define (do-lines) (do-line in-port (fn [l] (mailbox-send! mb-out (StdOut l)))) (do-line err-port (fn [l] (mailbox-send! mb-out (StdErr l))))) (loop () (receive (pid2 ok? exit-status) (posix:process-wait pid #t) (cond [(not (= 0 pid2)) (do-lines) (close-input-port in-port) (close-output-port out-port) (close-input-port err-port) (mailbox-send! mb-out (Exit exit-status))] [(not (mailbox-empty? mb-in)) (let ([msg (mailbox-receive! mb-in)]) (when (eq? msg 'stop) ;; TODO: add proper datatype (log-debug "Sending signal/stop for process" pid) (posix:process-signal pid signal/stop) (do-lines) (recur)))] [else ; not finished (do-lines) (thread-yield!) (recur)]))))) )