source: project/release/4/qwiki/trunk/qwiki.scm @ 15475

Last change on this file since 15475 was 15475, checked in by sjamaan, 10 years ago

Remove dependency on sxml-fu, since we now only use one small procedure from it

File size: 13.3 KB
Line 
1;;
2;; qwiki - the quick wiki
3;;
4;; Copyright (c) 2009 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
37  (qwiki-docroot 
38   qwiki-source-path 
39   qwiki-base-uri 
40   qwiki-handler
41   qwiki-show
42   qwiki-edit
43   qwiki-history
44   qwiki-render-file
45   qwiki-transformation-steps
46   qwiki-extensions
47   )
48
49(import chicken scheme)
50(use extras files posix ports data-structures srfi-1 srfi-13 srfi-14
51     intarweb uri-common spiffy sxml-transforms
52     wiki-parse qwiki-sxml doctype
53     ;; There should be a way to parameterize the versioning implementation
54     qwiki-svn)
55
56;; HTML files are stored here, relative to the current Spiffy docroot
57(define qwiki-docroot (make-parameter "/"))
58
59;; The location of the wiki source files (where a checkout will be made)
60(define qwiki-source-path (make-parameter "/tmp/qwiki"))
61
62;; The base URI for this wiki
63(define qwiki-base-uri (make-parameter "/" uri-reference))
64 
65;; The rules used for rendering wiki pages (default is HTML)
66(define qwiki-output-driver
67  (make-parameter qwiki-html-transformation-rules))
68
69(define qwiki-extensions
70  (make-parameter (list)))
71
72;; This must match name-to-base in svnwiki/deps.scm
73;; It is changed slightly to disallow newlines, tabs or other "weird"
74;; whitespace characters.
75(define (simplify-pagename pagename)
76  (if (file-exists? (make-pathname (qwiki-source-path) pagename))
77      pagename
78      (string-downcase
79       (string-filter (char-set-union char-set:letter+digit
80                                      (char-set #\space #\/ #\-))
81                      (string-translate pagename " " "-")))))
82
83(define wiki-link-normalization
84  `((wiki . ,(lambda (tag href . contents)
85               (let ((pretty-href (simplify-pagename href)))
86                 (if (pair? contents)
87                     `(wiki ,pretty-href ,@contents)
88                     `(wiki ,pretty-href ,href)))))
89    ,@alist-conv-rules))
90
91;; The rules used for transforming page SXML structure
92(define (qwiki-transformation-steps content)
93  (append (list wiki-link-normalization)
94          (qwiki-extensions)
95          ((qwiki-output-driver) content)
96          ))
97
98;; The basic template for SXML wiki pages
99(define (qwiki-sxml-page-template contents . headers)
100   `(wiki-page (Header ,@headers)
101               (body (page-specific-links)
102                     ,contents)))
103
104;; Return the trailing part of the path relative to the docroot/base-uri
105;; eg: If the wiki lives under /qwiki, /qwiki/eggref/4/9p gives /eggref/4/9p
106(define (relative-uri-path uri)
107  ;; Both URIs are assumed to contain absolute paths
108  (let loop ((path (cdr (uri-path uri)))
109             (base-path (cdr (uri-path (qwiki-base-uri)))))
110    (cond
111     ((or (null? base-path) (string-null? (car base-path))) path)
112     ((and (not (null? path))
113           (string=? (car path) (car base-path)))
114      (loop (cdr path) (cdr base-path)))
115     (else (error "Bad request URI path. Please configure qwiki-base-uri.")))))
116
117(define (path->html-filename path)
118  (make-pathname (qwiki-docroot)
119                 (string-join path "/") "html"))
120
121(define (path->source-filename path)
122  (make-pathname (qwiki-source-path) (string-join path "/")))
123
124;; Handle index files where needed.  Never try to open a directory as file
125(define (normalize-path path)
126  (if (directory? (path->source-filename path))
127      (append path '("index"))
128      path))
129
130;; Like with-output-to-file, only this creates parent directories as needed.
131(define (with-output-to-path path thunk)
132  (unless (file-exists? (pathname-directory path))
133    (create-directory (pathname-directory path) #t))
134  (with-output-to-file path thunk))
135
136;; From sxml-fu
137(define (output-xml tree rulesets)
138  (SRV:send-reply (fold (lambda (ruleset tree)
139                          (pre-post-order tree ruleset))
140                        tree rulesets)))
141
142(define (send-content content)
143  (write-logged-response)
144  (with-output-to-port (response-port (current-response))
145    (lambda ()
146      (output-xml content (qwiki-transformation-steps content))))
147  (close-output-port (response-port (current-response))))
148
149
150
151;;; Actions
152(define (qwiki-history path req)
153  (let* ((source-file (path->source-filename path))
154         (rev (string->number
155               (alist-ref 'rev (uri-query (request-uri req)) eq? "")))
156         (history (get-history source-file rev #f)) ; no pagination yet
157         (content (qwiki-sxml-page-template `(history ,history))))
158    (send-content content)))
159
160(define (qwiki-edit path req)
161  (let* ((html-file (path->html-filename path))
162         (source-file (path->source-filename path))
163         (postdata (if (eq? 'POST (request-method req))
164                       (form-urldecode (read-request-data req))
165                       '()))
166         (source (or (alist-ref 'source postdata)
167                     (and (file-exists? source-file)
168                          (with-input-from-file source-file read-string))
169                     ""))
170         (comment (alist-ref 'comment postdata eq? ""))
171         (username (alist-ref 'username postdata eq? ""))
172         (password (alist-ref 'password postdata eq? ""))
173         (auth (alist-ref 'auth postdata eq?))
174         ;; TODO: Clean this up, maybe put it in a transformation rule so
175         ;; it can be extended by plugins.  The names of the buttons are
176         ;; pretty much tied to the code though
177         (make-form
178          (lambda (#!optional message)
179            (qwiki-sxml-page-template 
180             `(,(if (alist-ref 'preview postdata)
181                    `(div (@ (class "preview"))
182                          (h2 "Preview")
183                          ,(wiki-parse source))
184                    "")
185               ,(if message
186                    `(div (@ class "message") ,message)
187                    "")
188               (form (@ (method "post") (action ""))
189                     (div (@ (id "article"))
190                          (label "Article contents:"
191                                 (textarea (@ (name "source")
192                                              (rows "20") (cols "72"))
193                                           ,source))
194                          (label "Description of your changes:"
195                                 (textarea (@ (name "comment")
196                                              (rows "2") (cols "72"))
197                                           ,comment)))
198                     (div (@ (id "auth"))
199                          (label "I would like to authenticate"
200                                 (input (@ (type "checkbox")
201                                           (name "auth")
202                                           ,@(if auth
203                                                 '((checked "checked"))
204                                                 '()))))
205                          (label "Username:"
206                                 (input (@ (type "text")
207                                           (name "username")
208                                           (value ,username))))
209                          (label "Password:"
210                                 (input (@ (type "password")
211                                           (name "password")
212                                           (value ,password)))))
213                     (div (@ (id "actions"))
214                          (input (@ (type "submit")
215                                    (name "save")
216                                    (value "Save")))
217                          (input (@ (type "submit")
218                                    (name "preview")
219                                    (value "Preview"))))))))))
220    (if (alist-ref 'save postdata)
221        (begin
222          (with-output-to-path source-file (lambda () (display source)))
223          (handle-exceptions exn
224            (begin
225              (undo-changes! source-file)
226              (update-sources! source-file)
227              (send-content (make-form (conc "Warning! Someone has edited this page while you were editing it. You can click save again to overwrite those changes with yours if this is the case."
228                                             (if auth
229                                                 " It is also possible your username/password are incorrect."
230                                                 "")))))
231            (store-changes! source-file comment
232                            (and auth username) (and auth password))
233            (redirect-to-qwiki-page req action: "show")))
234        (send-content (make-form)))))
235
236(define (redirect-to-qwiki-page req
237                                #!key
238                                ;; TODO: make path relative to qwiki-base-uri
239                                (path (uri-path (request-uri req)))
240                                (action "show"))
241  (with-headers `((location
242                   ,(update-uri (server-root-uri)
243                                path: path
244                                query: (alist-update!
245                                        'action action
246                                        (or (uri-query (request-uri req))
247                                            '())))))
248    ;; Maybe send a 303?
249    (lambda () (send-status 302 "Found"))))
250
251(define (qwiki-show path req)
252  ;; TODO: What if someone did something else than GET or HEAD?
253  (let* ((html-file (path->html-filename path))
254         (source-file (path->source-filename path))
255         (rev (string->number
256               (alist-ref 'rev (uri-query (request-uri req)) eq? ""))))
257    (if (file-exists? source-file)
258        (if rev
259            (send-content ; Do not store if old rev
260             (qwiki-sxml-page-template
261              (call-with-input-revision
262               source-file rev wiki-parse)))
263            (begin
264             (update-html-file! (make-pathname (root-path) html-file)
265                                source-file)
266             (send-static-file html-file)))
267        (redirect-to-qwiki-page req action: "edit"))))
268
269(define (file-newer? a b)
270  (> (file-modification-time a) (file-modification-time b)))
271
272;; Generate new cached HTML file
273(define (update-html-file! html-file source-file #!optional force-update)
274  (when (or force-update
275            (not (file-exists? html-file))
276            (file-newer? source-file html-file))
277    (with-output-to-path html-file
278      (lambda ()
279        (let ((content (qwiki-sxml-page-template
280                        (call-with-input-file source-file wiki-parse))))
281          (output-xml content (qwiki-transformation-steps content)))))))
282
283;;; Request dispatching
284(define action-handlers
285  `((edit    . ,qwiki-edit)
286    (show    . ,qwiki-show)
287    (history . ,qwiki-history)))
288
289(define (read-request-data req)
290  (let ((len (header-value 'content-length (request-headers req))))
291    ;; If the header is not available, this will read until EOF
292    (read-string len (request-port req))))
293
294;; From Spiffy. Maybe export it there?
295(define (impossible-filename? name)
296  (or (string=? name ".") (string=? name "..") (string-index name #\/)))
297
298(define (ensure-latest-sources!)
299  (if (not (directory-exists? (qwiki-source-path)))
300      (checkout-sources! (qwiki-source-path))
301      ;; Not sure if this should be done every freaking time - it's slow!
302      #;(update-sources! (qwiki-source-path))
303      (void)))
304
305;; Spiffy handler for requests that should be routed to the wiki
306(define (qwiki-handler continue)
307  (ensure-latest-sources!)
308  (let ((uri (request-uri (current-request))))
309    (if (any impossible-filename? (cdr (uri-path uri))) ; assumed to be absolute
310        (begin
311          (read-request-data (current-request))
312          (send-status 404 "Not found"))
313        (let* ((action (string->symbol
314                        (alist-ref 'action (uri-query uri) eq? "show")))
315               (handler (alist-ref action action-handlers eq? qwiki-show)))
316          (handler (normalize-path (relative-uri-path uri))
317                   (current-request))))))
318
319(define (qwiki-render-file file)
320  (call-with-input-file file
321    (lambda (input)
322      (let ((content (qwiki-sxml-page-template (wiki-parse input))))
323        (output-xml content (qwiki-transformation-steps content))))))
324
325)
Note: See TracBrowser for help on using the repository browser.