source: project/release/3/formular/trunk/formular.scm @ 13317

Last change on this file since 13317 was 13317, checked in by Ivan Raikov, 11 years ago

Bug fixes.

File size: 7.1 KB
Line 
1;;
2;;
3;; A set of routines to read and extract fields from email form
4;; submissions generated by the FormMail.pl script.
5;;
6;; Copyright 2008-2009 Ivan Raikov and the Okinawa Institute of
7;; Science and Technology.
8;;
9;; This program is free software: you can redistribute it and/or
10;; modify it under the terms of the GNU General Public License as
11;; published by the Free Software Foundation, either version 3 of the
12;; License, or (at your option) any later version.
13;;
14;; This program is distributed in the hope that it will be useful, but
15;; WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
17;; General Public License for more details.
18;;
19;; A full copy of the GPL license can be found at
20;; <http://www.gnu.org/licenses/>.
21;;
22
23(require-extension utf8)
24(require-extension utf8-srfi-13)
25(require-extension utf8-srfi-14)
26
27(require-extension srfi-1)
28(require-extension rfc822)
29(require-extension srfi-40)
30(require-extension stream-ext)
31(require-extension stream-sections)
32(require-extension rb-tree)
33
34(define-extension formular)
35
36
37(declare (export multiline-field-start multiline-field-end
38                 field-delim form-delim form-delim-len
39                 read-form mbox->form-stream form-stream->tree))
40
41
42(define multiline-field-start #\")
43(define multiline-field-end #\")
44(define field-delim #\:)
45(define form-delim (string->list "------"))
46(define form-delim-len (length form-delim))
47
48(define-record-printer (section x out)
49  (fprintf out "#(section depth=~S name=~S id=~S)"
50           (section-depth x)
51           (stream->string  (section-name x))
52           (section-id x) ))
53
54(define (take-one-line doc . rest)
55  (let-optionals rest ((newline? #t))
56  (cond
57    ((stream-null? doc) (values #f stream-null stream-null))
58    ((char=? (stream-car doc) #\newline)
59     (values #f (if newline? (stream #\newline) stream-null) (stream-cdr doc)))
60    (else
61      (receive (result skip rest)
62               (take-one-line (stream-cdr doc) newline?)
63        (values result (stream-cons (stream-car doc) skip) rest))))))
64
65
66(define $ (compose string->symbol stream->string ))
67
68;; The next two procedures follow the interface of document->stream
69;; from the stream-sections library to recognize the start of an RFC
70;; 822 message, or the start of a form field, respectively.
71
72(define (mbox-recognize-start strm)
73  (let-values (((skip line rest)  (take-one-line strm)))
74    (let* ((from-match  (stream-prefix= line (string->list "From ")))
75           (name        (and from-match (stream-drop line 5))))
76      (values (and name (make-section  1 name)) (if from-match stream-null line) rest))))
77
78
79(define (form-fields-recognize-start strm)
80  (let-values (((skip line rest)  (take-one-line strm)))
81    (let ((delim-match  (stream-prefix= line form-delim)))
82      (if delim-match rest (form-fields-recognize-start rest)))))
83
84
85
86(define (read-field-value strm)
87  (let ((multiline?  (char=? multiline-field-start (stream-car strm))))
88    (let loop ((lst (list)) (strm (if multiline? (stream-cdr strm) strm)))
89      (if (or (stream-null? strm)
90              (and multiline? (char=? multiline-field-end (stream-car strm)))
91              (and (not multiline?) (char=? (stream-car strm) #\newline)))
92          (values (list->string (reverse lst)) strm)
93          (loop (cons (stream-car strm) lst) (stream-cdr strm))))))
94
95
96(define (read-form-fields strm)
97  (let ((start (form-fields-recognize-start strm)))
98    (let loop ((fields (list)) (strm start))
99      (if (or (stream-null? strm) (section? (stream-car strm)))
100          (values (reverse fields) strm)
101          (if (not (char-alphabetic? (stream-car strm)))
102              (loop fields (stream-cdr strm))
103              (let-values (((field-name field-rest) 
104                            (stream-break (lambda (x) (char=? x field-delim)) strm)))
105                (let ((field-name ($ field-name))
106                      (field-rest (and (not (stream-null? field-rest))
107                                       (stream-drop-while char-whitespace? (stream-cdr field-rest)))))
108                  (if (not field-rest)
109                      (error 'read-form-fields "premature end of field" field-name))
110                  (let-values (((field-value rest) (read-field-value field-rest)))
111                     (loop (cons (list field-name field-value) fields)  rest)))))))))
112
113;; Given an RFC 822 envelope and message streams, parses the headers
114;; and fields that are found in the message stream, and returns an
115;; s-exp of the form:
116;;
117;; (form (envelope <envelope-string>)
118;;       (headers <RFC 822 header alist>)
119;;       (fields <field alist>))
120;;
121(define (read-form envelope strm)
122  (let* ((reader-strm  strm)
123         (reader   (lambda (ignore) 
124                     (let-values (((skip line rest)  (take-one-line reader-strm #f)))
125                       (set! reader-strm rest)
126                       (let ((str (stream->string line)))
127                         str))))
128         (headers  (rfc822-header->list reader-strm reader: reader)))
129    (let-values (((fields rest)   (read-form-fields reader-strm)))
130                (values `(form (envelope ,(stream->string envelope)) (headers ,headers) (fields ,fields))
131                        rest))))
132
133;;
134;; Given the name of a Unix mbox file, reads the file and returns an
135;; SRFI-40 stream representation of its contents, where each element
136;; in the stream is a form s-expression in the format created by the
137;; read-form procedure.
138;;
139(define (mbox->form-stream fname)
140  (let ((doc (port->stream (open-input-file fname))))
141    (let loop ((strm (document->sections mbox-recognize-start doc)))
142      (stream-delay
143       (if (stream-null? strm) stream-null
144           (let ((sec (stream-car strm)))
145             (if (not (section? sec)) 
146                 (loop (stream-cdr strm))
147                 (let-values (((form rest) (read-form (section-name sec) (stream-cdr strm))))
148                     (stream-cons form (loop rest))))))))))
149
150;;
151;; Given an SRFI-40 stream created by the mbox->form-stream procedure,
152;; returns an ordered dictionary structure, where the key is the email
153;; address of the form sender, and the value is the list of all forms
154;; submitted by that sender. The API of the tree object follows that
155;; of the e.g. treap and rb-tree libraries.
156;;
157(define (form-stream->tree strm)
158  (define (s<= x y) 
159    (cond ((string-ci< x y) -1)
160          ((string-ci= x y) 0)
161          (else 1)))
162  (define (subm< x y) 
163    (let ((x-seconds (alist-ref 'date-seconds (cdr x)))
164          (y-seconds (alist-ref 'date-seconds (cdr y))))
165      (< x-seconds y-seconds)))
166  (let loop ((tree (make-rb-tree s<=)) (strm strm))
167    (let ((lookup (tree 'get))
168          (update (tree 'put)))
169      (if (stream-null? strm) tree
170          (let ((form (stream-car strm)))
171            (match form
172                   (('form ('envelope envelope) ('headers headers) ('fields fields))
173                    (let ((date (rfc822-header-ref headers "date") )
174                          (from (rfc822-field->tokens (rfc822-header-ref headers "from") )))
175                      (let ((date-seconds (rfc822-date->seconds date))
176                            (from-address (match from 
177                                                 ((u #\@ v)  (string-append u "@" v))
178                                                 ((u v)      (string-append u "@" v))
179                                                 (else (error 'form-stream->tree "invalid from address: " from)))))
180                        (let ((exists     (lookup from-address #f))
181                              (submission `(submission (date-seconds ,date-seconds) (fields . ,fields))))
182                          (if exists 
183                              (loop (update from-address 
184                                            (merge (list submission) (cdr exists) subm<))
185                                    (stream-cdr strm))
186                              (loop (update from-address (list submission)) (stream-cdr strm)))))))
187                   (else (error 'form-stream->tree "invalid form: " form))))))))
188
Note: See TracBrowser for help on using the repository browser.