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

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

Bug fixes.

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