source: project/release/3/formular/trunk/form2wiki.scm @ 13395

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

Changed skip option to after-date.

File size: 9.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-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 args)
29(require-extension posix)
30(require-extension utils)
31(require-extension stream-ext)
32(require-extension ssax-core)
33(require-extension fmt)
34
35(require-extension formular)
36
37(foreign-declare "#include <math.h>")
38(define log10 (foreign-lambda double "log10" double))
39
40(define s+ string-append)
41(define s$ string->symbol)
42
43(define parser-error error)
44
45(define (xml:str-handler fragment foll-fragment seed)
46  (if (string-null? foll-fragment) (cons fragment seed)
47      (cons* foll-fragment fragment seed)))
48
49(define (entity-ref->string entity)
50  (case entity
51    ((quot) "\"")
52    ((apos) "'")
53    ((amp)  "&")
54    ((lt)   "<")
55    ((gt)   ">")
56    (else (error 'entity-ref->string "unknown entity " entity))))
57   
58(define (lookup-def k lst . rest)
59  (let-optionals rest ((default #f))
60      (let ((kv (assoc k lst)))
61        (if (not kv) default
62            (match kv ((k v) v) (else (cdr kv)))))))
63
64(define (xml:read-string s)
65  (let loop ((lst (list)) (iport (open-input-string s)))
66    (if (eof-object? (peek-char iport))
67        (string-concatenate (reverse lst))
68        (let-values (((lst token)  (SSAX:read-char-data iport #t xml:str-handler lst)))
69            (match (and (not (eof-object? token )) 
70                        (list (xml-token-kind token) (xml-token-head token)))
71                   (('ENTITY-REF entity) 
72                    (loop (cons (entity-ref->string entity) lst) iport))
73                   (else (loop lst iport)))))))
74
75(define (string-take-alphanumeric str n)
76  (let loop ((i n) (lst (string->list str)) (res (list)))
77    (if (or (null? lst) (zero? i)) (list->string (reverse res))
78        (if (positive? i)
79            (loop (if (or (char-alphabetic? (car lst)) (char-numeric? (car lst))) (- i 1) i)
80                  (cdr lst) (cons (car lst) res))))))
81
82(define (string-drop-alphanumeric str n)
83  (let loop ((i n) (lst (string->list str)))
84    (cond ((null? lst)  #f)
85          ((zero? i)    (list->string lst))
86          ((positive? i)
87           (loop (if (or (char-alphabetic? (car lst)) (char-numeric? (car lst))) (- i 1) i) 
88                 (cdr lst))))))
89
90
91(define (pp-submission/wiki id from-address date-seconds fields . rest)
92  (let-optionals rest ((include-fields #f) (field-limits #f) )
93    (let ((wiki-fields (filter-map identity
94                         (if include-fields
95                           (map (lambda (x) (assoc x fields)) include-fields)
96                           fields))))
97      (print (s+ "== " id " ==\n"))
98      (for-each (lambda (field)
99                  (let ((section-limit (lookup-def (first field) field-limits))
100                        (section-text  ((lambda (x) 
101                                          (if (string? x) (xml:read-string x) (->string x)) )
102                                        (second field))))
103                    (let ((section-title (->string (first field)))
104                          (section-content
105                           ((lambda (x) (string-split  x "\n" #t))
106                            ((lambda (x) (if section-limit (string-take-alphanumeric x section-limit) x))
107                             section-text)))
108                          (section-overlimit
109                           ((lambda (x) (and (string? x) (string-split  x "\n" #t)))
110                            ((lambda (x) (and section-limit (string-drop-alphanumeric x section-limit)))
111                             section-text))))
112                      (print  (s+ "=== " section-title " ==="))
113                      (for-each (lambda (x) 
114                                  (for-each (lambda (x) 
115                                              (let ((x1 (string-trim-both x char-whitespace?)))
116                                                (if (not (string-null? x1)) 
117                                                    (print x1 " <br>"))))
118                                            (string-split x "\n")))
119                                section-content )
120                      (if section-overlimit
121                          (begin
122                            (print  (s+ "==== " section-title " (over character limit)  ===="))
123                            (for-each (lambda (x) 
124                                        (for-each (lambda (x) 
125                                                    (let ((x1 (string-trim-both x char-whitespace?)))
126                                                      (if (not (string-null? x1)) 
127                                                          (print x1 " <br>"))))
128                                                  (string-split x "\n")))
129                                      section-overlimit )))
130                      (print))))
131                wiki-fields))))
132                     
133(define (make-id i width id-prefix idnum )
134  (s+ id-prefix " " (fmt #f (pad-char #\0 (fit/left width (num idnum)))) "-" (->string i)))
135
136(define (pp-formular-tree/wiki tree . rest)
137  (let-optionals rest ((id-prefix "Form Submission") (id-order #f) (include-fields #f)
138                       (exclude #f) (include #f) (field-limits #f) (after-date #f))
139   (let* ((keys  (tree 'list-keys))
140          (order (or id-order (inexact->exact (ceiling (log10 (length keys)))))))
141     ((tree 'foldi)
142      (lambda (from-address lst i)
143        (cond ((and exclude (member (s$ from-address) exclude)) i)
144              ((or (not include) (member (s$ from-address) include))
145               (let loop ((lst lst))
146                 (if (null? lst) i
147                     (match (car lst)
148                            (('submission ('date-seconds date-seconds) ('fields fld1 . fields))
149                             (if (or (not after-date) (> date-seconds after-date ))
150                                 (let* ((width (if (positive? order) order 1))
151                                        (idnum (inexact->exact (- date-seconds 10e8)))
152                                        (id    (let loop ((i 1) (id (make-id 1 width id-prefix idnum)))
153                                                 (if (file-exists? id) 
154                                                     (loop (+ 1 i) (make-id (+ 1 i) width id-prefix idnum)) id))))
155                                   (if (> (length lst) 1)
156                                       (print "Multiple submissions by " from-address ": using submission from "
157                                              (seconds->string date-seconds)))
158                                   (with-output-to-port (open-output-file id)
159                                     (lambda ()
160                                       (pp-submission/wiki id from-address date-seconds (cons fld1 fields) 
161                                                           include-fields field-limits)))))
162                             (+ i 1))
163                            (else (loop (cdr lst)))))))
164              (else i)))
165      1))))
166 
167
168(define opt_exclude       #f)
169(define opt_include       #f)
170(define opt_order         3)
171(define opt_mbox-path     "mbox")
172(define opt_title-prefix  "Form Submission")
173(define opt_fields        #f)
174(define opt_field-limits  (list))
175(define opt_alist_input   #f)
176(define opt_after_date    #f)
177
178(define opts
179  `(
180    ,(args:make-option (exclude)     (required: "FROM1:FROM2:...")   
181                       (string-append "specify a colon-separated list of entries to exclude (default is none )")
182                       (set! opt_exclude (map s$ (string-split (->string arg) ":"))))
183    ,(args:make-option (include)     (required: "FROM1:FROM2:...")   
184                       (string-append "specify a colon-separated list of entries to include (default is all )")
185                       (set! opt_include (map s$ (string-split (->string arg) ":"))))
186    ,(args:make-option (after-date)     (required: "N")   
187                       (string-append "omit entries before given date (in seconds)")
188                       (set! opt_after_date (string->number arg)))
189    ,(args:make-option (flimits)     (required: "FIELD1:LIMIT1,...")   
190                       (string-append "specify a comma-separated list of fields and character limits (default is none )")
191                       (set! opt_field-limits
192                             (append
193                              (let loop ((lst (string-split (->string arg) ",")) (field-limits (list)))
194                                (if (null? lst) field-limits
195                                    (match (string-split (car lst) ":")
196                                           ((field limit) 
197                                            (let ((field-sym (s$ field))
198                                                  (limit-num (string->number limit)))
199                                              (if (and (symbol? field-sym) (number? limit-num))
200                                                  (loop (cdr lst) (cons (list field-sym limit-num) field-limits))
201                                                  (error "invalid field:limit pair: " (list field limit)))))
202                                           (else (error "invalid field:limit list " lst)))))
203                              opt_field-limits)))
204
205    ,(args:make-option (fields)     (required: "FIELD1:FIELD2:...")   
206                       (string-append "specify a colon-separated list of fields to process (default is all fields )")
207                       (set! opt_fields (append (map s$ (string-split (->string arg) ":")) 
208                                                (or opt_fields (list)))))
209    ,(args:make-option (mbox-path)     (required: "PATH")   
210                       (string-append "specify path to input mbox (default: " opt_mbox-path ")")
211                       (set! opt_mbox-path (->string arg)))
212    ,(args:make-option (order)     (required: "N")   
213                       (string-append "specify order of form id (default: " (->string opt_order) ")")
214                       (set! opt_order (inexact->exact (string->number arg))))
215    ,(args:make-option (prefix)     (required: "STRING")   
216                       (string-append "specify prefix for wiki page title (default: " opt_title-prefix ")")
217                       (set! opt_title-prefix (->string arg)))
218    ,(args:make-option (read-alist)     (required: "FILE")   
219                       "read an alist representation from FILE"
220                       (set! opt_alist_input  (->string arg)))
221    ,(args:make-option (h help)  #:none               "Print help"
222                       (usage))))
223   
224;; Use args:usage to generate a formatted list of options (from OPTS),
225;; suitable for embedding into help text.
226(define (usage)
227  (print "Usage: form2wiki [options...] operands ")
228  (newline)
229  (print "The following options are recognized: ")
230  (newline)
231  (print (parameterize ((args:indent 2) (args:width 32)) (args:usage opts)))
232  (exit 1))
233
234
235(define args (command-line-arguments))
236
237(set!-values (options operands)  (args:parse args opts))
238
239(define (alist->rb-tree alst)
240  (define (s<= x y) 
241    (cond ((string-ci< x y) -1)
242          ((string-ci= x y) 0)
243          (else 1)))
244  (let* ((tree    (make-rb-tree s<=))
245         (update! (tree 'put!)))
246    (for-each (lambda (x) (let ((k (car x))
247                                (v (cdr x)))
248                            (update! k v)))
249              alst)
250    tree))
251                             
252
253(define (main options operands)
254  (let ((tree  (if opt_alist_input 
255                   (alist->rb-tree (read (open-input-file opt_alist_input)))
256                   (form-stream->tree (mbox->form-stream opt_mbox-path)))))
257
258    (pp-formular-tree/wiki tree
259                           opt_title-prefix
260                           opt_order
261                           opt_fields
262                           opt_exclude
263                           opt_include
264                           opt_field-limits
265                           opt_after_date
266                           )))
267
268(main options operands)
Note: See TracBrowser for help on using the repository browser.