;;
;;
;; A program to produce plain text output from email form submissions
;; generated by the FormMail.pl script.
;;
;; Copyright 2008-2010 Ivan Raikov and the Okinawa Institute of
;; Science and Technology.
;;
;; This program 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.
;;
;; This program 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.
;;
;; A full copy of the GPL license can be found at
;; .
;;
(import scheme chicken data-structures srfi-1 )
(require-extension posix utils srfi-13 srfi-14)
(require-extension mbox formular fmt rb-tree ssax getopt-long )
(foreign-declare "#include ")
(define log10 (foreign-lambda double "log10" double))
(define lookup-def
(lambda (k lst . rest)
(let-optionals rest ((default #f))
(let ((v (alist-ref k lst eq? default)))
(and v (if (or (atom? v) (and (pair? v) (pair? (cdr v)))) v
(car v)))))))
(define s+ string-append)
(define parser-error error)
(define (xml:str-handler fragment foll-fragment seed)
(if (string-null? foll-fragment)
(cons fragment seed)
(cons* foll-fragment fragment seed)))
(define (entity-ref->string entity)
(case entity
((quot) "\"")
((apos) "'")
((amp) "&")
((lt) "<")
((gt) ">")
(else (error 'entity-ref->string "unknown entity " entity))))
(define (alist->rb-tree alst)
(define (s<= x y)
(cond ((string-ci< x y) -1)
((string-ci= x y) 0)
(else 1)))
(let* ((tree (make-rb-tree s<=))
(update! (tree 'put!)))
(for-each (lambda (x) (let ((k (car x))
(v (cdr x)))
(update! k v)))
alst)
tree))
(define (xml:read-string s)
(let loop ((lst (list)) (iport (open-input-string s)))
(if (eof-object? (peek-char iport))
(string-concatenate (reverse lst))
(let-values (((lst token) (ssax:read-char-data iport #t xml:str-handler lst)))
(let ((v (and (not (eof-object? token ))
(list (xml-token-kind token) (xml-token-head token)))))
(cond ((and (pair? v) (eq? (car v) 'ENTITY-REF))
(let ((entity (cadr v)))
(loop (cons (entity-ref->string entity) lst) iport)))
(else (loop lst iport))))))))
(define (pp-submission/text id from-address time-seconds fields . rest)
(let-optionals rest ((include-fields #f))
(let ((text-fields (filter-map identity
(if include-fields
(map (lambda (x) (assoc x fields)) include-fields)
fields))))
(print id)
(for-each (lambda (field)
(let* ((section-title (->string (first field)))
(section-content (second field))
(section-content
(string-trim-both
(xml:read-string
(if (pair? section-content)
(list->string section-content)
section-content))
char-set:whitespace)))
(display (s+ section-title ": " section-content))
(print)))
text-fields))))
(define (make-id i width id-prefix idnum )
(s+ id-prefix " " (fmt #f (pad-char #\0 (fit/left width idnum))) "-" (->string i)))
(define (pp-formular-tree/text tree . rest)
(let-optionals rest ((id-prefix "Form Submission") (id-order #f) (include-fields #f)
(exclude #f) (after-time #f))
(let* ((id-list (list))
(keys (tree 'list-keys))
(order (or id-order (inexact->exact (ceiling (log10 (length keys)))))))
((tree 'foldi)
(lambda (from-address lst i)
(cond ((and exclude (member (string->symbol from-address) exclude)) i)
(else
(let loop ((lst lst))
(if (null? lst) i
(let* ((submission (cdr (last lst)))
(time-seconds (lookup-def 'time-seconds submission))
(fields (lookup-def 'fields submission)))
(if (or (not after-time) (> time-seconds after-time))
(let* ((width (if (positive? order) order 1))
(idnum (inexact->exact (- time-seconds 10e8)))
(id (let loop ((v 0) (id (make-id 1 width id-prefix idnum)))
(let ((hv (member id id-list)))
(if hv (loop (+ v 1) (make-id (+ 1 v) width id-prefix idnum))
(begin
(set! id-list (cons id id-list))
id))))))
(if (> (length lst) 1)
(print "Multiple submissions by " from-address ": using submission from "
(seconds->string time-seconds)))
(pp-submission/text id from-address time-seconds fields include-fields)))
(+ i 1)))))))
1))))
(define opt-defaults
`(
(order . 3)
(mbox-path . "mbox")
(prefix . "Form Submission")
))
(define (defopt x)
(lookup-def x opt-defaults))
(define opt-grammar
`(
(exclude "specify a colon-separated list of entries to exclude (default is none)"
(value (required "FROM1:FROM2")
(transformer ,(lambda (x) (list (map string->symbol (string-split x ":")))))))
(after-date "omit entries before given date (in seconds)"
(value (required "N")
(predicate ,string->number)
(transformer ,string->number)))
(fields "specify a colon-separated list of fields to process (default is all fields)"
(value (required "FIELD1:FIELD2:...")
(transformer ,(lambda (x) (list (map string->symbol (string-split x ":")))))))
(mbox-path ,(string-append "specify path to input mbox (default: " (defopt 'mbox-path) ")")
(value (required "PATH")
(default ,(defopt 'mbox-path))
))
(order ,(string-append "specify order of form id (default: " (->string (defopt 'order)) ")")
(value
(required "N")
(default ,(defopt 'order))
(transformer ,(lambda (x) (inexact->exact (string->number x))))))
(prefix ,(string-append "specify prefix for text page title (default: " (defopt 'prefix) ")")
(value (required "STRING")
(default ,(defopt 'prefix))))
(write-alist "write an alist representation to FILE"
(value (required "FILE")))
(read-alist "read an alist representation from FILE"
(value (required "FILE")))
(help (single-char #\h))
))
;; Use args:usage to generate a formatted list of options (from OPTS),
;; suitable for embedding into help text.
(define (form2txt:usage)
(print "Usage: form2txt [options...] operands ")
(newline)
(print "The following options are recognized: ")
(newline)
(print (parameterize ((indent 5)) (usage opt-grammar)))
(exit 1))
;; Process arguments and collate options and arguments into OPTIONS
;; alist, and operands (filenames) into OPERANDS.
(define opts (getopt-long (command-line-arguments) opt-grammar))
(define opt (make-option-dispatch opts opt-grammar))
(define (main options operands)
(if (opt 'help) (form2txt:usage))
(let ((tree (if (opt 'read-alist)
(alist->rb-tree (read (open-input-file (opt 'read-alist))))
(mbox-messages->form-tree
(mbox-file->messages/byte-blob-stream (opt 'mbox-path))))))
(if (opt 'write-alist)
(let ((oport (open-output-file (opt 'write-alist))))
(display "(" oport)
((tree 'for-each-ascending)
(lambda (x)
(let ((x1 (cons (car x)
(map (lambda (lst)
(let* ((submission (cdr lst))
(time-seconds (lookup-def 'time-seconds submission))
(fields (lookup-def 'fields submission))
(pf (lambda (f)
(list (first f) (list->string (second f))))))
`(submission (time-seconds ,time-seconds)
(fields ,(map pf fields)))))
(cdr x)))))
(pp x1 oport))))
(display ")" oport) ))
(pp-formular-tree/text tree
(opt 'prefix)
(opt 'order)
(opt 'fields)
(opt 'exclude)
(opt 'after-date)
)))
(main opts (opt '@))