subprocess.carp

(system-include "unistd.h")

(relative-include "./subprocess.h")

(register-type SubprocessPipe "CarpSubprocess_Pipe")
(defmodule SubprocessPipe
  (register init (Fn [] SubprocessPipe) "CarpSubprocess_PipeInit")
  (register input (Fn [(Ref SubprocessPipe)] Int) "CarpSubprocess_PipeInput")
  (register output (Fn [(Ref SubprocessPipe)] Int) "CarpSubprocess_PipeOutput")

  (register copy (Fn [(Ref SubprocessPipe)] SubprocessPipe) "CarpSubprocess_PipeCopy")
  (implements copy copy)

  (sig str (Fn [(Ref SubprocessPipe)] String))
  (defn str [p]  @"(SubprocessPipe")
  (implements str str)
  (sig ref-prn (Fn [(Ref SubprocessPipe)] String))
  (defn ref-prn [p] @"(SubprocessPipe)")
  (implements prn ref-prn)
  (sig prn (Fn [SubprocessPipe] String))
  (defn prn [p] @"(SubprocessPipe)")
  (implements prn prn))

(deftype SubprocessInMode  Std Pipe (PipeIn [SubprocessPipe]))
(deftype SubprocessOutMode Std Pipe)
(deftype SubprocessErrMode Std Pipe Out)
(deftype SubprocessOptions [in SubprocessInMode out SubprocessOutMode err SubprocessErrMode])
(defmodule SubprocessOptions
  (doc  sss "Sets options to the following: in = Std, out = Std, err = Std")
  (defn sss [] (SubprocessOptions (SubprocessInMode.Std) (SubprocessOutMode.Std) (SubprocessErrMode.Std)))
  (implements zero sss)
  (doc  spo "Sets options to the following: in = Std, out = Pipe, err = Out")
  (defn spo [] (SubprocessOptions (SubprocessInMode.Std) (SubprocessOutMode.Pipe) (SubprocessErrMode.Out)))
  (doc  spp "Sets options to the following: in = Std, out = Pipe, err = Pipe")
  (defn spp [] (SubprocessOptions (SubprocessInMode.Std) (SubprocessOutMode.Pipe) (SubprocessErrMode.Pipe)))
  (doc  sps "Sets options to the following: in = Std, out = Pipe, err = Std")
  (defn sps [] (SubprocessOptions (SubprocessInMode.Std) (SubprocessOutMode.Pipe) (SubprocessErrMode.Std)))
  (doc  pss "Sets options to the following: in = Pipe, out = Std, err = Std")
  (defn pss [] (SubprocessOptions (SubprocessInMode.Pipe) (SubprocessOutMode.Std) (SubprocessErrMode.Std)))
  (doc  iss "Sets options to the following: in = PipeIn, out = Std, err = Std")
  (defn iss [p] (SubprocessOptions (SubprocessInMode.PipeIn p) (SubprocessOutMode.Std) (SubprocessErrMode.Std)))
  (doc  ips "Sets options to the following: in = PipeIn, out = Pipe, err = Std")
  (defn ips [p] (SubprocessOptions (SubprocessInMode.PipeIn p) (SubprocessOutMode.Pipe) (SubprocessErrMode.Std))))

(deftype SubprocessRes [out (Maybe String) err (Maybe String) exit-code Int])
(derive SubprocessRes =)

(deftype Subprocess [in (Maybe SubprocessPipe) out (Maybe SubprocessPipe) err (Maybe SubprocessPipe) pid Int])
(defmodule Subprocess
  (private fork) (hidden fork)
  (register fork (Fn [] Int) "fork")
  (private close) (hidden close)
  (register close (Fn [Int] ()) "close")
  (private execvp) (hidden execvp)
  (register execvp (Fn [(Ptr CChar) (Ptr (Ptr CChar))] Int) "execvp")
  (private wait) (hidden wait)
  (register wait (Fn [(Ptr Int)] ()) "wait")
  (private wait-pid) (hidden wait-pid)
  (register wait-pid (Fn [Int (Ptr Int) Int] ()) "waitpid")
  (private read) (hidden read)
  (register read (Fn [Int (Ptr Byte) Int] Int) "read")
  (private dup2) (hidden dup2)
  (register dup2 (Fn [Int Int] Int) "dup2")
  (private exit-status) (hidden exit-status)
  (deftemplate exit-status (Fn [Int] Int) "int $NAME(int status)" "$DECL { return WEXITSTATUS(status); }")

  (defn- child-process [args in-pipe out-pipe err-pipe options]
    (do
     (match-ref (SubprocessOptions.in options)
       Pipe
       (do (close (SubprocessPipe.output in-pipe))
           (assert (/= -1 (dup2 (SubprocessPipe.input in-pipe) 0)))
           (close (SubprocessPipe.input in-pipe)))
       (PipeIn p)
       (do (close (SubprocessPipe.input p))
           (assert (/= -1 (dup2 (SubprocessPipe.output p) 0)))
           (close (SubprocessPipe.output p)))
       _ ())

     (match-ref (SubprocessOptions.out options)
       Pipe
       (do (close (SubprocessPipe.output out-pipe))
           (assert (/= -1 (dup2 (SubprocessPipe.input out-pipe) 1)))
           (close (SubprocessPipe.output out-pipe)))
       _ ())

     (match-ref (SubprocessOptions.err options)
       Pipe
       (do (close (SubprocessPipe.output err-pipe))
           (assert (/= -1 (dup2 (SubprocessPipe.input err-pipe) 2)))
           (close (SubprocessPipe.input err-pipe)))
       Out
       (match-ref (SubprocessOptions.out options)
         Pipe (assert (/= -1 (dup2 (SubprocessPipe.input out-pipe) 2)))
         Std  (assert (/= -1 (dup2 1 2))))
       _ ())

     ; Not sure having a silent fallback is a good idea...
     (if (> (Array.length args) 1) ; Array already has NULL in it when empty
       (assert (/= -1 (execvp (Array.unsafe-nth-value args 0) (Array.unsafe-raw args))))
       (let [true-args $[(cstr "true") NULL]
             exec-res  (execvp (StaticArray.unsafe-nth-value true-args 0) (StaticArray.unsafe-raw true-args))]
          (assert (/= exec-res -1))))

     (exit 1))) ; Should not be reached

  (defn- parent-process [in-pipe out-pipe err-pipe options pid]
    (let [maybe-in-pipe
          (match-ref (SubprocessOptions.in options)
            Pipe       (Just in-pipe)
            _          (Nothing))
          maybe-out-pipe
          (match-ref (SubprocessOptions.out options)
            Pipe (do (close (SubprocessPipe.input &out-pipe))
                     (Just out-pipe))
            _    (Nothing))
          maybe-err-pipe
          (match-ref (SubprocessOptions.err options)
            Pipe (do (close (SubprocessPipe.input &err-pipe))
                     (Just err-pipe))
            Out  (Nothing)
            _    (Nothing))]
      (init maybe-in-pipe maybe-out-pipe maybe-err-pipe pid)))

  (defn- fork-and-process [args options]
    (let-do [in-pipe (SubprocessPipe.init)
             *in-pipe &in-pipe
             out-pipe (SubprocessPipe.init)
             *out-pipe &out-pipe
             err-pipe (SubprocessPipe.init)
             *err-pipe &err-pipe
             pid -1]

       (set! pid (fork))
       (cond (< pid 0) (do (IO.errorln "Fork failed") (exit 1))
             (= pid 0) (child-process args *in-pipe *out-pipe *err-pipe options)
             (parent-process in-pipe out-pipe err-pipe options pid))))

  (sig call (Fn [SubprocessOptions (Ref (Array String))] Subprocess))
  (defn call [options args]
    (let-do [len (Array.length args)
             c-args (Array.allocate (inc len))]
      (for [i 0 len]
        (Array.aset-uninitialized! &c-args i (cstr (Array.unsafe-nth args i))))
      (Array.aset-uninitialized! &c-args (dec (Array.length &c-args)) NULL)
      (fork-and-process &c-args &options)))

  (sig collect (Fn [Subprocess] SubprocessRes))
  (defn-do collect [subp]
    (let-do [out-continue true
             err-continue true
             buff-size 1 ; One byte at a time TODO: buffer this
             out-buff (the (Array Byte) [])
             err-buff (the (Array Byte) [])
             out-current-char (the Byte (zero))
             err-current-char (the Byte (zero))
             out-byte-read 0
             err-byte-read 0
             status -1]

      (while-do (or out-continue err-continue)

        (when out-continue
          (match-ref (Subprocess.out &subp)
            (Just pipe)
            (do
              (set! out-byte-read (read (SubprocessPipe.output pipe)
                                        (Pointer.address &out-current-char)
                                        buff-size))
              (if (> out-byte-read 0)
                (Array.push-back! &out-buff out-current-char)
                (set! out-continue false)))
            _ (set! out-continue false)))

        (when err-continue
          (match-ref (Subprocess.err &subp)
            (Just pipe)
            (do
              ; TODO: check for EAGAIN | EWOULDBLOCK | EINTR + other non resumable errors
              (set! err-byte-read (read (SubprocessPipe.output pipe)
                                        (Pointer.address &err-current-char)
                                        buff-size))
              (if (> err-byte-read 0)
                (Array.push-back! &err-buff err-current-char)
                (set! err-continue false)))
            _ (set! err-continue false))))

      (wait-pid @(Subprocess.pid &subp) (Pointer.address &status) 0)
      (SubprocessRes.init
       (match-ref (Subprocess.out &subp)
         (Just _)  (Just (String.from-bytes &out-buff))
         _ (Nothing))
       (match-ref (Subprocess.err &subp)
         (Just _) (Just (String.from-bytes &err-buff))
         _ (Nothing))
       (exit-status status))))

  (sig pipe (Fn [(Ref (Array (Array String)))] Subprocess))
  (defn pipe [commands]
    (Array.reduce
      &(fn [acc command]
        (let [out @(Subprocess.out &acc)]
          (match out
            (Just p) (call (SubprocessOptions (SubprocessInMode.PipeIn p) (SubprocessOutMode.Pipe) (SubprocessErrMode.Std))
                           command)
            Nothing  (call (SubprocessOptions.sps) command))))
      (Subprocess (Nothing) (Nothing) (Nothing) -1)
      commands))

  (sig cmd (Fn [SubprocessOptions (Ref (Array String))] SubprocessRes))
  (defn cmd [opts args] (collect (call opts args))))