source: project/release/4/formular/trunk/form2txt.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: 9.3 KB
Line 
1;;
2;;
3;; A program to produce plain text output from email form submissions
4;; 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(import scheme chicken data-structures srfi-1 )
25
26(require-extension posix utils srfi-13 srfi-14)
27(require-extension typeclass input-classes rb-tree formular byte-blob byte-blob-stream)
28(require-extension fmt ssax getopt-long )
29
30(require-library abnf internet-message mbox)
31(import (only abnf <CoreABNF>  <Token> <CharLex> 
32              Token.CharLex->CoreABNF Input->Token 
33              Token->CharLex 
34              )
35        (only internet-message <InetMessage> CoreABNF->InetMessage)
36        (only mbox <Mbox> Input+.CoreABNF->Mbox)
37        )
38
39
40(foreign-declare "#include <math.h>")
41(define log10 (foreign-lambda double "log10" double))
42
43
44(define lookup-def 
45  (lambda (k lst . rest)
46    (let-optionals rest ((default #f))
47      (let ((v (alist-ref k lst eq? default)))
48        (and v (if (or (atom? v) (and (pair? v) (pair? (cdr v)))) v 
49                   (car v)))))))
50
51
52(define s+ string-append)
53
54(define parser-error error)
55
56(define (xml:str-handler fragment foll-fragment seed)
57  (if (string-null? foll-fragment) 
58      (cons fragment seed)
59      (cons* foll-fragment fragment seed)))
60
61
62(define (entity-ref->string entity)
63  (case entity
64    ((quot) "\"")
65    ((apos) "'")
66    ((amp)  "&")
67    ((lt)   "<")
68    ((gt)   ">")
69    (else (error 'entity-ref->string "unknown entity " entity))))
70
71
72(define (alist->rb-tree alst)
73  (define (s<= x y) 
74    (cond ((string-ci< x y) -1)
75          ((string-ci= x y) 0)
76          (else 1)))
77  (let* ((tree    (make-ephemeral-map s<=))
78         (update! (tree 'put!)))
79    (for-each (lambda (x) (let ((k (car x))
80                                (v (cdr x)))
81                            (update! k v)))
82              alst)
83    tree))
84                             
85
86
87(define (xml:read-string s)
88  (let loop ((lst (list)) (iport  (open-input-string s)))
89    (if (eof-object? (peek-char iport))
90        (string-concatenate (reverse lst))
91        (let-values (((lst token)  (ssax:read-char-data iport #t xml:str-handler lst)))
92            (let ((v (and (not (eof-object? token )) 
93                          (list (xml-token-kind token) (xml-token-head token)))))
94              (cond ((and (pair? v) (eq? (car v) 'ENTITY-REF))
95                     (let ((entity (cadr v)))
96                       (loop (cons (entity-ref->string entity) lst) iport)))
97                    (else (loop lst iport))))))))
98
99
100(define (pp-submission/text id from-address time-seconds fields . rest)
101  (let-optionals rest ((include-fields #f))
102    (let ((text-fields (filter-map identity
103                        (if include-fields
104                            (map (lambda (x) (assoc x fields)) include-fields)
105                            fields))))
106      (print id)
107      (for-each (lambda (field)
108                  (let* ((section-title (->string (first field)))
109                         (section-content (second field))
110                         (section-content 
111                          (string-trim-both
112                           (xml:read-string
113                            (if (pair? section-content) 
114                                (list->string section-content) 
115                                section-content))
116                            char-set:whitespace)))
117                    (display  (s+ section-title ": " section-content))
118                    (print)))
119                text-fields))))
120
121                     
122(define (make-id i width id-prefix idnum )
123  (s+ id-prefix " " (fmt #f (pad-char #\0 (fit/left width idnum))) "-" (->string i)))
124
125
126(define (pp-formular-tree/text tree . rest)
127  (let-optionals rest ((id-prefix "Form Submission") (id-order #f) (include-fields #f)
128                       (exclude #f) (after-time #f))
129   (let* ((id-list   (list))
130          (keys     (tree 'list-keys))
131          (order    (or id-order 
132                        (and (positive? (length keys)) (inexact->exact (ceiling (log10 (length keys)))))
133                        3)))
134     (if (null? keys) (error 'pp-formular-tree/text "empty list of forms"))
135     ((tree 'foldi)
136      (lambda (from-address lst i)
137        (cond ((and exclude (member (string->symbol from-address) exclude)) i)
138              (else
139               (let loop ((lst lst))
140                 (if (null? lst) i
141                     (let* ((submission (cdr (last lst)))
142                            (time-seconds (lookup-def 'time-seconds submission))
143                            (fields (lookup-def 'fields submission)))
144                       (if (or (not after-time) (> time-seconds after-time))
145                           (let* ((width (if (positive? order) order 1))
146                                  (idnum (inexact->exact (- time-seconds 10e8)))
147                                  (id    (let loop ((v 0) (id (make-id 1 width id-prefix idnum)))
148                                           (let ((hv (member id id-list)))
149                                             (if hv (loop (+ v 1) (make-id (+ 1 v) width id-prefix idnum))
150                                                 (begin
151                                                   (set! id-list (cons id id-list))
152                                                   id))))))
153                             (if (> (length lst) 1)
154                                 (print "Multiple submissions by " from-address ": using submission from "
155                                        (seconds->string time-seconds)))
156                             (pp-submission/text id from-address time-seconds fields include-fields)))
157                       (+ i 1)))))))
158      1))))
159 
160
161(define opt-defaults
162  `(
163    (order         . 3)
164    (mbox-path     . "mbox")
165    (prefix        . "Form Submission")
166    ))
167
168(define (defopt x)
169  (lookup-def x opt-defaults))
170
171(define opt-grammar
172  `(
173    (exclude     "specify a colon-separated list of entries to exclude (default is none)"
174                 (value (required "FROM1:FROM2")
175                        (transformer ,(lambda (x) (list (map string->symbol (string-split x ":")))))))
176
177    (after-date  "omit entries before given date (in seconds)"
178                 (value (required "N")   
179                        (predicate ,string->number)
180                        (transformer ,string->number)))
181
182    (fields      "specify a colon-separated list of fields to process (default is all fields)"
183                 (value (required "FIELD1:FIELD2:...")
184                        (transformer ,(lambda (x) (list (map string->symbol (string-split x ":")))))))
185
186    (mbox-path    ,(string-append "specify path to input mbox (default: " (defopt 'mbox-path) ")")
187                  (value (required "PATH")
188                         (default ,(defopt 'mbox-path))
189                         ))
190
191    (order        ,(string-append "specify order of form id (default: " (->string (defopt 'order)) ")")
192                  (value
193                   (required "N")   
194                   (default ,(defopt 'order))
195                   (transformer ,(lambda (x) (inexact->exact (string->number x))))))
196
197    (prefix       ,(string-append "specify prefix for text page title (default: " (defopt 'prefix) ")")
198                  (value (required "STRING")
199                         (default ,(defopt 'prefix))))
200
201    (write-alist     "write an alist representation to FILE"
202                     (value (required "FILE")))
203
204    (read-alist     "read an alist representation from FILE"
205                    (value (required "FILE")))
206
207    (help         (single-char #\h))
208    ))
209
210   
211;; Use args:usage to generate a formatted list of options (from OPTS),
212;; suitable for embedding into help text.
213(define (form2txt:usage)
214  (print "Usage: form2txt [options...] operands ")
215  (newline)
216  (print "The following options are recognized: ")
217  (newline)
218  (print (parameterize ((indent 5)) (usage opt-grammar)))
219  (exit 1))
220
221
222;; Process arguments and collate options and arguments into OPTIONS
223;; alist, and operands (filenames) into OPERANDS.
224
225(define opts    (getopt-long (command-line-arguments) opt-grammar))
226(define opt     (make-option-dispatch opts opt-grammar))
227
228(define-inline (byte->char b) (integer->char (fxand 255 b)))
229
230(define byte-blob-stream-<Input>
231  (make-<Input> byte-blob-stream-empty? 
232                (compose byte->char byte-blob-stream-car)
233                byte-blob-stream-cdr))
234
235(define byte-blob-stream-<Token>
236  (Input->Token byte-blob-stream-<Input>))
237
238(define byte-blob-stream-<CharLex>
239  (Token->CharLex byte-blob-stream-<Token>))
240
241(define byte-blob-stream-<CoreABNF>
242  (Token.CharLex->CoreABNF byte-blob-stream-<Token> 
243                           byte-blob-stream-<CharLex>))
244
245(define byte-blob-stream-<InetMessage>
246  (CoreABNF->InetMessage byte-blob-stream-<CoreABNF> ))
247
248(define byte-blob-stream-<Input+>
249  (make-<Input+> byte-blob-stream-<Input> 
250                 byte-blob-stream-find
251                 (compose blob->byte-blob string->blob)
252                 file->byte-blob-stream
253                 ))
254
255(define byte-blob-stream-<Mbox>
256  (Input+.CoreABNF->Mbox byte-blob-stream-<Input+>
257                         byte-blob-stream-<CoreABNF>
258                         ))
259
260(define (main options operands)
261
262  (if (opt 'help) (form2txt:usage))
263
264  (with-instance   ((<Mbox> byte-blob-stream-<Mbox>))
265
266   (let* ((mbox-messages->form-tree 
267           (mbox-messages->form-tree byte-blob-stream-<InetMessage>))
268
269          (mbox-messages (mbox-file->messages (opt 'mbox-path)))
270          (tree  (if (opt 'read-alist)
271                     (alist->rb-tree (read (open-input-file (opt 'read-alist))))
272                     (mbox-messages->form-tree 
273                      mbox-messages))))
274
275     (if (opt 'write-alist)
276         (let ((oport (open-output-file (opt 'write-alist))))
277           (display "(" oport) 
278           ((tree 'for-each-ascending) 
279            (lambda (x) 
280              (let ((x1 (cons (car x)
281                              (map (lambda (lst)
282                                     (let* ((submission (cdr lst))
283                                            (time-seconds (lookup-def 'time-seconds submission))
284                                            (fields (lookup-def 'fields submission))
285                                            (pf  (lambda (f) 
286                                                   (list (first f) (list->string (second f))))))
287                                       `(submission (time-seconds ,time-seconds)
288                                                    (fields ,(map pf fields)))))
289                                   (cdr x)))))
290             (pp x1 oport))))
291           (display ")" oport) ))
292         
293     (pp-formular-tree/text tree
294                            (or (opt 'prefix) (defopt 'prefix))
295                            (opt 'order)
296                            (opt 'fields)
297                            (opt 'exclude)
298                            (opt 'after-date)
299                            ))))
300
301
302(main opts (opt '@))
Note: See TracBrowser for help on using the repository browser.