; process.ss - Process utilities
;
;   Copyright (c) 2009  Higepon(Taro Minowa)  <higepon@users.sourceforge.jp>
;
;   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
;   OWNER 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.
;
;  $Id: process.ss 621 2008-11-09 06:22:47Z higepon $

#|
    Title: Process

    Process Management:
    The following procedures provide raw process management.

    (mosh process) is not supported on Windows.

    library: (mosh process)

    Process Management Library
|#
(library (mosh process)
  (export (rename (%pipe pipe)
                  (%fork fork)
                  (%waitpid waitpid)
                  (%getpid getpid)
                  (%call-process call-process)
                  (%start-process start-process))
          exec
          spawn
          process-list process-terminate!)
  (import (rnrs)
          (only (mosh) os-constant string-split)
          (only (mosh control) let1)
          (only (system)
                %waitpid %pipe %fork %exec %getpid %call-process process-list
                process-terminate! %confstr %start-process %dup)

          (only (srfi :1) every first zip)
          (srfi :8)
          (srfi :16)
          (srfi :98)
          (srfi :26)
          (only (srfi :13) string-contains string-null?))

  (define *path-delimiter* #\:)

  (define (duplicate-descriptors in out err)
    (for-each (cute apply %dup <...>)
              (filter car (zip (list in out err)
                               (list (standard-input-port)
                                     (standard-output-port)
                                     (standard-error-port))))))
  

  #|
      Function: fork

      Fork the current process. Returns 0 if you're in the child process, and a child process' pid if you're in the parent process. All the opened file descriptors are shared between the parent and the child. See fork(2) of your system for details.

      Prototype:
      > (fork)

      Returns:

        0 if you're in the child process, and a child process' pid if you're in the parent process
  |#

  #|
      Function: exec

      Replace the current process with a new external command.  The ports
      attached to the subprocess must be binary, and must be either file input
      ports or ports generated by the 'pipe' procedure.  They can also be #f
      which means the subprocess inherits the parent's ports.

      Prototype:
      > (exec command args in out err . path-search? env)

      Parameters:

        command - command string to spawn.
        args - list of command line arguments.
        in - input port to attach to standard input of the subprocess.
        out - output port to attach to standard output of the subprocess.
        err - output port to attach to standard error of the subprocess.
        path-search? - optional, defaults to #t.  If #t, command will be
        searched for in shell path, otherwise command must be an absolute path.
        env - optional association list of environment variables as strings.  If
        specified, replaces the environment variables of the subprocess.  Use an
        empty list to empty the subprocess environment completely.

      Returns:

        pid in out err is returned as multiple values.
  |#


  ; Note that both EXECVPE and ATTEMPT-EXEC require a pre-flattened environment
  ; list.
  
  (define exec
    (case-lambda
     ((command args in out err path-search? env)
      (duplicate-descriptors in out err)
      
      (let ((proc (if path-search? execvpe attempt-exec)))
        (proc command
              (cons command args)
              (flatten-environment-alist env)))

      (error 'exec "could not execute command" command args))
     ((command args in out err path-search?)
      (exec command args in out err path-search? (get-environment-variables)))
     ((command args in out err)
      (exec command args in out err #t))))

  (define (flatten-environment-alist alist)
    (when (not (every pair? alist))
      (assertion-violation 'flatten-environment-alist
                           "environment argument must be alist"))

    (map (lambda (var)
           (string-append (car var) "=" (cdr var)))
         alist))

  ; For the spec see:
  ; http://pubs.opengroup.org/onlinepubs/9699919799/basedefs/V1_chap08.html 
  ; This function should ideally perform the 'pathname resolution' process defined
  ; by POSIX.  However at the moment it just handles the empty path element
  ; special case.
  (define (resolve-path-element str)
    (if (string-null? str)
        "."
        str))

  (define (get-default-path)
    (or (get-environment-variable "PATH")
        (%confstr (os-constant '_CS_PATH))))

  (define (get-path-to-shell)
    (cond
     ((%confstr (os-constant '_CS_PATH))
      => (lambda (path)
           (first (enumerate-prefixes path "sh"))))
     (else
      (error 'get-path-to-shell
             "unable to locate path to posix shell"))))

  ; Attempt an exec.  All branches of the cond will either raise an exception
  ; or return #f, an #f return will cause the caller to retry another path.
  (define (attempt-exec absolute-path argv envp)
    (let ((errno (%exec absolute-path argv envp)))
      (cond
        ((memv errno (map os-constant '(E2BIG ENOMEM ETXTBSY)))
         (error 'execvpe "execve call failed" errno))
        ((memv errno (map os-constant '(ELOOP ENAMETOOLONG ENOENT ENOTDIR)))
         #f)
        ((eqv? errno (os-constant 'ENOEXEC))
         (attempt-exec (get-path-to-shell)
                       (cons "sh" argv) 
                       envp))
        ; NB: The code below causes a bit of information loss for the caller,
        ; compared to the FreeBSD implementation, because the caller doesn't get
        ; to know if EACCES occurred anywhere down the chain of visited paths.
        ((or (not (file-exists? absolute-path))
             (eqv? errno (os-constant 'EACCES)))
         #f)
        (else
         (error 'execvpe "execve call failed: unhandled error: " errno)))))

  (define (enumerate-prefixes path name)
    (map
     (lambda (prefix)
       (string-append (resolve-path-element prefix) "/" name))
     (string-split path *path-delimiter*)))
  
  (define (alist->plist alist)
    (apply append (map (lambda (pair) (list (car pair) (cdr pair))) alist)))

  (define (execvpe name argv envp)

    (when (string-null? name)
      (error 'execvpe "no such file or directory" name))

    (let ((possible-paths 
           (append (if (string-contains name "/") (list name) '())
                   (enumerate-prefixes (get-default-path) name)))
          (environ envp))
      (for-each
       (lambda (abs)
         (attempt-exec abs argv environ))   ; and handle error cases
       possible-paths)))

    

  #|
      Function: waitpid

       This is an interface to waitpid(3), an extended version of wait.
       pid is an exact integer specifying which child(ren) to be waited.
       If it is a positive integer, it waits fot that specific child. If it is zero, it waits for any member of this process group. If it is -1, it waits for any child process. If it is less than -1, it waits for any child process whose process group id is equal to the absolute value of pid.

      Prototype:
      > (waitpid pid)

      Parameters:

        pid - pid of process to wait.

      Returns:

        3 values are returned:
        * Child process ID as exact integer.
        * Exit status as exact integer, or #f on abnormal termination.
        * Signal number as exact integer if the process was signaled, or #f on
        normal termination.
  |#


  #|
      Function: spawn

      fork and exec.

      Prototype:
      > (spawn command args . io-list path-search? env)

      Parameters:

        The same as exec, except for io-list, which is an optional list of three
        ports representing in, out, err respectively.  ('exec' takes these values
        as separate arguments, and they are all required.)  If io-list is not
        provided, it defaults to '(#f #f #f), i.e. the subprocess will inherit
        the parent's ports.

      Example:
      (start code)
      ;; ls -l
      (let-values ([(pid cin cout cerr) (spawn "ls" '("-l") (list #f #f #f))])
        (waitpid pid))

      ;; get output as string
      (let-values ([(in out) (pipe)])
        (define (port->string p)
          (let loop ([ret '()][c (read-char p)])
            (if (eof-object? c)
                (list->string (reverse ret))
                (loop (cons c ret) (read-char p)))))
        (let-values ([(pid cin cout cerr) (spawn "ls" '("-l") (list #f out #f))])
          (close-port out)
          (write (port->string (transcoded-port in (make-transcoder (utf-8-codec)))))
          (close-port in)
          (waitpid pid)))
      (end code)

      Returns:

        pid in out err is returned as multiple values.
  |#


  (define spawn
    (case-lambda
     ((command args io-list path-search? env)
      (unless (= (length io-list) 3)
              (assertion-violation 'spawn "io-list length should be 3" io-list))
      (unless (for-all (lambda (p) (or (binary-port? p) (not p))) io-list)
              (assertion-violation 'spawn "list of binary port or #f required"
                                   io-list))
      
      (receive (in out err) (apply values io-list)
               (let1 pid (%fork)
                     (if (zero? pid)
                         (guard (ex (#t (exit)))
                                (exec command args in out err path-search? env))
                         (values pid in out err)))))
     
     ((command args io-list path-search?) 
      (spawn command args io-list path-search? (get-environment-variables)))
     ((command args io-list)
      (spawn command args io-list #t))
     ((command args)
      (spawn command args '(#f #f #f)))))

  #|
      Function: pipe

      Creates a pipe, and returns two ports. The first returned port is an input port and the second is an output port. The data put to the output port can be read from the input port.

      Prototype:
      > (pipe)

      Returns:

        Two ports
  |#

  #|
      Function: getpid

      Returns the process ID of the current interpreter process.  

      Prototype:
      > (getpid)

      Returns:

        Process ID as exact integer 
  |#

  #|
      Function: call-process

      Run an external command using a shell.

      Prototype:
      > (call-process command)

      Returns:

        3 values:
        * The command's complete output on stdout (stderr is not captured).
        * The exit status of the command, or #f if it terminated abnormally.
        * #f on normal termination, or the signal number if it was terminated
          by a signal.
  |#

  #|
      Function: start-process

      Run an external command. Unlike call-process, start-process doesn't wait it's terminatation.

      Prototype:
      > (start-process command . os-depedent-args)

  |#

  #|
      Function: process-list

      Returns a process list as an a-list. Keys of the a-list depend on OS.

      Prototype:
      > (process-list)

      Returns:

        a process list as an a-list. Keys of the a-list depend on OS.
  |#

  #|
      Function: process-terminate!

      Kill process identified by OS dependent process identifier.

      Prototype:
      > (process-terminate! id)

      Returns:

        #t if terminated otherwise #f.
  |#

)
