gash/gash/shell.scm

;;; Gash -- Guile As SHell
;;; Copyright © 2018, 2019, 2020 Timothy Sample <samplet@ngyro.com>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gash shell)
  #:use-module (gash built-ins)
  #:use-module (gash compat)
  #:use-module (gash compat textual-ports)
  #:use-module (gash environment)
  #:use-module (gash pattern)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (sh:and
            sh:async
            sh:case
            sh:cond
            sh:exec-let
            sh:exec
            sh:for
            sh:not
            sh:or
            sh:pipeline
            sh:set-redirects
            sh:subshell
            sh:substitute-command
            sh:while
            sh:with-redirects
            sh:until))

;;; Commentary:
;;;
;;; This module provides functions for executing Shell language
;;; constructs.
;;;
;;; Code:

(define ignore-errexit? (make-parameter #f))

(define (without-errexit thunk)
  (parameterize ((ignore-errexit? #t)) (thunk)))

(define (errexit)
  (unless (or (zero? (get-status)) (ignore-errexit?))
    (when (getopt 'errexit)
      (sh:exit))))

(define (install-current-ports!)
  "Install all current ports into their usual file descriptors.  For
example, if @code{current-input-port} is a @code{file-port?}, make the
process file descriptor 0 refer to the file open for
@code{current-input-port}.  If any current port is a @code{port?} but
not a @code{file-port?}, its corresponding file descriptor will refer
to @file{/dev/null}."
  ;; XXX: Input/output ports?  Closing other FDs?
  (for-each (lambda (i)
              (match ((fd->current-port i))
                ((? file-port? port)
                 (dup port i))
                ((? input-port? port)
                 (dup (open-file "/dev/null" "r") i))
                ((? output-port? port)
                 (dup (open-file "/dev/null" "w") i))
                (_ #t)))
            (iota *fd-count*)))

(define (exec-utility bindings path name args)
  "Execute @var{path} as a subprocess with extra environment variables
@var{bindings}.  The first argument given to the new process will be
@var{name}, and the rest of the arguments will be @var{args}."
  (let ((utility-env (get-environ bindings)))
    ;; We need to flush all ports here to ensure the proper sequence
    ;; of output.  Without flushing, output that we have written could
    ;; stay in a buffer while the utility (which does not know about
    ;; the buffer) produces its output.
    (flush-all-ports)
    (match (primitive-fork)
      (0 (install-current-ports!)
         (apply execle path utility-env name args))
      (pid (match-let (((pid . status) (waitpid pid)))
             (set-status! (status:exit-val status)))))))

(define (slashless? s)
  "Test if the string @var{s} does not contain any slashes ('/')."
  (not (string-index s #\/)))

(define (split-search-path s)
  "Split the search path string @var{s}."
  (if (string-null? s) '() (string-split s #\:)))

(define (find-utility name)
  "Search for the path of the utility @var{name} using the current
search path as specified by the environment variable @code{$PATH}.  If
it cannot be found, return @code{#f}."
  (let loop ((prefixes (split-search-path (getvar "PATH" ""))))
    (and (pair? prefixes)
         (let* ((prefix (car prefixes))
                (path (if (string-suffix? "/" prefix)
                          (string-append prefix name)
                          (string-append prefix "/" name))))
           (if (access? path X_OK)
               path
               (loop (cdr prefixes)))))))

(define (sh:exec-let bindings name . args)
  "Find and execute @var{name} with arguments @var{args} and extra
environment variable bindings @var{bindings}."
  (when (getopt 'xtrace)
    (format (current-error-port) "+~a\n"
            (string-join (cons name
                               (map (lambda (x)
                                      (if (string-null? x) "''"
                                          x)) args)))))
  (if (slashless? name)
      (or (and=> (search-special-built-ins name)
                 (lambda (proc)
                   (for-each (match-lambda
                               ((name . value)
                                (setvar! name value)))
                             bindings)
                   (set-status! (apply proc args))))
          (and=> (getfun name)
                 (lambda (proc)
                   (save-variables-excursion (map car bindings)
                     (lambda ()
                       (for-each (match-lambda
                                   ((name . value)
                                    (setvar! name value)))
                                 bindings)
                       (with-arguments (cons (car (program-arguments)) args)
                         (lambda ()
                           (call-with-return
                            (lambda ()
                              (apply proc args)))))))))
          (and=> (search-built-ins name)
                 (lambda (proc)
                   (save-variables-excursion (map car bindings)
                     (lambda ()
                       (for-each (match-lambda
                                   ((name . value)
                                    (setvar! name value)))
                                 bindings)
                       (let ((exit-val (apply proc args)))
                         (set-status! exit-val))))))
          (and=> (find-utility name)
                 (lambda (path)
                   (exec-utility bindings path name args)))
          (begin (format (current-error-port)
                         "~a: ~a: Command not found.~%"
                         (car (program-arguments)) name)
                 (set-status! 127)))
      (exec-utility bindings name name args))
  (errexit))

(define (sh:exec name . args)
  "Find and execute @var{name} with arguments @var{args}."
  (apply sh:exec-let '() name args))


;;; Redirects.

(define (process-redir redir)
  "Convert @var{redir} into a list consisting of the current-port
parameter to be updated, the port that should be its new value (or
@code{#f} if it should be considered closed), and a boolean indicating
if it is our responsibility to close the port."

  (define* (make-processed-redir fd target #:optional (open-flags 0))
    (let ((port (match target
                  ((? port?) target)
                  ((? string?) (open target open-flags))
                  ;; TODO: Verify open-flags.
                  ((? integer?) ((fd->current-port target)))
                  (#f #f))))
      `(,(fd->current-port fd) ,port ,(string? target))))

  (match redir
    (('< (? integer? fd) (? string? filename))
     (make-processed-redir fd filename O_RDONLY))
    (('> (? integer? fd) (? string? filename))
     (let* ((clobber-flags (logior O_WRONLY O_CREAT O_TRUNC))
            (flags (if (getopt 'noclobber)
                       (logior clobber-flags O_EXCL)
                       clobber-flags)))
       (make-processed-redir fd filename flags)))
    (('>! (? integer? fd) (? string? filename))
     (make-processed-redir fd filename (logior O_WRONLY O_CREAT O_TRUNC)))
    (('>> fd filename)
     (make-processed-redir fd filename (logior O_WRONLY O_CREAT O_APPEND)))
    (('<> fd filename)
     (make-processed-redir fd filename (logior O_RDWR O_CREAT)))
    (('<& (? integer? fd1) (? integer? fd2))
     (make-processed-redir fd1 fd2))
    (('<& (? integer? fd) '-)
     (make-processed-redir fd #f))
    (('>& (? integer? fd1) (? integer? fd2))
     (make-processed-redir fd1 fd2))
    (('>& (? integer? fd) '-)
     (make-processed-redir fd #f))
    (('<< (? integer? fd) text)
     (let ((port (tmpfile)))
       (display text port)
       (seek port 0 SEEK_SET)
       (make-processed-redir fd port)))))

(define (sh:set-redirects redirs)
  "Put the redirects @var{redirs} into effect."
  (let loop ((redirs redirs))
    (match redirs
      (() #t)
      ((redir . rest)
       (match (false-if-exception (process-redir redir))
         (#f (set-status! 1)
             (errexit))
         ((parameter port close?)
          (parameter port)
          (loop rest)))))))

(define (sh:with-redirects redirs thunk)
  "Call @var{thunk} with the redirects @var{redirs} in effect."
  ;; This may be too clever!  We need to parameterize a variable
  ;; number of things in a particular order, and this seems to be the
  ;; only way.
  ((fold-right (lambda (redir thunk)
                 (lambda ()
                   (match (false-if-exception (process-redir redir))
                     (#f (set-status! 1)
                         (errexit))
                     ((parameter port close?)
                      (parameterize ((parameter port))
                        (thunk))
                      (cond
                       (close? (close-port port))
                       ((output-port? port) (force-output port)))))))
               thunk
               redirs)))


;;; Subshells and command substitution.

(define* (%subshell thunk)
  "Run @var{thunk} in a new process and return the ID of the new
process."
  ;; We need to flush all ports before forking to avoid copying the
  ;; port buffers into the child process, which could lead to
  ;; duplicate output.
  (flush-all-ports)
  (match (primitive-fork)
    (0 (dynamic-wind
         (lambda () #t)
         (lambda ()
           (restore-signals)
           (set-atexit! #f)
           ;; We need to preserve the status given to 'exit', so we
           ;; catch the 'quit' key here.
           (catch 'quit
             thunk
             (lambda (_ status)
               (primitive-exit status)))
           (primitive-exit (get-status)))
         (lambda ()
           (primitive-exit 1))))
    (pid pid)))

(define (sh:subshell thunk)
  "Run @var{thunk} in a subshell environment."
  (match-let* ((pid (%subshell thunk))
               ((pid . status) (waitpid pid)))
    (set-status! (status:exit-val status))
    (errexit)))

(define (sh:substitute-command thunk)
  "Run @var{thunk} in a subshell environment and return its output as
a string."
  (match-let* (((sink . source) (pipe))
               (thunk* (lambda ()
                         (close-port sink)
                         (with-output-to-port source thunk)))
               (pid (%subshell thunk*)))
    (close-port source)
    (match-let ((result (string-trim-right (get-string-all sink) #\newline))
                ((pid . status) (waitpid pid)))
      (set-status! (status:exit-val status))
      (errexit)
      result)))


;;; Pipelines.

(define (plumb in out close thunk)
  "Run @var{thunk} in a new process with @code{current-input-port} set
to @var{in} and @code{current-output-port} set to @var{out}.  If
@var{in} or @var{out} is @code{#f}, the corresponding ``current'' port
is left unchanged.  Unless it is @code{#f}, the port @var{close} will
be closed in the new process."
  (let* ((thunk* (lambda ()
                   (when close (close-port close))
                   (let ((in (or in (current-input-port)))
                         (out (or out (current-output-port))))
                     (parameterize ((current-input-port in)
                                    (current-output-port out))
                       (thunk)))))
         (pid (%subshell thunk*)))
    (when in (close-port in))
    (when out (close-port out))
    pid))

(define (waitpid/any pids)
  "Wait for any process with an ID in the list @var{pids} to terminate
and return its status information."
  (let loop ((interval 10))
    (or (any (lambda (pid)
               (match (waitpid pid WNOHANG)
                 ((0 . _) #f)
                 (x x)))
             pids)
        (begin
          (usleep interval)
          (loop (if (< interval 160)
                    (* 2 interval)
                    interval))))))

(define (sh:pipeline . thunks)
  "Run each thunk in @var{thunks} in its own process with the output
of each thunk sent to the input of the next thunk."
  (define (plumb-thunks)
    (let loop ((thunks thunks) (in #f) (pids '()))
      (match thunks
        (() pids)
        ((thunk) (reverse! (cons (plumb in #f #f thunk) pids)))
        ((thunk . rest)
         (match-let (((next-in . out) (pipe)))
           (loop rest next-in (cons (plumb in out next-in thunk) pids)))))))

  (let ((pids (plumb-thunks)))
    (unless (null? pids)
      (let ((last-pid (last pids)))
        ;; We have to wait for all the processes to finish so we can
        ;; reap them.  We do this by polling them with 'waitpid'.
        ;; This is something of a naive approach, but it works for now
        ;; and will be easier to improve later when we have job
        ;; control.
        (let loop ((pids pids))
          (unless (null? pids)
            (match (waitpid/any pids)
              ((pid . status)
               (when (= pid last-pid)
                 (set-status! (status:exit-val status)))
               (loop (remove (cut = pid <>) pids)))))))
      (errexit))))


;;; Boolean expressions.

(define (sh:and thunk1 thunk2)
  "Run @var{thunk1} and if it exits with status zero, run
@var{thunk2}."
  (without-errexit thunk1)
  (when (= (get-status) 0)
    (thunk2)
    (errexit)))

(define (sh:or thunk1 thunk2)
  "Run @var{thunk1} and if it exits with a nonzero status, run
@var{thunk2}."
  (without-errexit thunk1)
  (unless (= (get-status) 0)
    (thunk2)
    (errexit)))

(define (sh:not thunk)
  "Run @var{thunk}, inverting its exit status."
  (without-errexit thunk)
  (let ((inverted-status (if (= (get-status) 0) 1 0)))
    (set-status! inverted-status)))


;;; Loops.

(define (sh:for bindings thunk)
  "Run @var{thunk} for each binding in @var{bindings}.  The value of
@var{bindings} have the form @code{(@var{name} (@var{value} ...))}."
  (set-status! 0)
  (match-let (((name (values ...)) bindings))
    (call-with-break
      (lambda ()
        (for-each (lambda (value)
                    (setvar! name value)
                    (call-with-continue thunk))
                  values)))))

(define (sh:while test-thunk thunk)
  (call-with-break
    (lambda ()
      (let loop ((last-status 0))
        (without-errexit test-thunk)
        (cond
         ((= (get-status) 0)
          (call-with-continue thunk)
          (loop (get-status)))
         (else
          (set-status! last-status)))))))

(define (sh:until test-thunk thunk)
  (sh:while (lambda () (sh:not test-thunk)) thunk))


;;; Conditionals.

(define (sh:case value . cases)
  (set-status! 0)
  (let loop ((cases cases))
    (match cases
      (() #t)
      (((patterns thunk) . tail)
       (if (any (cut pattern-match? <> value) patterns)
           (thunk)
           (loop tail))))))

(define (sh:cond . cases)
  (let loop ((cases cases))
    (match cases
      (() (set-status! 0))
      (((#t thunk))
       (thunk))
      (((test-thunk thunk) . tail)
       (without-errexit test-thunk)
       (if (= (get-status) 0)
           (thunk)
           (loop tail))))))


;;; Asynchronous commands.

(define (sh:async thunk)
  "Run @var{thunk} asynchronously."
  (let ((pid (%subshell thunk)))
    (set-last-job! pid)
    (set-status! 0)))