#!/bin/sh
exec guile -e "(ttn-do run-signed-batch-job)" -s $0 "$@" # -*- scheme -*-
!#
;;; run-signed-batch-job

;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2007, 2009,
;;   2010, 2011 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version.  There is NO WARRANTY.  See file COPYING for details.

;;; Commentary:

;; Usage: run-signed-batch-job [OPTIONS]
;;
;; Read standard input for a GPG-signed job message and execute it if
;; the signer is trusted and if the cache file does not have a duplicate
;; signature.  New signatures are added to the cache file.  Mail results.
;;
;; Options:
;;  -t, --trusted-signer SIGNER  -- accept jobs from SIGNER (can use multiply)
;;  -c, --sig-cache FILE         -- cache sigs in FILE
;;  -l, --logfile FILE           -- write transaction log to FILE (required)
;;  -m, --mailto ADDR            -- mail results to ADDR
;;  -s, --slack SECONDS          -- timeout on each command (default: 4)

;;; Code:

(define-module (ttn-do run-signed-batch-job)
  #:export (main)
  #:use-module ((ttn-do zzz banalities) #:select (check-hv
                                                  qop<-args))
  #:use-module ((ice-9 common-list) #:select (every))
  #:use-module ((ice-9 regex) #:select (string-match))
  #:use-module ((ttn-do zzz personally) #:select (FE fs fso fse make-fso))
  #:use-module ((ttn-do zzz subprocess) #:select (make-buffered-caller
                                                  call-process))
  #:use-module ((ice-9 expect) #:select (expect-strings))
  #:use-module ((ttn-do mogrify) #:select (find-file
                                           editing-buffer)))

(define *listener-contacts*
  '((default . "guile -q")
    (beguiled . "beguiled --client")
    (repl . "telnet localhost 55555")))

(define *listener-contact* (assq-ref *listener-contacts*
                                     ;; hardcode this for now
                                     'default))
(define *trusted-signers*  '())
(define *sig-cache*        "/dev/null")
(define *logfile*          #f)
(define *mailto*           "nobody")
(define *slack*            4)

;; logging

(define log!
  (let ((pid (getpid))
        (port #f))
    (lambda (fstr . args)
      (case fstr
        ((#:set-port!) (set! port (car args)))
        ((#:close-port!) (close-port port))
        (else
         (apply format port (string-append "~A[~A]: " fstr "~%")
                (strftime "%F %T" (localtime (current-time)))
                pid args)
         (flush-all-ports))))))

;; mail

(define (mail-buf gb recip subj)
  (editing-buffer gb
    (let ((p (point)))
      (goto-char (point-min))
      (let ((mailer (make-buffered-caller "mail -v -s"
                                          #:args (list subj recip)
                                          #:inb gb)))
        (mailer #:execute)
        (goto-char p)
        (mailer #:exit-val)))))

(define (mail/exit gb subj)
  (fse "~A !!!~%" subj)
  (editing-buffer gb
    (insert "\nORIGINAL FOLLOWS:\n\n"))
  (mail-buf gb *mailto* subj)
  (exit 1))

;; validation

(define (gpg . args)
  (make-buffered-caller "gpg" #:args args))

(define (verify-signed-message msg)
  (let* ((gb (editing-buffer msg))
         (verifier (gpg "--no-secmem-warning --verify" #:inb gb)))
    (if (not (zero? (verifier 'execute)))
        (throw 'signature-verification-error verifier)
        (let ((sig (list->string
                    (delete #\newline
                            (string->list
                             (editing-buffer gb
                               (goto-char (point-min))
                               (re-search-forward "^-+BEGIN PGP SIGNA.+-+$")
                               (search-forward "\n\n")
                               (let ((p (point)))
                                 (re-search-forward "^--")
                                 (buffer-substring p (match-beginning))))))))
              (body (editing-buffer gb
                      (goto-char (point-min))
                      (re-search-forward "^-+BEGIN PGP SIGNED MESSAGE-+$")
                      (re-search-forward "^Hash: .+\n\n")
                      (let ((p (point)))
                        (re-search-forward "^-+BEGIN PGP SIGNATURE-+$")
                        (buffer-substring p (match-beginning))))))
          (let ((sig-time #f) (sig-method #f) (signer #f))
            (editing-buffer (verifier 'errbuf)
              (goto-char (point-min))
              (re-search-forward "^gpg: Signature made (.+) using (.+)$")
              (set! sig-time (match-string 1))
              (set! sig-method (match-string 2))
              (re-search-forward "^gpg: Good signature from \"")
              (forward-char -1)
              (set! signer (read (buffer-port))))
            (vector signer sig-time sig-method sig body))))))

(define (siginfo:signer si) (vector-ref si 0))
(define (siginfo:time   si) (vector-ref si 1))
(define (siginfo:method si) (vector-ref si 2))
(define (siginfo:sig    si) (vector-ref si 3))
(define (siginfo:body   si) (vector-ref si 4))

(define (authenticate gb)
  (let ((sig-info (catch 'signature-verification-error
                         (lambda () (verify-signed-message gb))
                         (lambda (key verifier)
                           (log! "signature verification failure")
                           (editing-buffer gb
                             (goto-char (point-min))
                             (insert "\nSIG VERIFIER OUTBUF:\n")
                             (insert (verifier 'outbuf-string))
                             (insert "\nSIG VERIFIER ERRBUF:\n")
                             (insert (verifier 'errbuf-string)))
                           (mail/exit gb "sig-verif-failure")))))
    (cond ((every (lambda (trusted-signer)
                    (not (string-match trusted-signer
                                       (siginfo:signer sig-info))))
                  *trusted-signers*)
           (log! "sig found but not trusted:")
           (editing-buffer gb
             (goto-char (point-min))
             (FE (list siginfo:signer siginfo:time siginfo:method)
                 (lambda (extract)
                   (insert (fs "~A\t~A~%"
                               (procedure-name extract)
                               (extract sig-info)))
                   (log! "  ~A" (extract sig-info))))
             (insert "NO TRUSTED SIGNATURES FOUND!\n"))
           (mail/exit gb "no-trusted-sigs"))
          (else sig-info))))

(define (check-duplicates! sig)
  (editing-buffer (find-file *sig-cache*)
    (goto-char (point-min))
    (cond ((search-forward sig (point-max) #t)
           (let ((p (point)))
             (beginning-of-line)
             (log! "duplicate: ~A" (buffer-substring (point) p))
             (fse "duplicate!~%"))
           (fso "exiting failurefully~%")
           (exit 1))
          (else
           (insert (strftime "%F %T "
                             (localtime (current-time)))
                   sig "\n")
           (save-buffer)))))

;; processing

(define (port-on gb)
  (editing-buffer gb
    (buffer-port)))

(define (read-buf->command-proc gb)
  (let ((gbp (port-on gb)))
    (lambda ()
      (let ((v (read gbp)))
        (cond ((eof-object? v) v)
              (else
               (read-char gbp)          ; also consume \n
               (with-output-to-string   ; ugh
                 (lambda ()
                   (write v)
                   (newline)))))))))    ; add back the \n

(define (insert-answer-proc gb)
  (let ((fgb (make-fso (port-on gb))))
    (lambda (answer)
      (fgb (if (string-null? answer)
               ";~Aok~%"
               ";+~%~A;-~%~%")
           answer))))

(define (bg program)
  (let ((kid-rd/par-wr (pipe))
        (par-rd/kid-wr (pipe)))
    (let ((pid (primitive-fork)))
      (if (zero? pid)
          (exit (call-process program
                              #:inp (car kid-rd/par-wr)
                              #:outp (cdr par-rd/kid-wr)
                              #:errp (cdr par-rd/kid-wr)
                              #:norm #t))
          (cons (car par-rd/kid-wr) (cdr kid-rd/par-wr))))))

(define (repl-session interpreter prompt-re next log)
  (let* ((interp-ports (bg interpreter))
         (spew (lambda (string)
                 (display string (cdr interp-ports))
                 (flush-all-ports))))
    (let ((expect-port (car interp-ports))
          (expect-timeout *slack*)
          (expect-timeout-proc (lambda (s)
                                 ;;(fso "Time's up!~%")
                                 (throw 'done 'time-out)))
          (expect-eof-proc (lambda (s)
                             ;;(fso "EOF!!!~%")
                             (throw 'done 'eof))))
      (let loop ((command #f))          ; wait for first prompt
        (or (eof-object? command)
            (let* ((ans '())
                   (expect-char-proc (lambda (c) (set! ans (cons c ans)))))
              (sleep 2)
              (and command (spew command))
              (expect-strings
               (prompt-re => (lambda (prompt)
                               (log (list->string
                                     (reverse
                                      (list-tail
                                       ans
                                       (string-length prompt))))))))
              (loop (next))))))))

(define (run gb)
  (catch 'done
         (lambda ()
           (editing-buffer gb (goto-char (point-min)))
           (repl-session *listener-contact* "guile> "
                         (read-buf->command-proc gb)
                         (insert-answer-proc gb)))
         (lambda stuff
           (editing-buffer gb
             (insert "\n;;; caught something\n;;; " stuff "\n;;;\n"))))
  gb)

(define (process+report! gb)
  (log! "starting job")
  (mail-buf (run gb) *mailto* "results")
  (log! "finished job"))

;; dispatch

(define (main/qop qop)
  (qop 'trusted-signer (lambda (x)
                         (set! *trusted-signers*
                               (if (list? x)
                                   x
                                   (list x)))))
  (qop 'sig-cache (lambda (x)
                    (or (file-exists? x)
                        (call-with-output-file x identity))
                    (set! *sig-cache* x)))
  (qop 'logfile (lambda (x)
                  (log! #:set-port! (if (file-exists? x)
                                        (open-file x "a")
                                        (open-output-file x)))))
  (qop 'mailto (lambda (x)
                 (set! *mailto* x)))
  (qop 'slack (lambda (x)
                (set! *slack* (let ((n (string->number x)))
                                (if (zero? n) 4 n)))))
  (let* ((buf (editing-buffer (current-input-port)))
         (sig-info (authenticate buf)))
    (check-duplicates! (siginfo:sig sig-info))
    (process+report! (editing-buffer (siginfo:body sig-info))))
  (and (qop 'logfile)
       (log! #:close-port!))
  #t)

(define (main args)
  (check-hv args '((package . "ttn-do")
                   (version . "2.1")
                   ;; 1.0 original release in 2001
                   ;; 2.0 new option set, plus --help and --version support
                   ;; 2.1 support "--slack SECONDS"
                   (help . commentary)))
  (main/qop
   (qop<-args
    args '((trusted-signer (single-char #\t) (value #t) (merge-multiple? #t))
           (sig-cache      (single-char #\c) (value #t))
           (logfile        (single-char #\l) (value #t) (required? #t))
           (mailto         (single-char #\m) (value #t))
           (slack          (single-char #\s) (value #t))))))

;;; run-signed-batch-job ends here