source: project/release/3/svnwiki-extensions/trunk/svnwiki-extensions-support-base.scm @ 14907

Last change on this file since 14907 was 14907, checked in by azul, 11 years ago

Adding svnwiki-xml-escape.

File size: 12.4 KB
Line 
1;; $Id$
2
3(declare (export svnwiki-extension-define svnwiki-extensions-for-each
4                 svnwiki-extensions-get svnwiki-extensions-init
5                 svnwiki-extensions-print
6                 *svnwiki-environment-symbol-undefined*
7                 svnwiki-basename
8                 svnwiki-stream-cut-with-ellipsis
9                 svnwiki-dirname
10                 svnwiki-path-escape 
11                 svnwiki-make-pathname
12                 svnwiki-html-body-top-warning
13                 svnwiki-ignore-errors
14                 svnwiki-is-raw?
15                 *discuss-dir*
16                 svnwiki-is-discuss?
17                 is-discuss?
18                 mime->ending
19                 get-mime
20                 write-file-with-tmp
21                 svnwiki-make-tmp-path
22                 svnwiki-list-with-parents
23                 svnwiki-list-parents
24                 svnwiki-create-add-parents
25                 svnwiki-path-canonical
26                 svnwiki-xml-escape))
27
28(use posix format-modular embedded-test srfi-1 srfi-40 stream-ext)
29
30(define *svnwiki-extensions* (make-hash-table))
31
32(define *svnwiki-environment-symbol-undefined* (gensym 'svnwiki-environment-symbol-undefined))
33
34(define (svnwiki-extension-define type name func)
35  (hash-table-set! *svnwiki-extensions*
36                   type
37                   (cons (list name func)
38                         (svnwiki-extension-get type))))
39
40(define (svnwiki-extension-get type)
41  (hash-table-ref/default *svnwiki-extensions* type '()))
42
43; Call (proc name func) for every extension of type type, where name is the
44; name of the extension and func the function.
45
46(define (svnwiki-extensions-for-each type proc)
47  (for-each
48    (lambda (data) (apply proc data))
49    (svnwiki-extension-get type)))
50
51(define (svnwiki-extensions-get type name . rest)
52  (let-optionals rest ((default #f))
53    (call-with-current-continuation
54      (lambda (exit)
55        (svnwiki-extensions-for-each type
56          (lambda (name-current current)
57            (when (eq? name name-current)
58              (exit current))))
59        default))))
60
61(define (svnwiki-extensions-init)
62  (for-each (lambda (name)
63              (require (string-append "svnwiki-" name)))
64            (directory (make-pathname (repository-path) "svnwiki-extensions-registry"))))
65
66(define (svnwiki-extensions-print)
67  (hash-table-walk
68    *svnwiki-extensions*
69    (cut format #t "~A:~:{ ~A~}~%" <...>)))
70
71(test-group svnwiki-basename
72  (test (svnwiki-basename "foo/bar/hey") "hey")
73  (test (svnwiki-basename "") "")
74  (test (svnwiki-basename "xx") "xx"))
75
76(define (svnwiki-basename path)
77  (last (string-split path "/" #t)))
78
79(test-group svnwiki-dirname
80  (test (svnwiki-dirname "foo/bar/hey") "foo/bar")
81  (test (svnwiki-dirname "/foo/bar/hey") "/foo/bar")
82  (test (svnwiki-dirname "") "")
83  (test (svnwiki-dirname "xx") ""))
84
85(define (svnwiki-dirname path)
86  ((if (and (> (string-length path) 0)
87            (char=? (string-ref path 0) #\/))
88     (cut format #f "/~A" <>)
89     identity)
90   (svnwiki-make-pathname (butlast (string-split path "/" #t)))))
91
92(test-group svnwiki-make-pathname
93
94  (test (svnwiki-make-pathname "foo" "bar" "scm")
95        "foo/bar.scm")
96
97  (test (svnwiki-make-pathname (list "" "." "" "foo" "" "" "bar" "" "") "hey")
98        "foo/bar/hey")
99
100  (test (svnwiki-make-pathname "foo" "bar" "")
101        "foo/bar")
102
103  (test (svnwiki-make-pathname "foo" "bar" #f)
104        "foo/bar"))
105
106(define (svnwiki-make-pathname dir . rest)
107  (assert (and 'svnwiki-make-pathname (<= (length rest) 2)))
108  (let-optionals rest ((file #f) (ext #f))
109    (cond
110      ((string? dir) (svnwiki-make-pathname (list dir) file ext))
111      ((not dir) (svnwiki-make-pathname '() file ext))
112      ((and (or (not file)
113                (string=? file "")
114                (string=? file "/"))
115            (not ext))
116       (string-intersperse
117         (remove (disjoin (cut string=? "" <>)
118                          (cut string=? "." <>))
119                 dir)
120         "/"))
121      (else
122        (assert (and 'svnwiki-make-pathname (list? dir)))
123        (assert (and 'svnwiki-make-pathname (every string? dir)))
124        (make-pathname (remove (disjoin (cut string=? <> "")
125                                        (cut string=? "." <>))
126                               dir)
127                       file
128                       ext)))))
129
130(define (svnwiki-path-escape path)
131  (list->string
132    (fold-right
133      (lambda (c rest)
134        (if (or (char-alphabetic? c) (char-numeric? c) (member c '(#\/ #\-)))
135          (cons c rest)
136          (cons* #\\ c rest)))
137      '()
138      (if (string? path)
139        (string->list path)
140        (stream->list path)))))
141
142(test-group svnwiki-path-escape
143  (test (svnwiki-path-escape "foo/bar2")
144        "foo/bar2")
145  (test (svnwiki-path-escape "foo;ls *")
146        "foo\\;ls\\ \\*"))
147
148(define (svnwiki-stream-cut-with-ellipsis str . rest)
149  (let-optionals rest ((len 10))
150    (cond
151      ((string? str)
152       (svnwiki-stream-cut-with-ellipsis (string->stream str) len))
153      ((stream-length>= str (+ len 1))
154       (stream-append
155         (stream-take str (- len 3))
156         (string->stream "...")))
157      (else
158       str))))
159
160(define (svnwiki-stream-cut-with-ellipsis-test str)
161  (stream->string (svnwiki-stream-cut-with-ellipsis str)))
162
163(test-group svnwiki-stream-cut-with-ellipsis
164  (test (svnwiki-stream-cut-with-ellipsis-test "") "")
165  (test (svnwiki-stream-cut-with-ellipsis-test "foobar") "foobar")
166  (test (svnwiki-stream-cut-with-ellipsis-test "012345678") "012345678")
167  (test (svnwiki-stream-cut-with-ellipsis-test "0123456789") "0123456789")
168  (test (svnwiki-stream-cut-with-ellipsis-test "01234567890") "0123456..."))
169
170(define (svnwiki-html-body-top-warning env text)
171  (let-from-environment env (return)
172    (return (html-stream ((div class "warning") text)))))
173
174(define (svnwiki-ignore-errors path-in path)
175  (stream-map
176    stream->symbol
177    (stream-split
178      (string->stream
179        (get-props-parents-first "svnwiki:ignore-errors" path-in path ""))
180      char-whitespace?)))
181
182(define (svnwiki-is-raw? path-in path)
183  (let ((value (get-props-parents-first "svnwiki:raw" path-in path #f)))
184    (if value
185      ; Any value other than "no" (eg. "" or "foo" or "yes") defaults to
186      ; enabling this.
187      (not (string=? value "no"))
188      ; If no value is defined, it is raw if it has a mime-type other than
189      ; one we reserve for wiki pages.
190      (and-let* ((type (get-props-parents-first "svn:mime-type" path-in path #f)))
191        (not (string=? type "application/x-wiki"))))))
192
193(define *discuss-dir* "xsvnwiki-discuss")
194
195(test-group svnwiki-is-discuss?
196  (test (not (svnwiki-is-discuss? "xsvnwiki-dir/foo/2342342")))
197  (test (svnwiki-is-discuss? "xsvnwiki-discuss/foo/2342342"))
198  (test (svnwiki-is-discuss? "foo/bar/xsvnwiki-discuss/foo/33232345"))
199  (test (svnwiki-is-discuss? "bar/xsvnwiki-discuss/foo/33232345"))
200  (test (svnwiki-is-discuss? "xsvnwiki-discuss/foo"))
201  (test (not (svnwiki-is-discuss? "foo")))
202  (test (not (svnwiki-is-discuss? "")))
203  (test (not (svnwiki-is-discuss? "foo/bar/hey/xsvnwiki-bleh/xx/meh"))))
204
205(define (svnwiki-is-discuss? file)
206  (if (stream? file)
207    (svnwiki-is-discuss? (stream->string file))
208    (any (cut string=? *discuss-dir* <>)
209         (string-split file "/"))))
210
211; Deprecated:
212
213(define is-discuss? svnwiki-is-discuss?)
214
215;;; Get extension
216
217(define *mime-extensions*
218  '(("text/html" "html")
219    ("image/png" "png")
220    ("image/jpeg" "jpeg")
221    ("image/x-icon" "ico") ; Don't use this, use image/vnd.microsoft.icon
222    ("image/vnd.microsoft.icon" "ico")
223    ("text/css" "css")
224    ("text/javascript" "js")
225    ("application/xml" "xml")
226    ("application/xhtml+xml" "xhtml")
227    ("application/atom+xml" "xml")
228    ("application/x-scheme" "scm")
229    ("application/x-shockwave-flash" "swf")))
230
231(test-group mime->ending
232  (test (mime->ending "text/css") "css")
233  (test (mime->ending #f) "")
234  (test (mime->ending "") ""))
235
236(define (mime->ending ext)
237  (let ((info (assoc ext *mime-extensions*)))
238    (if info (cadr info) "")))
239
240(define (get-mime path-in path)
241  (svnwiki-repository-property-get "svn:mime-type" (svnwiki-make-pathname path-in path) "text/plain"))
242
243; Write the stream of characters content to a temporary file.  Once the writing
244; is done, move the file to the path specified by the other three arguments:
245; web is the path to the base of the web tree (eg.
246; "/var/www/wiki.freaks-unidos.net/"), path is the path of the file in the wiki
247; (eg. "foo/xsvnwiki-discuss/bar") and mime is a mime type supported by
248; mime->ending.
249
250(define (write-file-with-tmp path mime web content)
251  (let* ((file (svnwiki-make-pathname #f path (mime->ending mime)))
252         (tmp (svnwiki-make-tmp-path web file)))
253    (create-parents web path)
254    (with-output-to-file tmp
255      (lambda ()
256        (write-stream (if (string? content) (string->stream content) content))))
257    (rename-file tmp (svnwiki-make-pathname web file))
258
259    ; This is an ugly hack to work around the fact that many browsers (ie. IE
260    ; 6.0) don't support a MIME type of "application/xhtml+xml".  We do need to
261    ; write some files as XHTML in order to be able to extract information from
262    ; them with AJAX.
263
264    (when (equal? mime "application/xhtml+xml")
265      (let ((link-name (svnwiki-make-pathname web path (mime->ending "text/html"))))
266        (unless (file-exists? link-name)
267          (create-symbolic-link (last (string-split file "/")) link-name))))))
268
269(define (svnwiki-make-tmp-path out-dir path)
270  (let ((comps (string-split path "/")))
271    (svnwiki-make-pathname (filter identity (cons out-dir (butlast comps)))
272                           (format #f "xsvnwiki-tmp-~A" (last comps)))))
273
274(test-group svnwiki-list-with-parents
275  (test (svnwiki-list-with-parents "") '(""))
276  (test (svnwiki-list-with-parents "foo/bar/hey/there") '("" "foo" "foo/bar" "foo/bar/hey" "foo/bar/hey/there")))
277
278(define (svnwiki-list-with-parents path)
279  (reverse
280    (fold
281      (lambda (c rest)
282        (cons (svnwiki-make-pathname (car rest) c)
283              rest))
284      '("")
285      (string-split (svnwiki-path-canonical path) "/"))))
286
287(test-group svnwiki-list-parents
288  (test (svnwiki-list-parents "") '())
289  (test (svnwiki-list-parents "/foo////bar/hey/there") '("" "foo" "foo/bar" "foo/bar/hey"))
290  (test (svnwiki-list-parents "foo/bar/hey/there") '("" "foo" "foo/bar" "foo/bar/hey")))
291
292(define svnwiki-list-parents
293  (compose butlast svnwiki-list-with-parents))
294
295; Given a path to an existing directory and a relative path to an (usually
296; unexisting) file inside it (eg. "/home/azul/data" and
297; "svnwiki/new-dir/mail-spec" for "/home/azul/data/svnwiki/new-dir/mail-spec"),
298; create all the parent directories to the full path (eg.
299; ("/home/azul/data/svnwiki/new-dir")).  Return a list with all directories
300; that had to be created in the order in which they were created (eg.
301; ("/home/azul/data/svnwiki")).
302
303(define (create-parents path-in path)
304  (let ((dirs (remove (lambda (x)
305                        (or (string=? "" x) (file-exists? x)))
306                      (map (cut svnwiki-make-pathname path-in <>)
307                           (svnwiki-list-parents path)))))
308    (for-each create-directory dirs)
309    dirs))
310
311(define (svnwiki-create-add-parents path-in path)
312  (map (lambda (p)
313         (svn-add p)
314         p)
315       (create-parents path-in path)))
316
317; Transform path.  At the end it will be a relative path without "." or ".."
318; components.  It won't start with a slash and all unnecessary slashes (at
319; beginning, end or consecutive) will be removed.
320
321(test-group svnwiki-path-canonical
322  (test (svnwiki-path-canonical "../../../foo/bar/hey") "foo/bar/hey")
323  (test (svnwiki-path-canonical "a/../../../../foo/bar/hey") "foo/bar/hey")
324  (test (svnwiki-path-canonical "/foo/bar/hey") "foo/bar/hey")
325  (test (svnwiki-path-canonical "///foo/bar/../meh/../././bar/hey///") "foo/bar/hey"))
326
327(define (svnwiki-path-canonical path)
328  (assert (and 'svnwiki-path-canonical path))
329  (if (string=? path "")
330    path
331    (string-intersperse
332      (reverse
333        (fold
334          (lambda (c rest)
335            (cond
336              ((string=? c ".") rest)
337              ((string=? c "..") (if (null? rest) '() (cdr rest)))
338              (else (cons c rest))))
339          '()
340          (string-split (if (string? path) path (stream->string path)) "/")))
341      "/")))
342
343(define (svnwiki-xml-escape string)
344  (stream->string
345    (stream-fold-right-delay
346      (lambda (c rest)
347        (case c
348          ((#\') (->stream-char "&apos;" rest))
349          (else (stream-cons c rest))))
350      stream-null
351      (string->stream string))))
352
353(test-group svnwiki-xml-escape
354  (test (svnwiki-xml-escape "Alejo's Test") "Alejo&apos;s Test"))
Note: See TracBrowser for help on using the repository browser.