run-signed-batch-job.scm

[thi]

say you're stuck behind a low-bandwidth metered dialup account (ugh) but
would like to do some lengthy remote hacking.  well, if you're patient,
are able to set up a persistent (session) repl server, and do the right
GPG incantations on both ends, you can use the following program (say,
from a ~/.procmailrc recipe) and your favorite GPG-enabled MUA, to enjoy
guile non-locally.  wheee!

please note that this program can be used as a basis for asynchronous
agent migration and other less gloriously named malware.  the
possibilities (for rendering your system(s) suboptimal) are endless!
YHBW, YMMV, HAND...

C-c / s
thi


____________________________________
#!/bin/sh
exec guile -s $0 "$@"                                   # -*- scheme -*-
!#
;;; Copyright (C) 2001 Thien-Thi Nguyen
;;; This program is part of ttn-do, released under GNU GPL v2 with ABSOLUTELY
;;; NO WARRANTY.  See http://www.gnu.org/copyleft/gpl.txt for details.
;;;
;;; 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:
;;; --trusted-signer SIGNER     -- accept jobs from SIGNER (can use multiply)
;;; --sig-cache FILE            -- cache sigs in FILE
;;; --results-recip ADDR        -- mail results to ADDR

(debug-enable 'debug 'backtrace)

;; remove when ttn-pers-scheme-0.19 installed -- for (ttn gpgutils)
(set! %load-path (cons "/home/ttn/build/ttn-pers-scheme" %load-path))

;;;---------------------------------------------------------------------------
;;; configuration

(define trusted-signers '())
(let loop ((ls (command-line)))
  (or (null? ls)
      (let ((first (car ls)))
        (cond ((and (string=? "--trusted-signer" first)
                    (false-if-exception (cadr ls)))
               => (lambda (signer)
                    (set! trusted-signers (cons signer trusted-signers))
                    (loop (cddr ls))))
              (else (loop (cdr ls)))))))

(define sig-cache "/dev/null")
(cond ((member "--sig-cache" (command-line))
       => (lambda (rest)
            (set! sig-cache (cadr rest)))))

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

;; hardcode this for now
(define listener-contact (assq-ref listener-contacts 'default))

(define results-recip "nobody")
(cond ((member "--results-recip" (command-line))
       => (lambda (rest)
            (set! results-recip (cadr rest)))))

;;;---------------------------------------------------------------------------
;;; support

(use-modules (ice-9 common-list) (ice-9 regex))
(use-modules (ttn echo) (ttn gap-buffer) (ttn shellutils))
(use-modules (ttn gpgutils) (ttn edit))

(define buf (make-gap-buffer (current-input-port)))

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

;;;---------------------------------------------------------------------------
;;; validate

(define (authenticate gb)
  (let ((mail/exit (lambda (subj)
                     (echo subj "!!!")
                     (editing-buffer gb
                       (insert "\nORIGINAL FOLLOWS:\n\n"))
                     ;(mail-buf gb "ttn" subj)
                     (exit 1))))
    (let ((sig-info (catch 'signature-verification-error
                           (lambda () (verify-signed-message buf))
                           (lambda (key verifier)
                             (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 "sig-verif-failure")))))
      (cond ((every (lambda (trusted-signer)
                      (not (string-match trusted-signer
                                         (siginfo:signer sig-info))))
                    trusted-signers)
             (echo "sig found but not trusted:" sig-info)
             (editing-buffer gb
               (goto-char (point-min))
               (insert "sig: " sig-info)
               (insert "NO TRUSTED SIGNATURES FOUND!\n"))
             (mail/exit "no-trusted-sigs"))
            (else sig-info)))))

;; check now to minimize module loading (exit if bad)

(define sig-info (authenticate buf))

(use-modules (ttn fileutils))           ; todo: move checking to cache daemon

(define (check-duplicates sig)
  (editing-buffer (find-file sig-cache)
    (goto-char (1+ (point-min)))
    (cond ((search-forward sig (point-max) #t)
           (let ((p (point)))
             (search-backward "\n")
             (echo "duplicate:" (buffer-substring (1+ (point)) p))
             (write-line "duplicate!" (current-error-port)))
           (echo "exiting failurefully")
           (exit 1))
          (else
           (insert (strftime "%Y-%m-%d %H:%M:%S "
                             (localtime (current-time)))
                   sig "\n")
           (save-buffer (current-buffer))))))

(check-duplicates (siginfo:sig sig-info))

;;;---------------------------------------------------------------------------
;;; processing

(define job-buf (make-gap-buffer (siginfo:body sig-info)))

(use-modules (ice-9 expect))

(define (read-buf->command-proc gb)
  (let ((gbp (make-gap-buffer-port gb)))
    (lambda ()
      (let ((v (read gbp)))
        (cond ((eof-object? v) v)
              (else
               (read-char gbp)          ; also consume \n
               (with-output-to-string   ; ugh
                 (lambda ()
                   (echow v)))))))))    ; `echow' adds back \n

(define (insert-answer-proc gb)
  (let ((gbp (make-gap-buffer-port gb)))
    (lambda (answer)
      (with-output-to-port gbp
        (lambda ()
          (cond ((string=? "" answer) (echo ";ok"))
                (else (echo ";+")
                      (echo-n answer)
                      (echo ";-")
                      (echo))))))))

(define (bg program)
  (let ((kid-rd/par-wr (pipe))
        (par-rd/kid-wr (pipe)))
    (let ((pid (primitive-fork)))
      (if (= 0 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 4)                    ; todo: parameterize
          (expect-timeout-proc (lambda (s)
                                 ;;(echo "Time's up!")
                                 (throw 'done 'time-out)))
          (expect-eof-proc (lambda (s)
                             ;;(echo "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> "     ; todo: parameterize
                         (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)
  (mail-buf (run gb) results-recip "results"))

(exit (process/report job-buf))

;;; $RCSfile: run-signed-batch-job.scm,v $$Revision: 1.1 $ ends here