source: project/release/4/qwiki/branches/svnwiki-sxml/qwiki.scm @ 18579

Last change on this file since 18579 was 18579, checked in by sjamaan, 11 years ago

qwiki: Fix small typo

File size: 26.2 KB
Line 
1;;
2;; qwiki - the quick wiki
3;;
4;; Copyright (c) 2009-2010 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;; TODO: Attempt to split out all Spiffy and URI-related stuff.
37;; This makes things like the post-commit-hook much more lightweight.
38
39(module qwiki
40  (qwiki-docroot
41   qwiki-web-path
42   qwiki-source-path 
43   qwiki-base-uri 
44   qwiki-handler
45   qwiki-show
46   qwiki-edit
47   qwiki-history
48   qwiki-transformation-steps
49   qwiki-extensions
50   qwiki-output-driver
51   qwiki-global-action-handlers
52   qwiki-page-action-handlers
53   qwiki-update-handlers
54   qwiki-update-file!
55   qwiki-delete-handlers
56   qwiki-delete-file!
57   qwiki-clear-cache!
58   qwiki-css-file
59   qwiki-sxml-page-template
60   send-content
61   write-content
62   blocked-ip-addresses-file
63   )
64
65(import chicken scheme)
66(use extras files posix ports data-structures srfi-1 srfi-13 srfi-14
67     intarweb uri-common spiffy sxml-transforms sxpath
68     svnwiki-sxml qwiki-sxml doctype sha1
69     ;; There should be a way to parameterize the versioning implementation
70     qwiki-svn)
71
72;; HTML files are stored here, relative to the current Spiffy docroot
73(define qwiki-docroot (make-parameter "/"))
74
75;; The docroot. This will be parameterized to be identical to the Spiffy
76;; docroot when running inside the webserver.  The post-commit-hook
77;; could need to customize this.
78(define qwiki-web-path
79  (make-parameter
80   (or (get-environment-variable "QWIKI_WEB_PATH") "/var/www")))
81
82;; The location of the wiki source files (where a checkout will be made)
83(define qwiki-source-path
84  (make-parameter
85   (or (get-environment-variable "QWIKI_SOURCE_PATH") "/tmp/qwiki")))
86
87;; The base URI for this wiki
88(define qwiki-base-uri (make-parameter "/" uri-reference))
89 
90;; The rules used for rendering wiki pages (default is HTML)
91(define qwiki-output-driver
92  (make-parameter qwiki-html-transformation-rules))
93
94(define qwiki-extensions
95  (make-parameter (list)))
96
97(define qwiki-update-handlers
98  (make-parameter (list)))
99
100(define qwiki-delete-handlers
101  (make-parameter (list)))
102
103;; Not configurable but used during processing; the file currently being
104;; processed by the system.
105(define qwiki-current-file
106  (make-parameter #f))
107
108(define qwiki-css-file
109  (make-parameter #f (lambda (x) (and x (uri-reference x)))))
110
111(define blocked-ip-addresses-file
112  (make-parameter "edit-deny"))
113
114;; This must match name-to-base in svnwiki/deps.scm
115;; It is changed slightly to disallow newlines, tabs or other "weird"
116;; whitespace characters.
117(define (simplify-pagename pagename)
118  (let* ((basedir  (and (qwiki-current-file) (pathname-directory (qwiki-current-file))))
119         (pagedir  (if basedir
120                       (make-pathname (qwiki-source-path) basedir)
121                       (qwiki-source-path)))
122         ;; Try if any of these exist, first
123         (attempts (list pagename (string-downcase pagename))))
124    (or (find (lambda (f) (file-exists? (make-pathname pagedir f))) attempts)
125        ;; None match?  Then simplify by getting rid of nonalphanumerics and
126        ;; convert spaces to dashes.  This results in sane, easy to type URIs.
127        (string-downcase (string-filter
128                          (char-set-union char-set:letter+digit
129                                          (char-set #\space #\/ #\-))
130                          (string-translate pagename " " "-"))))))
131
132(define wiki-link-normalization
133  `((int-link . ,(lambda (tag tree)
134                   (let* ((href (car tree))
135                          (contents (cdr tree))
136                          (pretty-href (simplify-pagename href)))
137                     (if (pair? contents)
138                         `(int-link ,pretty-href . ,contents)
139                         `(int-link ,pretty-href ,href)))))
140    . ,alist-conv-rules*))
141
142;; The rules used for transforming page SXML structure
143(define (qwiki-transformation-steps content)
144  (append (list wiki-link-normalization)
145          (qwiki-extensions)
146          ((qwiki-output-driver) content)
147          ))
148
149;; The basic template for SXML wiki pages
150(define (qwiki-sxml-page-template contents . headers)
151  (let ((headers
152         (if (qwiki-css-file)
153             (cons `(style ,(uri->string (uri-relative-to (qwiki-css-file)
154                                                          (qwiki-base-uri))))
155                   headers)
156             headers)))
157    `(wiki-page (Header . ,headers)
158                (body (page-specific-links . ,headers)
159                      (wiki-content ,contents)))))
160
161;; Return the trailing part of the path relative to the docroot/base-uri
162;; eg: If the wiki lives under /qwiki, /qwiki/eggref/4/9p gives /eggref/4/9p
163(define (relative-uri-path uri)
164  ;; Both URIs are assumed to contain absolute paths
165  (let loop ((path (cdr (uri-path uri)))
166             (base-path (cdr (uri-path (qwiki-base-uri)))))
167    (cond
168     ((or (null? base-path) (string-null? (car base-path))) path)
169     ((and (not (null? path))
170           (string=? (car path) (car base-path)))
171      (loop (cdr path) (cdr base-path)))
172     (else (error "Bad request URI path. Please configure qwiki-base-uri.")))))
173
174(define (path->html-filename path)
175  (make-pathname (qwiki-docroot)
176                 (string-join path "/") "html"))
177
178(define (path->source-filename path)
179  (make-pathname (qwiki-source-path) (string-join path "/")))
180
181;; Handle index files where needed.  Never try to open a directory as file
182(define (normalize-path path)
183  (remove! string-null?
184           (if (directory? (path->source-filename path))
185               (append path '("index"))
186               path)))
187
188;; Like with-output-to-file, only this creates parent directories as needed.
189(define (with-output-to-path path thunk)
190  (unless (file-exists? (pathname-directory path))
191    (create-directory (pathname-directory path) #t))
192  (with-output-to-file path thunk))
193
194;; From sxml-fu
195(define (output-xml tree rulesets)
196  (SRV:send-reply (fold (lambda (ruleset tree)
197                          (pre-post-order* tree ruleset))
198                        tree rulesets)))
199
200(define (send-content content)
201  (write-logged-response)
202  (with-output-to-port (response-port (current-response))
203    (lambda ()
204      (output-xml content (qwiki-transformation-steps content))))
205  (close-output-port (response-port (current-response))))
206
207(define (write-content content)
208  (output-xml content (qwiki-transformation-steps content)))
209
210
211;;; Actions
212(define (qwiki-history path req)
213  (let ((source-file (path->source-filename path)))
214    (if (not (file-exists? source-file))
215        (redirect-to-qwiki-page req action: "show")       
216        (let* ((rev (string->number
217                    (alist-ref 'rev (uri-query (request-uri req)) eq? "")))
218              (history (get-history source-file rev #f)) ; no pagination yet
219              (content (qwiki-sxml-page-template
220                        `(history . ,history)
221                        ;; We could determine the current title by parsing
222                        ;; the wiki page. That would be a bit wasteful though...
223                        ;; Perhaps read out svnwiki:title instead?
224                        `(title ,(sprintf "Edit history for page: ~A"
225                                          (string-join path "/")))
226                        (if (frozen? source-file) '(read-only) '(read-write)))))
227          (send-content content)))))
228
229(define (blocked-ip-address? ip-address)
230  (and-let* ((f (blocked-ip-addresses-file))
231             (file (make-pathname (qwiki-source-path) f))
232             ((file-exists? file)))
233    (call-with-input-file file
234      (lambda (p)
235        (let loop ((line (read-line p)))
236          (if (eof-object? line)
237              #f
238              (or (string=? (string-trim-both line) ip-address)
239                  (loop (read-line p)))))))))
240
241(define (qwiki-edit path req)
242  (let* ((source-file (path->source-filename path))
243         (auth-required (requires-authentication? source-file))
244         (postdata (if (eq? 'POST (request-method req))
245                       (form-urldecode (read-request-data req))
246                       '()))
247         (new-file (not (file-exists? source-file)))
248         (file-revision (if new-file 0 (get-last-modified-revision source-file)))
249         (source (or (alist-ref 'source postdata)
250                     (and (not new-file)
251                          (with-input-from-file source-file read-string))
252                     ""))
253         (sxml (call-with-input-string source svnwiki->sxml))
254         (comment (alist-ref 'comment postdata eq? ""))
255         (username (alist-ref 'username postdata eq? ""))
256         (password (alist-ref 'password postdata eq? ""))
257         (make-spam-control-hash
258          (lambda (answer time)
259            (sha1-digest (sprintf "Answer: ~A for file ~A (r~A) at ~A"
260                                  answer source-file file-revision time))))
261         (auth (or auth-required (alist-ref 'auth postdata)))
262         (title ((sxpath '(// (section 1) (*text* 1))) (cons 'root sxml)))
263         ;; If spambot provided auth, it will fail on bad credentials later
264         (likely-human
265          (or auth (and-let* ((hash (alist-ref 'captcha-hash postdata))
266                              (ans (alist-ref 'captcha-answer postdata))
267                              (time (alist-ref 'captcha-time postdata))
268                              ((> (string->number time) ; max half an hour old
269                                  (- (current-seconds) 108000)))
270                              (expected-hash (make-spam-control-hash ans time)))
271                     ;; The hash is unique for this form since this file
272                     ;; will only be changed for this revision once and
273                     ;; the revision/filename combination is unforgeable.
274                     ;; We could use crypt() instead of sha1 for added
275                     ;; security but it hardly seems worth it because the
276                     ;; challenge itself is rather weak...
277                     (string=? hash expected-hash))))
278         ;; TODO: Clean this up, maybe put it in a transformation rule so
279         ;; it can be extended by plugins.  The names of the buttons are
280         ;; pretty much tied to the code though
281         (make-form
282          (lambda (#!optional message)
283            (qwiki-sxml-page-template 
284             `(,(if (alist-ref 'preview postdata)
285                    `(div (@ (class "preview")) (h2 "Preview") ,sxml)
286                    "")
287               ,(if message
288                    `(div (@ class "message") ,message)
289                    "")
290               (form (@ (method "post") (action ""))
291                     (div (@ (id "article"))
292                          (label "Article contents:"
293                                 (textarea (@ (name "source")
294                                              (rows "20") (cols "72"))
295                                           ,source))
296                          (label "Description of your changes:"
297                                 (textarea (@ (name "comment")
298                                              (rows "2") (cols "72"))
299                                           ,comment)))
300                     (div (@ (id "auth"))
301                          ,(if auth-required
302                               `(label "This file is " (em "locked.")
303                                       " To edit it, you "
304                                       (em "must authenticate.")
305                                       (input (@ (type "hidden")
306                                                 (name "auth")
307                                                 (value "true"))))
308                               `(label "I would like to authenticate"
309                                       (input (@ (type "checkbox")
310                                                 (name "auth")
311                                                 (id "auth-checkbox")
312                                                 (value "true")
313                                                 . ,(if auth
314                                                        '((checked "checked"))
315                                                        '())))))
316                          (div (@ (id "credentials"))
317                               (label "Username:"
318                                      (input (@ (type "text")
319                                                (name "username")
320                                                (value ,username))))
321                               (label "Password:"
322                                      (input (@ (type "password")
323                                                (name "password")
324                                                (value ,password))))))
325                     ,(if auth-required ;; No point in including a spam check
326                          `(div)
327                          (let* ((op (car (shuffle '(+ - *) random)))
328                                 (a (random (if (eq? op '*) 10 25)))
329                                 (b (random (if (eq? op '*) 10 25)))
330                                 (res ((case op ((+) +) ((-) -) ((*) *)) a b))
331                                 (time (->string (current-seconds))))
332                           `(div (@ (id "antispam"))
333                                 (h3 "Spam control")
334                                 (p "What do you get when you "
335                                    ,(case op
336                                       ((-) (sprintf " subtract ~A from ~A?" b a))
337                                       ((*) (sprintf " multiply ~A by ~A?" a b))
338                                       ((+) (sprintf " add ~A to ~A?" a b))))
339                                 (input (@ (type "hidden") (name "captcha-time")
340                                           (value ,time)))
341                                 (input (@ (type "hidden") (name "captcha-hash")
342                                           (value ,(make-spam-control-hash
343                                                    res time))))
344                                 (input (@ (type "text") (name "captcha-answer")
345                                           ;; prevent Firefox from pre-filling:
346                                           (value "")))
347                                 ;; Really nasty inline JS, but this keeps
348                                 ;; it lean and mean; no external JS needed.
349                                 (script (@ (type "text/javascript"))
350                                         "var box = document.getElementById('auth-checkbox');"
351                                         "var as = document.getElementById('antispam').style;"
352                                         "var cs = document.getElementById('credentials').style;"
353                                         "if (box.checked)"
354                                         "  as.display = 'none';"
355                                         " else "
356                                         "  cs.display = 'none';"
357                                         "box.onclick = function() {"
358                                         "  if (box.checked) {"
359                                         "    as.display = 'none';"
360                                         "    cs.display = 'block';"
361                                         "  } else {"
362                                         "    as.display = 'block';"
363                                         "    cs.display = 'none';"
364                                         "  }"
365                                         "};"))))
366                     (div (@ (id "actions"))
367                          (input (@ (type "submit")
368                                    (name "save")
369                                    (value "Save")))
370                          (input (@ (type "submit")
371                                    (name "preview")
372                                    (value "Preview"))))))
373             `(title ,(sprintf "Editing page: ~A" (if (null? title)
374                                                      (string-join path "/")
375                                                      (car title))))
376             (if new-file '(new-file) '(existing-file))))))
377    (cond
378     ((frozen? source-file) (redirect-to-qwiki-page req action: "show"))
379     ((blocked-ip-address? (remote-address))
380      (send-content
381       (make-form (conc "You have been blocked from making any edits. "
382                        "If you believe this is in error, please contact "
383                        "the administrators of this wiki."))))
384     ((and (alist-ref 'save postdata) (not likely-human))
385      (send-content
386       (make-form (conc "Your answer to the spam control question was "
387                        "incorrect.  Are you a spammer?  Gosh, I hope not! "
388                        "Try again, but please try a little harder!"))))
389     ((alist-ref 'save postdata)
390      (with-output-to-path source-file (lambda () (display source)))
391      (handle-exceptions exn
392        (begin
393          (undo-changes! source-file)
394          ;; No idea how to cleanly ensure a proper update...
395          ;; The enclosing directory might have been removed, or the file
396          ;; might have been deleted, renamed etc.  Let's just update the
397          ;; whole tree (but this can take a long time)
398          (ensure-latest-sources! #t)
399          (send-content (make-form (conc "Warning! Someone has edited this "
400                                         "page while you were editing it. "
401                                         "You can click save again to "
402                                         "overwrite those changes with yours "
403                                         "if this is the case."
404                                         (if auth
405                                             (conc " It is also possible your "
406                                                   "username/password are "
407                                                   "incorrect.")
408                                             "")))))
409       
410        (store-changes! source-file
411                        (if auth
412                            comment
413                            (sprintf "Anonymous wiki edit for IP [~A]: ~A"
414                                     (remote-address) comment))
415                        (and auth username) (and auth password))
416        (redirect-to-qwiki-page req action: "show")))
417     (else (send-content (make-form))))))
418
419(define (redirect-to-qwiki-page req
420                                #!key
421                                ;; TODO: make path relative to qwiki-base-uri
422                                (path (uri-path (request-uri req)))
423                                (action "show"))
424  (with-headers `((location
425                   ,(update-uri (server-root-uri)
426                                path: path
427                                query: (alist-update!
428                                        'action action
429                                        (or (uri-query (request-uri req))
430                                            '())))))
431    ;; Maybe send a 303?
432    (lambda () (send-status 302 "Found"))))
433
434(define (qwiki-show path req)
435  ;; TODO: What if someone did something else than GET or HEAD?
436  (let* ((html-file (path->html-filename path))
437         (html-path (make-pathname (qwiki-web-path) html-file))
438         (source-file (path->source-filename path)))
439    (cond
440     ((not (file-exists? source-file))
441      (redirect-to-qwiki-page req action: "edit"))
442     ((string->number (alist-ref 'rev (uri-query (request-uri req)) eq? ""))
443      => (lambda (rev) ; Do not cache HTML file if historical rev was requested
444           (send-content
445            (let* ((sxml (call-with-input-revision
446                          source-file rev svnwiki->sxml))
447                   (title ((sxpath '(// (section 1) (*text* 1)))
448                           (cons 'root sxml))))
449              (qwiki-sxml-page-template
450               sxml
451               `(title ,(sprintf "~A (historical revision ~A)"
452                                 (if (null? title)
453                                     (string-join path "/")
454                                     (car title))
455                                 rev))
456               (if (frozen? source-file) '(read-only) '(read-write)))))))
457     (else (when (or (not (file-exists? html-path))
458                     (file-newer? source-file html-path))
459             (qwiki-update-file! path))
460           (send-static-file html-file)))))
461
462(define (frozen? source-file)
463  (and-let* ((value (get-extended-property source-file "svnwiki:frozen")))
464    (string=? (string-trim-both value) "yes")))
465
466(define (requires-authentication? source-file)
467  (and-let* ((value (get-extended-property source-file "svnwiki:authenticate")))
468    (string=? (string-trim-both value) "yes")))
469
470(define (file-newer? a b)
471  (> (file-modification-time a) (file-modification-time b)))
472
473;; Generate new cached HTML file
474(define (regenerate-html-file! path page)
475  (let* ((html-file (make-pathname (qwiki-web-path) (path->html-filename path)))
476         (title ((sxpath '(// (section 1) (*text* 1))) (cons 'root page))))
477    (with-output-to-path html-file
478      (lambda ()
479        (let ((content (qwiki-sxml-page-template
480                        page
481                        `(title  ,(if (null? title)
482                                      (string-join path "/")
483                                      (car title)))
484                        (if (frozen? (path->source-filename path))
485                            '(read-only)
486                            '(read-write)))))
487          (output-xml content (qwiki-transformation-steps content)))))))
488
489(define (qwiki-update-file! path)
490  (let* ((source-file (path->source-filename path))
491         (page (call-with-input-file source-file svnwiki->sxml)))
492    (parameterize ((qwiki-current-file (string-join path "/")))
493      (for-each (lambda (handler) (handler path page))
494                (append (qwiki-update-handlers) (list regenerate-html-file!))))))
495
496(define (delete-html-file! path)
497  (let ((basename
498         (make-pathname (qwiki-docroot)
499                        (string-join (cons (qwiki-web-path) path) "/"))))
500    (if (and (directory? basename) (not (symbolic-link? basename)))
501        (begin
502          (for-each delete-html-file! (directory basename #t))
503          (delete-directory basename))
504        (delete-file* (string-append basename ".html")))))
505
506;; Destroy all HTML files in the cache
507(define (qwiki-clear-cache!)
508  (find-files (qwiki-web-path)
509              (lambda (f) (string=? (or (pathname-extension f) "") "html"))
510              (lambda (f _) (delete-file* f)) #f
511              (lambda (x) (not (symbolic-link? x)))))
512
513(define (qwiki-delete-file! path)
514  (for-each (lambda (handler) (handler path))
515            (cons delete-html-file! (qwiki-delete-handlers))))
516
517;;; Request dispatching
518(define qwiki-page-action-handlers
519  (make-parameter
520   `((edit    . ,qwiki-edit)
521     (show    . ,qwiki-show)
522     (history . ,qwiki-history))))
523
524(define qwiki-global-action-handlers
525  (make-parameter (list)))
526
527(define (read-request-data req)
528  (let ((len (header-value 'content-length (request-headers req))))
529    ;; If the header is not available, this will read until EOF
530    (read-string len (request-port req))))
531
532;; From Spiffy. Maybe export it there?
533(define (impossible-filename? name)
534  (or (string=? name ".") (string=? name "..") (string-index name #\/)))
535
536(define (ensure-latest-sources! #!optional force?)
537  ;; Not sure if this should be done every freaking time - it's slow!
538  (if force?
539      (update-sources! (qwiki-source-path))
540      (void)))
541
542;; Spiffy handler for requests that should be routed to the wiki
543(define (qwiki-handler continue)
544  (parameterize ((qwiki-web-path (root-path)))
545    (cond
546     ((not (directory-exists? (qwiki-source-path)))
547      (send-status 503 "Missing checkout"
548                   (conc "<p>Checkout not found. Expected it in "
549                         "<code>" (htmlize (qwiki-source-path)) "</code>.<p>"
550                         "<p>To fix this, please run qwiki-install or change "
551                         "the value of <code>qwiki-source-path</code>.</p>")))
552     (else
553      (ensure-latest-sources!)
554      (let ((uri (request-uri (current-request))))
555        (cond
556         ((equal? (uri-path uri) (uri-path (qwiki-css-file)))
557          (send-static-file
558           (make-pathname (qwiki-docroot)
559                          (string-join (cdr (uri-path (qwiki-css-file))) "/"))))
560         ((find (lambda (a)
561                  (equal? (uri-path uri) (list '/ (->string (car a)))))
562                (qwiki-global-action-handlers))
563          => (lambda (handler)
564               ((cdr handler) (current-request))))
565         ((any impossible-filename? (cdr (uri-path uri))) ; should be absolute
566          (read-request-data (current-request))
567          (send-status 404 "Not found"))
568         (else (let* ((action (string->symbol
569                               (alist-ref 'action (uri-query uri) eq? "show")))
570                      (handler (alist-ref action
571                                          (qwiki-page-action-handlers)
572                                          eq? qwiki-show)))
573                 (handler (normalize-path (relative-uri-path uri))
574                          (current-request))))))))))
575
576)
Note: See TracBrowser for help on using the repository browser.