source: project/release/4/qwiki/trunk/qwiki-sxml.scm

Last change on this file was 33985, checked in by sjamaan, 4 years ago

qwiki: Add paging to history view; history is getting too long sometimes
File size: 16.3 KB
Line 
1;;
2;; qwiki-sxml - SXML rules and tools for qwiki
3;;
4;; Copyright (c) 2009-2017 Peter Bex and Ivan Raikov
5;;
6;;  Redistribution and use in source and binary forms, with or without
7;;  modification, are permitted provided that the following conditions
8;;  are met:
9;;
10;;  - Redistributions of source code must retain the above copyright
11;;  notice, this list of conditions and the following disclaimer.
12;;
13;;  - Redistributions in binary form must reproduce the above
14;;  copyright notice, this list of conditions and the following
15;;  disclaimer in the documentation and/or other materials provided
16;;  with the distribution.
17;;
18;;  - Neither name of the copyright holders nor the names of its
19;;  contributors may be used to endorse or promote products derived
20;;  from this software without specific prior written permission.
21;;
22;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE
23;;  CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
24;;  INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
25;;  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
26;;  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE
27;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
28;;  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
29;;  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
30;;  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
31;;  AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
32;;  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
33;;  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
34;;  POSSIBILITY OF SUCH DAMAGE.
35
36(module qwiki-sxml
37
38(title-for-wiki-page
39 qwiki-html-transformation-rules)
40
41(import chicken scheme)
42
43(use posix srfi-1 srfi-13 data-structures extras irregex)
44(use sxml-transforms doctype sxpath colorize html-parser)
45
46;; Try to extract a meaningful title from the page contents
47;; Unfortunately, title contents aren't always correct sxml but can
48;; be a list of strings, so we need to do some massaging of the content.
49;; This code doesn't work for links (eg, int-link doesn't have the target
50;; as an attribute but as contents. d'oh!)
51(define (title-for-wiki-page page)
52  (and-let* ((section ((if-car-sxpath '(// (section 1))) (cons 'root page)))
53             (section-contents (caddr section)))
54    (if (string? section-contents)
55        section-contents
56        (string-concatenate
57         (append-map (lambda (x)
58                       (if (string? x)
59                           (list x)
60                           ((sxpath '(// *text*)) x)))
61                     section-contents)))))
62
63(define (lookup-def k lst . rest)
64  (let-optionals rest ((default #f))
65    (alist-ref k lst eq? default)))
66
67(define (make-html-header head-params)
68  `(head
69    ,@(let ((title (lookup-def 'title head-params)))
70        (if title `((title ,title)) '()))
71    (meta (@ (http-equiv "Content-Style-Type") (content "text/css")))
72    (meta (@ (http-equiv "Content-Type") 
73             (content ,(lookup-def 'Content-Type head-params 
74                                   "text/html; charset=UTF-8"))))
75    ,(let ((style  (lookup-def 'style head-params))
76           (print-style  (lookup-def 'print-style head-params))
77           (canonical (lookup-def 'canonical head-params)))
78       (list (if style `(link (@ (rel "stylesheet") (type "text/css") (href ,style))) '())
79             (if print-style `(link (@ (rel "stylesheet") (type "text/css") 
80                                       (media "print")  (href ,print-style))) '())
81             (if canonical `(link (@ (rel "canonical") (href ,canonical))) '())))
82    ;; Remove already processed head parameters, inserting only unprocessed ones
83    ,@(remove (lambda (param)
84                (member (car param) '(title style print-style canonical
85                                            new-file existing-file
86                                            read-only read-write)))
87              head-params)))
88
89(define (internal-link r)
90  (pre-post-order* 
91   r
92   `((*default* . ,(lambda (tag . elems) elems))
93     (*text* . ,(lambda (trigger str) 
94                  (let ((str (string-downcase str)))
95                    (fold (lambda (regex/subst str)
96                            (irregex-replace/all (car regex/subst) str (cdr regex/subst)))
97                          str
98                          '(("^[^a-z]+" . "")
99                            ("[^a-z0-9_ \t-]" . "")
100                            ("[ \t]+" . "-")))))))))
101
102(define (qwiki-html-transformation-rules content)
103  `(((wiki-page 
104      *macro*
105      . ,(lambda (tag elems)
106           `(html:begin . ,elems)))
107
108     ;; Maybe this should be done in multiple steps to make it more "hookable"
109     (history
110      *macro* 
111      . ,(lambda (tag elements)
112           (let* ((items-per-page (car elements))
113                  (path (cadr elements))
114                  (start-revisions (caddr elements))
115                  (all-items (cdddr elements))
116                  (items (if (> (length all-items) items-per-page)
117                             (take all-items items-per-page)
118                             all-items))
119                  (first-item-on-next-page
120                   (and (> (length all-items) items-per-page)
121                        (list-ref all-items items-per-page))))
122             `(div
123               (h3 "Edit history for page: " ,path)
124               (form (@ (method "get") (action ""))
125                     (input (@ (type "hidden") (name "action")
126                               (value "diff")))
127                     (table
128                      (tr (th "revision")
129                          (th "author")
130                          (th "date")
131                          (th "description")
132                          (th "r1")
133                          (th "r2"))
134                      ,@(map (lambda (item)
135                               ;; TODO: The nofollow should really apply
136                               ;; to the entire page instead of each
137                               ;; individual link.
138                               `(tr (td (a (@ (rel "nofollow")
139                                              (href ,(string-append
140                                                      "?action=show&rev="
141                                                      (number->string (car item)))))
142                                           ,(car item)))
143                                    (td ,(cadr item))
144                                    (td ,(time->string (caddr item)))
145                                    (td ,(cadddr item))
146                                    (td (input (@ (type "radio")
147                                                  (name "rev1")
148                                                  (value ,(car item)))))
149                                    (td (input (@ (type "radio")
150                                                  (name "rev2")
151                                                  (value ,(car item)))))))
152                             items))
153                     (input (@ (type "submit")
154                               (value "show diff between selected revisions")
155                               (class "diff-selection"))))
156               ;; Bleeeeergh
157               (div (@ (class "pager"))
158                    ,@(if (not (null? start-revisions))
159                          `((a (@ (href "?action=history"
160                                        ,(string-join
161                                          (map ->string
162                                               (cdr start-revisions))
163                                          "&rev=" 'prefix))
164                                  (class "prev-page"))
165                               "prev page") " ")
166                          '())
167                    ,@(if first-item-on-next-page
168                          (let ((revs (cons (car first-item-on-next-page)
169                                            start-revisions)))
170                            `((a (@ (href "?action=history"
171                                          ,(string-join
172                                            (map ->string revs)
173                                            "&rev=" 'prefix))
174                                    (class "next-page"))
175                                 "next page")))
176                          '()))))))
177
178     (diff
179      *macro*
180      . ,(lambda (tag elems)
181           ;; The diff-language class is a bit weird here, but
182           ;; consistent with what we would emit in a highlight block.
183           (let* ((classname "highlight diff-language diff-page")
184                  (diff (handle-exceptions exn elems
185                          (map (lambda (s)
186                                 (cdr (html->sxml (html-colorize 'diff s))))
187                               elems))))
188             `(pre (@ (class ,classname)) . ,diff))))
189
190     (wiki-content
191      *macro* .
192      ,(lambda (tag contents)
193         `(div (@ (id "content")) . ,contents)))
194
195     (tags
196      *preorder* .
197      ,(lambda (tag page-tags)
198         `(ul (@ (class "tags"))
199              . ,(map (lambda (tag) `(li ,tag))
200                      (string-split (car page-tags))))))
201
202     (highlight
203      *macro*
204      . ,(lambda (tag elems)
205           (let* ((lang (car elems))
206                  (classname (conc "highlight " lang "-language"))
207                  (code (handle-exceptions exn
208                            (cdr elems)
209                          (map (lambda (s)
210                                 (cdr (html->sxml (html-colorize lang s))))
211                               (cdr elems)))))
212             `(pre (@ (class ,classname)) . ,code))))
213
214     (examples
215      ((example
216        ((init
217          *macro*
218          . ,(lambda (tag elems)
219               `(div (@ (class "init")) (highlight scheme . ,elems))))
220         (expr
221          *macro*
222          . ,(lambda (tag elems)
223               `(div (@ (class "expression")) (highlight scheme . ,elems))))
224         (input
225          *macro*
226          . ,(lambda (tag elems)
227               `(div (@ (class "io input")) (em "input: ")
228                     (highlight scheme . ,elems))))
229         (output
230          *macro*
231          . ,(lambda (tag elems)
232               `(div (@ (class "io output")) (em "output: ")
233                     (highlight scheme . ,elems))))
234         (result
235          *macro*
236          . ,(lambda (tag elems)
237               `(div (@ (class "result"))
238                     (span (@ (class "result-symbol")) " => ")
239                     (highlight scheme . ,elems))))) ;; Or use "basic lisp" here?
240        . ,(lambda (tag elems)
241             `(div (@ (class "example")) . ,elems))))
242      . ,(lambda (tag elems)
243           `(div (@ (class "examples"))
244                 (span (@ (class "examples-heading")) "Examples:") . ,elems)))
245
246     (page-specific-links
247      *macro* 
248      . ,(lambda (tag elems)
249           `(ul (@ (id "page-specific-links"))
250                (li ,(if ((if-sxpath '(// new-file)) (cons tag elems))
251                         `(span (@ (class "disabled")
252                                   (title "This page doesn't exist yet"))
253                                "show")
254                         `(a (@ (href "?action=show")) "show")))
255                (li ,(if ((if-sxpath '(// read-only)) (cons tag elems))
256                         `(span (@ (class "disabled")
257                                   (title "This page has been frozen. "
258                                          "Only someone with direct access "
259                                          "to the repository can edit it."))
260                                "edit")
261                         `(a (@ (href "?action=edit") (rel "nofollow")) "edit")))
262                (li ,(if ((if-sxpath '(// new-file)) (cons tag elems))
263                         `(span (@ (class "disabled")
264                                   (title "This page doesn't exist yet"))
265                                "history")
266                         `(a (@ (href "?action=history")) "history"))))))
267
268     (@ *preorder* . ,(lambda (tag elements) (cons tag elements)))
269
270     (Header
271      *preorder*
272      . ,(lambda (tag headers)
273           (make-html-header headers)))
274
275     (toc ;; Re-scan the content for "section" tags and generate
276      *macro*
277      . ,(lambda (tag rest) ;; the table of contents
278           `(div (@ (id "toc"))
279                 ,rest
280                 (ol ,(let find-sections ((content content))
281                        (cond
282                         ((not (pair? content)) '())
283                         ((pair? (car content))
284                          (append (find-sections (car content))
285                                  (find-sections (cdr content))))
286                         ((eq? (car content) 'section)
287                          (let* ((level (cadr content))
288                                 (head-word (caddr content))
289                                 (href (list "#" (internal-link head-word)))
290                                 (subsections (find-sections (cdddr content))))
291                            (cond ((and (integer? level) head-word)
292                                   `((li (a (@ (href (,href))) ,head-word)
293                                         ,@(if (null? subsections)
294                                               '()
295                                               `((ol ,subsections))))))
296                                  (else
297                                   (error 'html-transformation-rules
298                                          "section elements must be of the form (section level head-word . contents)")))))
299                         (else (find-sections (cdr content)))))))))
300
301     (section
302      *macro*
303      . ,(lambda (tag elems)
304           (let* ((level (car elems))
305                  (head-word (cadr elems))
306                  (link (internal-link head-word))
307                  (contents (cddr elems)))
308             (cond ((and (integer? level) head-word)
309                    `((a (@ (href ,@(list "#" link)))
310                         (,(string->symbol (string-append "h" (number->string level)))
311                          (@ (id ,link))
312                          ,head-word)) . ,contents))
313                   (else
314                    (error 'html-transformation-rules
315                           (conc "section elements must be of the form (section level head-word . contents), got " elems)))))))
316
317     (section*
318      *macro*
319      . ,(lambda (tag elems)
320           (let ((level (car elems))
321                 (head-word (cadr elems))
322                 (contents (cddr elems)))
323             (cond ((and (integer? level) head-word)
324                    `((,(string->symbol (string-append "h" (number->string level)))
325                       ,head-word ) . ,contents))
326                   (else
327                    (error 'html-transformation-rules
328                           (conc "section elements must be of the form (section level head-word . contents), got " elems)))))))
329
330     (def
331      ((sig . ,(lambda (tag types)
332                 (map (lambda (spec)
333                        `(span (@ (class ,(conc "definition " (car spec))))
334                               (em "[" ,(symbol->string (car spec)) "]")
335                               " " (tt ,@(cdr spec)) (br)))
336                      types))))
337      . ,(lambda (tag elems) elems))
338
339     (pre
340      . ,(lambda (tag elems)
341           `(pre (tt . ,elems))))
342
343     (image-link
344      *macro*
345      . ,(lambda (tag elems)
346           `(img (@ (src ,(car elems)) . ,(if (null? (cdr elems))
347                                              '()
348                                              `((alt ,(cadr elems))
349                                                (title ,(cadr elems))))))))
350
351     (int-link
352      *macro*
353      . ,(lambda (tag elems)
354           ;; Normalize links so people can refer to sections by their proper name
355           (let* ((parts (string-split (car elems) "#" #t))
356                  (nparts (intersperse
357                           (cons (car parts) (internal-link (cdr parts)))
358                           "#")))
359             `(a (@ (href ,@nparts) (class "internal"))
360                 ,(if (null? (cdr elems)) (car elems) (cadr elems))))))
361
362     (link
363      *macro*
364      . ,(lambda (tag elems)
365           `(a (@ (href ,(car elems)) (class "external"))
366               ,(if (null? (cdr elems)) (car elems) (cadr elems)))))
367
368     ,@alist-conv-rules*)
369
370    ((html:begin
371      . ,(lambda (tag elems)
372           (list xhtml-1.0-strict
373                 "<html xmlns=\"http://www.w3.org/1999/xhtml\">"
374                 elems
375                 "</html>")))
376
377     (verbatim
378      *preorder*
379      . ,(lambda (tag elems)
380           elems))
381
382     ,@universal-conversion-rules*)))
383
384)
Note: See TracBrowser for help on using the repository browser.