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

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

Lots of code from Svnwiki has been moved here.

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