;;
;; 
;; 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
;; <http://www.gnu.org/licenses/>.
;;


(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 <math.h>")
(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 
			(and (positive? (length keys)) (inexact->exact (ceiling (log10 (length keys)))))
			3)))
     (if (null? keys) (error 'pp-formular-tree/text "empty list of forms"))
     ((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 (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
			   (or (opt 'prefix) (defopt 'prefix))
			   (opt 'order)
			   (opt 'fields)
			   (opt 'exclude)
			   (opt 'after-date)
			   )))


(main opts (opt '@))