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