source: project/release/3/formular/tags/1.12/formular.scm @ 13401

;;
;; 
;; A set of routines to read and extract fields from email form
;; submissions generated by the FormMail.pl script.
;;
;; Copyright 2008-2009 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/>.
;;

(require-extension utf8)
(require-extension utf8-srfi-13)
(require-extension utf8-srfi-14)

(require-extension srfi-1)
(require-extension rfc822)
(require-extension srfi-40)
(require-extension stream-ext)
(require-extension stream-sections)
(require-extension rb-tree)

(define-extension formular)


(declare (export multiline-field-start multiline-field-end
                 field-delim form-delim form-delim-len
                 read-form mbox->form-stream form-stream->tree))


(define multiline-field-start #\")
(define multiline-field-end #\")
(define field-delim #\:)
(define form-delim (string->list "------"))
(define form-delim-len (length form-delim))

(define-record-printer (section x out)
  (fprintf out "#(section depth=~S name=~S id=~S)"
           (section-depth x)
           (stream->string  (section-name x))
           (let ((id (section-id x)))
             (if (stream? id) (stream->string id) id))))

(define (take-one-line doc . rest)
  (let-optionals rest ((newline? #t))
  (cond
    ((stream-null? doc) (values #f stream-null stream-null))
    ((char=? (stream-car doc) #\newline)
     (values #f (if newline? (stream #\newline) stream-null) (stream-cdr doc)))
    (else
      (receive (result skip rest)
               (take-one-line (stream-cdr doc) newline?)
        (values result (stream-cons (stream-car doc) skip) rest))))))


(define $ (compose string->symbol stream->string ))

;; The next two procedures follow the interface of document->stream
;; from the stream-sections library to recognize the start of an RFC
;; 822 message, or the start of a form field, respectively.

(define (mbox-recognize-start strm)
  (let-values (((skip line rest)  (take-one-line strm)))
    (let* ((from-match  (stream-prefix= line (string->list "From ")))
           (name        (and from-match (stream-drop line 5))))
      (values (and name (make-section  1 name)) (if from-match stream-null line) rest))))


(define (form-fields-recognize-start strm)
  (let-values (((skip line rest)  (take-one-line strm)))
    (let ((delim-match  (stream-prefix= line form-delim)))
      (if delim-match rest (form-fields-recognize-start rest)))))



(define (read-field-value strm)
  (let ((multiline?  (char=? multiline-field-start (stream-car strm))))
    (let loop ((lst (list)) (strm (if multiline? (stream-cdr strm) strm)))
      (if (or (stream-null? strm)
              (and multiline? (char=? multiline-field-end (stream-car strm)))
              (and (not multiline?) (char=? (stream-car strm) #\newline)))
          (values (list->string (reverse lst)) strm)
          (loop (cons (stream-car strm) lst) (stream-cdr strm))))))


(define (read-form-fields strm)
  (let ((start (form-fields-recognize-start strm)))
    (let loop ((fields (list)) (strm start))
      (if (or (stream-null? strm) (section? (stream-car strm)))
          (values (reverse fields) strm)
          (if (not (char-alphabetic? (stream-car strm)))
              (loop fields (stream-cdr strm))
              (let-values (((field-name field-rest) 
                            (stream-break (lambda (x) (char=? x field-delim)) strm)))
                (let ((field-name ($ field-name))
                      (field-rest (and (not (stream-null? field-rest))
                                       (stream-drop-while char-whitespace? (stream-cdr field-rest)))))
                  (if (not field-rest)
                      (error 'read-form-fields "premature end of field" field-name))
                  (let-values (((field-value rest) (read-field-value field-rest)))
                     (loop (cons (list field-name field-value) fields)  rest)))))))))

;; Given an RFC 822 envelope and message streams, parses the headers
;; and fields that are found in the message stream, and returns an
;; s-exp of the form:
;;
;; (form (envelope <envelope-string>) 
;;       (headers <RFC 822 header alist>) 
;;       (fields <field alist>))
;;
(define (read-form envelope strm)
  (let* ((reader-strm  strm)
         (reader   (lambda (ignore) 
                     (let-values (((skip line rest)  (take-one-line reader-strm #f)))
                       (set! reader-strm rest)
                       (let ((str (stream->string line)))
                         str))))
         (headers  (rfc822-header->list reader-strm reader: reader)))
    (let-values (((fields rest)   (read-form-fields reader-strm)))
                (values `(form (envelope ,(stream->string envelope)) (headers ,headers) (fields ,fields))
                        rest))))

;;
;; Given the name of a Unix mbox file, reads the file and returns an
;; SRFI-40 stream representation of its contents, where each element
;; in the stream is a form s-expression in the format created by the
;; read-form procedure.
;;
(define (mbox->form-stream fname)
  (let ((doc (port->stream (open-input-file fname))))
    (let loop ((strm (document->sections mbox-recognize-start doc)))
      (stream-delay
       (if (stream-null? strm) stream-null
           (let ((sec (stream-car strm)))
             (if (not (section? sec)) 
                 (loop (stream-cdr strm))
                 (let-values (((form rest) (read-form (section-name sec) (stream-cdr strm))))
                     (stream-cons form (loop rest))))))))))

;;
;; Given an SRFI-40 stream created by the mbox->form-stream procedure,
;; returns an ordered dictionary structure, where the key is the email
;; address of the form sender, and the value is the list of all forms
;; submitted by that sender. The API of the tree object follows that
;; of the e.g. treap and rb-tree libraries.
;;
(define (form-stream->tree strm)
  (define (s<= x y) 
    (cond ((string-ci< x y) -1)
          ((string-ci= x y) 0)
          (else 1)))
  (define (subm< x y) 
    (let ((x-seconds (alist-ref 'date-seconds (cdr x)))
          (y-seconds (alist-ref 'date-seconds (cdr y))))
      (< x-seconds y-seconds)))
  (let loop ((tree (make-rb-tree s<=)) (strm strm))
    (let ((lookup (tree 'get))
          (update (tree 'put)))
      (if (stream-null? strm) tree
          (let ((form (stream-car strm)))
            (match form
                   (('form ('envelope envelope) ('headers headers) ('fields fields))
                    (let ((date (rfc822-header-ref headers "date") )
                          (from (rfc822-field->tokens (rfc822-header-ref headers "from") )))
                      (let ((date-seconds (rfc822-date->seconds date))
                            (from-address (match from 
                                                 ((u #\@ v)  (string-append u "@" v))
                                                 ((u v)      (string-append u "@" v))
                                                 (else (error 'form-stream->tree "invalid from address: " from)))))
                        (let ((exists     (lookup from-address #f))
                              (submission `(submission (date-seconds ,date-seconds) (fields . ,fields))))
                          (if exists 
                              (loop (update from-address 
                                            (merge (list submission) (cdr exists) subm<))
                                    (stream-cdr strm))
                              (loop (update from-address (list submission)) (stream-cdr strm)))))))
                   (else (error 'form-stream->tree "invalid form: " form))))))))