source: project/release/5/qwiki/trunk/qwiki.scm @ 36104

Last change on this file since 36104 was 36104, checked in by sjamaan, 9 months ago

Port qwiki to CHICKEN 5

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