gash/gash/job.scm

;;; Gash --- Guile As SHell
;;; Copyright © 2016,2017,2018 R.E.W. van Beusekom <rutger.van.beusekom@gmail.com>
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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 job)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-8)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)

  #:use-module (gash io)
  #:use-module (gash util)

  #:export (
            bg
            fg
            display-job
            job-table
            job?
            job-add-process
            job-control-init
            job-debug-id
            job-setup-process
            job-status
            new-job
            report-jobs
            wait
            ))

(define-record-type <process>
  (make-process pid command status)
  process?
  (pid process-pid)
  (command process-command)
  (status process-status set-process-status!))

(define-record-type <job>
  (make-job id pgid processes debug-id)
  job?
  (id job-id)
  (pgid job-pgid set-job-pgid!)
  (processes job-processes set-job-processes!)
  (debug-id job-debug-id))

(define debug-id
  (let ((id -1))
    (lambda ()
      (set! id (1+ id))
      (number->string id))))

(define (new-job)
  (let ((job (make-job (+ 1 (length job-table)) #f '() (debug-id))))
    (set! job-table (cons job job-table))
    job))

(define job-table '()) ;; list of <job>

(define (job-index index)
  (let ((index (- (length job-table) index)))
    (if (<= 0 index)
        (list-ref job-table index)
        #f)))

(define (status->state status)
  (cond ((not status) 'Running)
        ((status:exit-val status) 'Done)
        ((status:term-sig status) 'Terminated)
        ((status:stop-sig status) 'Stopped)))

(define (job-command job)
  (string-join (map (compose string-join process-command) (reverse (job-processes job))) " | "))

(define (display-job job)
  (stdout "[" (job-id job) "] " (map status->state (job-status job)) "\t\t"
          (job-command job)))

(define (job-status job)
  (map process-status (job-processes job)))

(define (job-update job pid status)
  (unless (= 0 pid)
    (let ((proc (find (compose (cut eqv? pid <>) process-pid) (job-processes job))))
      (when proc
        (set-process-status! proc status)))))

(define (job-running? job)
  (find (compose not process-status) (job-processes job)))

(define (job-stopped? job)
  (find status:stop-sig (filter-map process-status (job-processes job))))

(define (job-completed? job)
  (let ((state (map (compose status->state process-status) (job-processes job))))
    (every (cut member <> '(Done Terminated)) state)))

(define (add-to-process-group job pid)
  (let* ((interactive? (isatty? (current-error-port)))
         (pgid (if interactive?
                   (or (job-pgid job) pid)
                   (getpgrp))))
    (set-job-pgid! job pgid)
    (when interactive? (setpgid pid pgid))
    pgid))

(define (job-add-process fg? job pid command)
  (let ((pgid (add-to-process-group job pid)))
    (set-job-pgid! job pgid)
    (stderr "job-add-process fg?=~a\n" fg?)
    (when (and (isatty? (current-error-port))
               fg?)
      (tcsetpgrp (current-error-port) pgid))
    (set-job-processes! job (cons (make-process pid command #f) (job-processes job)))))

(define (job-setup-process fg? job)
  (when (isatty? (current-error-port))
    (when (and (isatty? (current-error-port))
               fg?)
      (tcsetpgrp (current-error-port) (add-to-process-group job (getpid))))
    (map (cut sigaction <> SIG_DFL)
         (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD))))

(define (job-control-init)
  (when (isatty? (current-error-port))
    (let ((pgid (getpgrp)))
      (while (and #f  ;; FIXME: make check backgrouds our tests
                  (isatty? (current-error-port))
                  (not (eqv? (tcgetpgrp (current-error-port)) pgid)))
        (kill (- pgid) SIGTTIN))) ;; oops we are not in the foreground
    (map (cut sigaction <> SIG_IGN) (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU))
    (sigaction SIGCHLD SIG_DFL)
    (let ((pid (getpid)))
      (setpgid pid pid) ;; create new process group for ourself
      (tcsetpgrp (current-error-port) pid))))

(define (reap-jobs)
  (set! job-table (filter (disjoin job-running? job-stopped?) job-table)))

(define (report-jobs)
  (when (not (null? job-table))
    (let* ((pid-status (waitpid WAIT_ANY (logior WUNTRACED WNOHANG)))
           (pid (car pid-status))
           (status (cdr pid-status)))
      (unless (= 0 pid)
        (map (cut job-update <> pid status) job-table)
        (map display-job (filter job-completed? job-table))
        (reap-jobs)))))

(define (wait job)
  (when (job-running? job)
    (let loop ()
      (let* ((pid-status (waitpid (- (job-pgid job)) WUNTRACED))
             (pid (car pid-status))
             (status (cdr pid-status)))
        (job-update job pid status)
        (if (job-running? job) (loop)))))
  (unless (job-completed? job)
    (newline) (display-job job))
  (reap-jobs)
  (or (find (negate zero?) (job-status job))
      0))

(define (fg index)
  (let ((job (job-index index)))
    (cond (job
           (let ((pgid (job-pgid job)))
             (tcsetpgrp (current-error-port) pgid)
             (kill (- (job-pgid job)) SIGCONT))
           (stdout (job-command job))
           (wait job))
          (#t
           (stderr "fg: no such job " index)))))

(define (bg index)
  (let ((job (job-index index)))
    (cond (job
           (map (cut set-process-status! <>  #f) (job-processes job))
           (kill (- (job-pgid job)) SIGCONT))
          (#t
           (stderr "fg: no such job " index)))))