source: project/release/4/formular/trunk/formular.scm @ 20656

Last change on this file since 20656 was 20656, checked in by Ivan Raikov, 10 years ago

formular: update to reflect new rb-tree API

File size: 5.6 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-2010 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
24(module formular
25
26        (form-delim-start form-delim-end field-delim
27         form-field form mbox-messages->form-tree)
28                   
29
30        (import scheme chicken data-structures srfi-1 srfi-14)
31        (import (only srfi-13 string-ci< string-ci= string-trim-both))
32
33        (require-extension typeclass input-classes rb-tree mbox)
34        (require-library abnf abnf-consumers internet-message)
35
36        (import (prefix abnf abnf:) 
37                (prefix abnf-consumers abnf:) 
38                (only abnf <CoreABNF> <Token> <CharLex> 
39                      Token.CharLex->CoreABNF Input->Token 
40                      Token->CharLex 
41                      )
42                (only internet-message <InetMessage>)
43                )
44
45
46(define consumed-objects-lift-any
47  (abnf:consumed-objects-lift
48   (abnf:consumed-objects identity)))
49
50
51(define (char-list-titlecase x)
52  (if (null? x) x (cons (char-upcase (car x)) (map char-downcase (cdr x)))))
53
54;; construct symbols from consumed chars
55(define consumed-chars->tsymbol
56  (abnf:consumed-chars->list 
57   (compose string->symbol 
58            list->string 
59            char-list-titlecase 
60            abnf:trim-ws-char-list)))
61
62;; shortcut for (abnf:bind consumed-chars->tsymbol (abnf:longest ... ))
63(define-syntax bind-consumed->tsymbol
64  (syntax-rules () 
65    ((_ p)    (abnf:bind consumed-chars->tsymbol (abnf:longest p)))
66    ))
67
68(define field-delim           (make-parameter #\:))
69(define form-delim-start     
70  (make-parameter "---------------------------------------------------------------------------"))
71(define form-delim-end     
72  (make-parameter "---------------------------------------------------------------------------"))
73
74(define=> (lwsp <InetMessage>) (set-from-string " \r\n\t"))
75
76
77(define=> (formpar <InetMessage>)
78  (lambda (p)
79    (let ((v (p)))
80      (cond ((char? v)    (char v))
81            ((string? v)  (lit v))
82            (else (error 'formpar "parameter must be one of char or string" v))))))
83   
84(define=> (field-name <InetMessage>)
85  (bind-consumed->tsymbol (abnf:repetition1 ftext)))
86
87
88(define=> (field-value <InetMessage>)
89  (abnf:alternatives
90   quoted-string
91   unstructured))
92
93
94(define (form-field lwsp formpar field-name field-value)
95  (abnf:bind (consumed-objects-lift-any)
96    (abnf:concatenation
97     field-name
98     (abnf:drop-consumed
99      (abnf:concatenation (formpar field-delim)
100                          (abnf:repetition lwsp)))
101     field-value
102     (abnf:drop-consumed (abnf:repetition lwsp)))))
103 
104
105
106(define (form lwsp formpar form-field)
107  (abnf:bind-consumed-pairs->list 
108   (abnf:concatenation
109    (abnf:drop-consumed
110     (abnf:concatenation 
111      (abnf:repetition lwsp)
112      (formpar form-delim-start)
113      (abnf:repetition lwsp)))
114    (abnf:repetition form-field))))
115
116
117;;
118;; Given a list of messages returned by the file->messages procedure
119;; from the mbox library, returns an ordered dictionary structure,
120;; where the key is the email address of the form sender, and the
121;; value is the list of all forms submitted by that sender. The API of
122;; the tree object follows that of the e.g. treap and rb-tree
123;; libraries.
124;;
125
126(define (lookup-def x lst)
127  (let ((v (alist-ref x lst)))
128    (and v (if (pair? (cdr v)) v (car v)))))
129
130(define (mbox-messages->form-tree M)
131
132  (define (s<= x y) 
133    (cond ((string-ci< x y) -1)
134          ((string-ci= x y) 0)
135          (else 1)))
136
137  (define (subm< x y) 
138    (let ((x-seconds (lookup-def 'time-seconds (cdr x)))
139          (y-seconds (lookup-def 'time-seconds (cdr y))))
140      (< x-seconds y-seconds)))
141
142  (let* ((lwsp         (lwsp M))
143         (formpar      (formpar M))
144         (field-name   (field-name M))
145         (field-value  (field-value M))
146         (form-field   (form-field lwsp formpar field-name field-value))
147         (form         (form lwsp formpar form-field)))
148
149    (lambda (messages)
150      (let loop ((tree (make-persistent-map s<=)) (msgs messages))
151        (let ((lookup (tree 'get))
152              (update (tree 'put)))
153          (if (null? msgs) tree
154              (let ((message (car msgs)))
155                (let ((envelope (message-envelope message))
156                      (headers  (message-headers message))
157                      (body     (message-body message)))
158                  (let ((time-seconds (lookup-def 'time-seconds envelope))
159                        (from-address (let* ((addresskv (assoc 'address envelope))
160                                             (address   (and addresskv (cdr addresskv)))
161                                             (local-part (lookup-def 'local-part address))
162                                             (domain     (lookup-def 'domain address)))
163                                        (cond ((and local-part domain)
164                                               (string-append
165                                                (string-trim-both local-part char-set:whitespace) 
166                                                "@"
167                                                (string-trim-both domain char-set:whitespace)))
168                                              (local-part
169                                               (string-trim-both local-part char-set:whitespace))
170                                              (else (error 'mbox-messages->form-tree "invalid address" 
171                                                           address))))))
172                    (let ((exists    (lookup from-address #f))
173                          (submission `(submission (time-seconds ,time-seconds) 
174                                                   (fields . ,(body mbox-message-body: form)))))
175                      (if exists 
176                          (loop (update from-address 
177                                        (merge (list submission) (cdr exists) subm<))
178                                (cdr msgs))
179                          (loop (update from-address (list submission)) (cdr msgs)))))))
180            ))))))
181
182
183)
Note: See TracBrowser for help on using the repository browser.