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

Last change on this file since 27237 was 27237, checked in by sjamaan, 9 years ago

Qwiki: make request reading re-use read-urlencoded-request-data from intarweb

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