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

Last change on this file since 13348 was 13348, checked in by Ivan Raikov, 12 years ago

Removed some debug statements.

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                                          (print "section-text: x = " x)
102                                          (if (string? x) (xml:read-string x) (->string x)) )
103                                        (second field))))
104                    (let ((section-title (->string (first field)))
105                          (section-content
106                           ((lambda (x) (string-split  x "\n" #t))
107                            ((lambda (x) (if section-limit (string-take-alphanumeric x section-limit) x))
108                             section-text)))
109                          (section-overlimit
110                           ((lambda (x) (and (string? x) (string-split  x "\n" #t)))
111                            ((lambda (x) (and section-limit (string-drop-alphanumeric x section-limit)))
112                             section-text))))
113                      (print  (s+ "=== " section-title " ==="))
114                      (for-each (lambda (x) 
115                                  (for-each (lambda (x) 
116                                              (let ((x1 (string-trim-both x char-whitespace?)))
117                                                (if (not (string-null? x1)) 
118                                                    (print x1 " <br>"))))
119                                            (string-split x "\n")))
120                                section-content )
121                      (if section-overlimit
122                          (begin
123                            (print  (s+ "==== " section-title " (over character limit)  ===="))
124                            (for-each (lambda (x) 
125                                        (for-each (lambda (x) 
126                                                    (let ((x1 (string-trim-both x char-whitespace?)))
127                                                      (if (not (string-null? x1)) 
128                                                          (print x1 " <br>"))))
129                                                  (string-split x "\n")))
130                                      section-overlimit )))
131                      (print))))
132                wiki-fields))))
133                     
134(define (make-id i width id-prefix idnum )
135  (s+ id-prefix " " (fmt #f (pad-char #\0 (fit/left width (num idnum)))) "-" (->string i)))
136
137(define (pp-formular-tree/wiki tree . rest)
138  (let-optionals rest ((id-prefix "Form Submission") (id-order #f) (include-fields #f)
139                       (exclude #f) (include #f) (field-limits #f) (skip #f))
140   (let* ((keys  (tree 'list-keys))
141          (order (or id-order (inexact->exact (ceiling (log10 (length keys)))))))
142     ((tree 'foldi)
143      (lambda (from-address lst i)
144        (cond ((and exclude (member (s$ from-address) exclude)) i)
145              ((or (not include) (member (s$ from-address) include))
146               (if (and skip (< i skip)) (+ i 1)
147                   (let loop ((lst lst))
148                     (if (null? lst) i
149                         (match (car lst)
150                                (('submission ('date-seconds date-seconds) ('fields fld1 . fields))
151                                 (let* ((width (if (positive? order) order 1))
152                                        (idnum (inexact->exact (- date-seconds 10e8)))
153                                        (id    (let loop ((i 1) (id (make-id 1 width id-prefix idnum)))
154                                                 (if (file-exists? id) 
155                                                     (loop (+ 1 i) (make-id (+ 1 i) width id-prefix idnum)) id))))
156                                   (if (> (length lst) 1)
157                                       (print "Multiple submissions by " from-address ": using submission from "
158                                              (seconds->string date-seconds)))
159                                   (with-output-to-port (open-output-file id)
160                                     (lambda ()
161                                       (pp-submission/wiki id from-address date-seconds (cons fld1 fields) 
162                                                           include-fields field-limits)))
163                                   (+ i 1)))
164                                (else (loop (cdr lst))))))))
165              (else i)))
166      1))))
167 
168
169(define opt_exclude       #f)
170(define opt_include       #f)
171(define opt_order         3)
172(define opt_mbox-path     "mbox")
173(define opt_title-prefix  "Form Submission")
174(define opt_fields        #f)
175(define opt_field-limits  (list))
176(define opt_alist_input   #f)
177(define opt_skip         #f)
178
179(define opts
180  `(
181    ,(args:make-option (exclude)     (required: "FROM1:FROM2:...")   
182                       (string-append "specify a colon-separated list of entries to exclude (default is none )")
183                       (set! opt_exclude (map s$ (string-split (->string arg) ":"))))
184    ,(args:make-option (include)     (required: "FROM1:FROM2:...")   
185                       (string-append "specify a colon-separated list of entries to include (default is all )")
186                       (set! opt_include (map s$ (string-split (->string arg) ":"))))
187    ,(args:make-option (skip)     (required: "N")   
188                       (string-append "skip first N entries (ordered by submission time)")
189                       (set! opt_skip (inexact->exact (string->number arg))))
190    ,(args:make-option (flimits)     (required: "FIELD1:LIMIT1,...")   
191                       (string-append "specify a comma-separated list of fields and character limits (default is none )")
192                       (set! opt_field-limits
193                             (append
194                              (let loop ((lst (string-split (->string arg) ",")) (field-limits (list)))
195                                (if (null? lst) field-limits
196                                    (match (string-split (car lst) ":")
197                                           ((field limit) 
198                                            (let ((field-sym (s$ field))
199                                                  (limit-num (string->number limit)))
200                                              (if (and (symbol? field-sym) (number? limit-num))
201                                                  (loop (cdr lst) (cons (list field-sym limit-num) field-limits))
202                                                  (error "invalid field:limit pair: " (list field limit)))))
203                                           (else (error "invalid field:limit list " lst)))))
204                              opt_field-limits)))
205
206    ,(args:make-option (fields)     (required: "FIELD1:FIELD2:...")   
207                       (string-append "specify a colon-separated list of fields to process (default is all fields )")
208                       (set! opt_fields (append (map s$ (string-split (->string arg) ":")) 
209                                                (or opt_fields (list)))))
210    ,(args:make-option (mbox-path)     (required: "PATH")   
211                       (string-append "specify path to input mbox (default: " opt_mbox-path ")")
212                       (set! opt_mbox-path (->string arg)))
213    ,(args:make-option (order)     (required: "N")   
214                       (string-append "specify order of form id (default: " (->string opt_order) ")")
215                       (set! opt_order (inexact->exact (string->number arg))))
216    ,(args:make-option (prefix)     (required: "STRING")   
217                       (string-append "specify prefix for wiki page title (default: " opt_title-prefix ")")
218                       (set! opt_title-prefix (->string arg)))
219    ,(args:make-option (read-alist)     (required: "FILE")   
220                       "read an alist representation from FILE"
221                       (set! opt_alist_input  (->string arg)))
222    ,(args:make-option (h help)  #:none               "Print help"
223                       (usage))))
224   
225;; Use args:usage to generate a formatted list of options (from OPTS),
226;; suitable for embedding into help text.
227(define (usage)
228  (print "Usage: form2wiki [options...] operands ")
229  (newline)
230  (print "The following options are recognized: ")
231  (newline)
232  (print (parameterize ((args:indent 2) (args:width 32)) (args:usage opts)))
233  (exit 1))
234
235
236(define args (command-line-arguments))
237
238(set!-values (options operands)  (args:parse args opts))
239
240(define (alist->rb-tree alst)
241  (define (s<= x y) 
242    (cond ((string-ci< x y) -1)
243          ((string-ci= x y) 0)
244          (else 1)))
245  (let* ((tree    (make-rb-tree s<=))
246         (update! (tree 'put!)))
247    (for-each (lambda (x) (let ((k (car x))
248                                (v (cdr x)))
249                            (update! k v)))
250              alst)
251    tree))
252                             
253
254(define (main options operands)
255  (let ((tree  (if opt_alist_input 
256                   (alist->rb-tree (read (open-input-file opt_alist_input)))
257                   (form-stream->tree (mbox->form-stream opt_mbox-path)))))
258
259    (pp-formular-tree/wiki tree
260                           opt_title-prefix
261                           opt_order
262                           opt_fields
263                           opt_exclude
264                           opt_include
265                           opt_field-limits
266                           opt_skip
267                           )))
268
269(main options operands)
Note: See TracBrowser for help on using the repository browser.