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

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

qwiki: Handle non-existing files a bit more gracefully

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         (file-rev (or (and (file-exists? source-file) (get-last-modified-revision source-file)) 0))
344         ;; Used for the spam check, but not sent into the form
345         (file-author (if (zero? file-rev) "-" (cadar (get-history source-file file-rev 1))))
346         (source (string-translate*
347                  (or (alist-ref 'source postdata)
348                      (handle-exceptions exn ""
349                        (with-input-from-file source-file read-string)))
350                  ;; normalize all EOL styles to Unix line endings
351                  '(("\r\n" . "\n") ("\r" . "\n"))))
352         (sxml (call-with-input-string source svnwiki->sxml))
353         (comment (alist-ref 'comment postdata eq? ""))
354         (username (alist-ref 'username postdata eq? ""))
355         (password (alist-ref 'password postdata eq? ""))
356         (edit-rev (or (string->number
357                        (alist-ref 'edit-rev postdata eq?
358                                   (number->string file-rev))) 0))
359         (make-spam-control-hash
360          (lambda (answer time)
361            (string->sha1sum
362             (sprintf "Answer: ~A for file ~A (r~A by ~A) at ~A"
363                      answer source-file file-rev file-author time))))
364         (auth (or auth-required (alist-ref 'auth postdata)))
365         (title (title-for-wiki-page sxml))
366         ;; If spambot provided auth, it will fail on bad credentials later
367         (likely-human
368          (or auth (and-let* ((hash (alist-ref 'captcha-hash postdata))
369                              (ans (alist-ref 'captcha-answer postdata))
370                              (time (alist-ref 'captcha-time postdata))
371                              ((> (string->number time) ; max half an hour old
372                                  (- (current-seconds) 108000)))
373                              (expected-hash (make-spam-control-hash ans time)))
374                     ;; The hash is unique for this form since this file
375                     ;; will only be changed for this revision once and
376                     ;; the revision/filename combination is unforgeable.
377                     ;; We could use crypt() instead of sha1 for added
378                     ;; security but it hardly seems worth it because the
379                     ;; challenge itself is rather weak...
380                     (string=? hash expected-hash))))
381         ;; TODO: Clean this up, maybe put it in a transformation rule so
382         ;; it can be extended by plugins.  The names of the buttons are
383         ;; pretty much tied to the code though
384         (make-form
385          (lambda (#!optional message)
386            (qwiki-sxml-page-template 
387             `(,(if (alist-ref 'preview postdata)
388                    `(div (@ (class "preview")) (h2 "Preview") ,sxml)
389                    "")
390               ,(if message
391                    `(div (@ class "message") ,message)
392                    "")
393               (form (@ (method "post") (action ""))
394                     (div (@ (id "article"))
395                          (p "You can edit this page using "
396                             (a (@ (href "/edit-help")) "wiki syntax")
397                             " for markup.")
398                          (label "Article contents:"
399                                 (textarea (@ (name "source")
400                                              (rows "20") (cols "72"))
401                                           ,source))
402                          (label "Description of your changes:"
403                                 (textarea (@ (name "comment")
404                                              (rows "2") (cols "72"))
405                                           ,comment))
406                          (input (@ (type "hidden") (name "edit-rev")
407                                    (value ,edit-rev))))
408                     (div (@ (id "auth"))
409                          ,(if auth-required
410                               `(label "This file is " (em "locked.")
411                                       " To edit it, you "
412                                       (em "must authenticate.")
413                                       (input (@ (type "hidden")
414                                                 (name "auth")
415                                                 (value "true"))))
416                               `(label "I would like to authenticate"
417                                       (input (@ (type "checkbox")
418                                                 (name "auth")
419                                                 (id "auth-checkbox")
420                                                 (value "true")
421                                                 . ,(if auth
422                                                        '((checked "checked"))
423                                                        '())))))
424                          (div (@ (id "credentials"))
425                               (h3 "Authentication")
426                               (label "Username:"
427                                      (input (@ (type "text")
428                                                (name "username")
429                                                (value ,username))))
430                               (label "Password:"
431                                      (input (@ (type "password")
432                                                (name "password")
433                                                (value ,password))))))
434                     ,(if auth-required ;; No point in including a spam check
435                          `(div)
436                          (let* ((op (vector-ref
437                                      '#(+ - *)
438                                      (pseudo-random-integer 3)))
439                                 (a (pseudo-random-integer
440                                     (if (eq? op '*) 10 25)))
441                                 (b (pseudo-random-integer
442                                     (if (eq? op '*) 10 25)))
443                                 (res ((case op ((+) +) ((-) -) ((*) *)) a b))
444                                 (time (->string (current-seconds))))
445                           `(div (@ (id "antispam"))
446                                 (h3 "Spam control")
447                                 (p "What do you get when you "
448                                    ,(case op
449                                       ((-) (sprintf " subtract ~A from ~A?" b a))
450                                       ((*) (sprintf " multiply ~A by ~A?" a b))
451                                       ((+) (sprintf " add ~A to ~A?" a b))))
452                                 (input (@ (type "hidden") (name "captcha-time")
453                                           (value ,time)))
454                                 (input (@ (type "hidden") (name "captcha-hash")
455                                           (value ,(make-spam-control-hash
456                                                    res time))))
457                                 (input (@ (type "text") (name "captcha-answer")
458                                           ;; prevent Firefox from pre-filling:
459                                           (value "")))
460                                 ;; Really nasty inline JS, but this keeps
461                                 ;; it lean and mean; no external JS needed.
462                                 (script (@ (type "text/javascript"))
463                                         "var box = document.getElementById('auth-checkbox');"
464                                         "var as = document.getElementById('antispam').style;"
465                                         "var cs = document.getElementById('credentials').style;"
466                                         "if (box.checked)"
467                                         "  as.display = 'none';"
468                                         " else "
469                                         "  cs.display = 'none';"
470                                         "box.onclick = function() {"
471                                         "  if (box.checked) {"
472                                         "    as.display = 'none';"
473                                         "    cs.display = 'block';"
474                                         "  } else {"
475                                         "    as.display = 'block';"
476                                         "    cs.display = 'none';"
477                                         "  }"
478                                         "};"))))
479                     (div (@ (id "actions"))
480                          (input (@ (type "submit")
481                                    (name "save")
482                                    (value "Save")))
483                          (input (@ (type "submit")
484                                    (name "preview")
485                                    (value "Preview"))))))
486             `(title ,(sprintf "Editing page: ~A" (or title (string-join path "/"))))
487             (if (zero? file-rev) '(new-file) '(existing-file))))))
488    (cond
489     ((frozen? source-file) (redirect-to-qwiki-page req)) ; Default action
490     ((blocked-ip-address? (remote-address))
491      (send-content
492       (make-form (conc "You have been blocked from making any edits. "
493                        "If you believe this is in error, please contact "
494                        "the administrators of this wiki."))))
495     ((and (alist-ref 'save postdata) (not (= edit-rev file-rev)))
496      (send-content
497       (make-form (conc "Warning! Someone else has edited this page while you "
498                        "were editing it.  You are blocked from saving this "
499                        "page.  Please review the latest version by clicking "
500                        "\"show\", then click \"edit\" and merge in your "
501                        "changes again.  Sorry for the inconvenience!"))))
502     ((and (alist-ref 'save postdata) (not likely-human))
503      (send-content
504       (make-form (conc "Your answer to the spam control question was "
505                        "incorrect.  Are you a spammer?  Gosh, I hope not! "
506                        "Try again, but please try a little harder!"))))
507     ((alist-ref 'save postdata)
508      (with-output-to-path source-file (lambda () (display source)))
509      (handle-exceptions exn
510        (begin
511          (undo-changes! source-file)
512          ;; No idea how to cleanly ensure a proper update...
513          ;; The enclosing directory might have been removed, or the file
514          ;; might have been deleted, renamed etc.  Let's just update the
515          ;; whole tree (but this can take a long time)
516          (ensure-latest-sources! #t)
517          ;; Different type of race condition
518          (send-content
519           (make-form (conc "Error! Something went wrong while "
520                            "storing your changes."
521                            (if auth
522                                (conc " It is possible your username/password "
523                                      "are incorrect.")
524                                "")
525                            " Please try again.  If this error keeps up, "
526                            "please notify a system administrator about it."))))
527        (store-changes! source-file
528                        (if auth
529                            comment
530                            (sprintf "Anonymous wiki edit for IP [~A]: ~A"
531                                     (remote-address) comment))
532                        (and auth username) (and auth password))
533        (redirect-to-qwiki-page req)))  ; Default action
534     (else (send-content (make-form))))))
535
536(define (->symbol x) (if (symbol? x) x (string->symbol (->string x))))
537
538(define (redirect-to-qwiki-page
539         req #!key (path (uri-path (request-uri req))) action)
540  ;; Default action is "show" and should not appear in generated URIs
541  (let ((action (and action (not (eq? (->symbol action) 'show)) action)))
542    (with-headers `((location
543                     ,(uri-relative-to
544                       (update-uri (uri-reference "")
545                                   path: path
546                                   query: (alist-update!
547                                           'action action
548                                           (or (uri-query (request-uri req))
549                                               '())))
550                       ;; qwiki-base-uri may itself be relative, so resolve
551                       ;; it against the known-to-be-absolute request-uri
552                       (uri-relative-to (qwiki-base-uri) (request-uri req)))))
553      ;; Maybe send a 303?
554      (lambda () (send-status 302 "Found")))))
555
556(define (qwiki-show path req)
557  ;; TODO: What if someone did something else than GET or HEAD?
558  (let* ((html-file (path->html-filename path))
559         (html-path (make-pathname (qwiki-web-path) html-file))
560         (source-file (path->source-filename path)))
561    (cond
562     ((not (file-exists? source-file))
563      (parameterize ((current-response (update-response
564                                        (current-response)
565                                        code: 404 reason: "Not found")))
566        (send-content
567         (qwiki-sxml-page-template
568          `(div (@ (id "missing-page"))
569                (h1 "This page does not exist yet")
570                (p "The page you requested, \"" ,(string-join path "/") "\", "
571                   "does not currently exist. If you want, you can "
572                   (a (@ (rel "nofollow") (href "?action=edit"))
573                      "create this page.")))
574          `(title ,(string-join path "/"))
575          `(new-file)))))
576     ((string->number (alist-ref 'rev (uri-query (request-uri req)) eq? ""))
577      => (lambda (rev) ; Do not cache HTML file if historical rev was requested
578           (send-content
579            (let* ((sxml (call-with-input-revision
580                          source-file rev svnwiki->sxml))
581                   (title (title-for-wiki-page sxml)))
582              (qwiki-sxml-page-template
583               `(div (@ (class "old-revision"))
584                     (p (@ (id "old-revision-message"))
585                        ,(sprintf "You are looking at historical revision ~A of this page. " rev)
586                        "It may differ significantly from its "
587                        (a (@ (href "?action=show")) "current revision."))
588                     ,sxml)
589               `(title ,(sprintf "~A (historical revision ~A)"
590                                 (or title (string-join path "/"))
591                                 rev))
592               `(canonical "?action=show")
593               (if (frozen? source-file) '(read-only) '(read-write)))))))
594     (else (when (or (not (file-exists? html-path))
595                     (file-newer? source-file html-path))
596             (qwiki-update-file! path))
597           (send-static-file html-file)))))
598
599(define (frozen? source-file)
600  (and-let* ((value (get-extended-property source-file "svnwiki:frozen")))
601    (string=? (string-trim-both value) "yes")))
602
603(define (requires-authentication? source-file)
604  (and-let* ((value (get-extended-property source-file "svnwiki:authenticate")))
605    (string=? (string-trim-both value) "yes")))
606
607(define (file-newer? a b)
608  (> (file-modification-time a) (file-modification-time b)))
609
610;; Generate new cached HTML file
611(define (regenerate-html-file! path page)
612  (let* ((html-file (make-pathname (qwiki-web-path) (path->html-filename path)))
613         (title (title-for-wiki-page page)))
614    (with-output-to-path html-file
615      (lambda ()
616        (let ((content (qwiki-sxml-page-template
617                        page
618                        `(title  ,(or title (string-join path "/")))
619                        (if (frozen? (path->source-filename path))
620                            '(read-only)
621                            '(read-write)))))
622          (output-xml content (qwiki-transformation-steps content)))))))
623
624(define (qwiki-update-file! path)
625  (let* ((source-file (path->source-filename path))
626         (page (call-with-input-file source-file 
627                 (lambda (f)
628                   (handle-exceptions exn
629                     (begin (close-input-port f) (signal exn))
630                     (svnwiki->sxml f))))))
631    (parameterize ((qwiki-current-file (string-join path "/")))
632      (for-each (lambda (handler) (handler path page))
633                (append (qwiki-update-handlers) (list regenerate-html-file!))))))
634
635(define (delete-html-file! path)
636  (let ((basename
637         (make-pathname (qwiki-docroot)
638                        (string-join (cons (qwiki-web-path) path) "/"))))
639    (if (and (directory? basename) (not (symbolic-link? basename)))
640        (begin
641          (for-each delete-html-file! (directory basename #t))
642          (delete-directory basename))
643        (delete-file* (string-append basename ".html")))))
644
645;; Destroy all HTML files in the cache
646(define (qwiki-clear-cache!)
647  (find-files (qwiki-web-path)
648              (lambda (f) (string=? (or (pathname-extension f) "") "html"))
649              (lambda (f _) (delete-file* f)) #f
650              (lambda (x) (not (symbolic-link? x)))))
651
652(define (qwiki-delete-file! path)
653  (parameterize ((qwiki-current-file (string-join path "/")))
654    (for-each (lambda (handler) (handler path))
655              (cons delete-html-file! (qwiki-delete-handlers)))))
656
657;;; Request dispatching
658(define qwiki-page-action-handlers
659  (make-parameter
660   `((edit    . ,qwiki-edit)
661     (show    . ,qwiki-show)
662     (diff    . ,qwiki-diff)
663     (history . ,qwiki-history))))
664
665(define qwiki-global-action-handlers
666  (make-parameter (list)))
667
668;; From Spiffy. Maybe export it there?
669;;
670;; Is the file impossible to be requested directly?
671;;
672;; Any file that the the filesystem is incapable of representing is
673;; considered impossible to request.  This includes ".", "..", and
674;; files with a name containing a NUL or a slash; they are all special
675;; files.  Such a request is probably an encoded traversal attack.
676;;
677;; Please note that we disallow backslash even in a UNIX environment,
678;; because core plays fast and loose with slashes and backslashes.
679;; This causes the path "\.." (which strictly speaking is 100%
680;; harmless on UNIX) to be converted to "/..", which opens up a path
681;; traversal bug!  So as a workaround we add the backslash in all
682;; cases.  Because backslashes in filenames are relatively rare,
683;; hopefully this causes no additional problems...  This vulnerability
684;; was found by Benedikt Rosenau with the Netsparker vulnerability
685;; scanner.  In fixed CHICKENs we should deny the backslash only on
686;; Windows.
687(define (impossible-filename? name)
688  (or (string=? name ".") (string=? name "..")
689      (string-index name (char-set #\\ #\/ #\nul))))
690
691(define (ensure-latest-sources! #!optional force?)
692  ;; Not sure if this should be done every freaking time - it's slow!
693  (if force?
694      (update-sources! (qwiki-source-path))
695      (void)))
696
697;; Spiffy handler for requests that should be routed to the wiki
698(define (qwiki-handler continue)
699  (parameterize ((qwiki-web-path (root-path)))
700    (cond
701     ((not (directory-exists? (qwiki-source-path)))
702      (send-status 503 "Missing checkout"
703                   (conc "<p>Checkout not found. Expected it in "
704                         "<code>" (htmlize (qwiki-source-path)) "</code>.<p>"
705                         "<p>To fix this, please run qwiki-install or change "
706                         "the value of <code>qwiki-source-path</code>.</p>")))
707     (else
708      (ensure-latest-sources!)
709      (let ((uri (request-uri (current-request)))
710            (css (qwiki-css-file)))
711        (cond
712         ((and css (equal? (uri-path uri) (uri-path css)))
713          (send-static-file
714           (make-pathname (qwiki-docroot)
715                          (string-join (cdr (uri-path (qwiki-css-file))) "/"))))
716         ((find (lambda (a)
717                  (equal? (uri-path uri) (list '/ (->string (car a)))))
718                (qwiki-global-action-handlers))
719          => (lambda (handler)
720               ((cdr handler) (current-request))))
721         ((any impossible-filename? (cdr (uri-path uri))) ; should be absolute
722          (read-urlencoded-request-data (current-request)) ; Discard possible sent data
723          (send-status 404 "Not found"))
724         (else (let* ((action (->symbol (alist-ref
725                                         'action (uri-query uri) eq? "show")))
726                      (handler (alist-ref action
727                                          (qwiki-page-action-handlers)
728                                          eq? qwiki-show))
729                      (normalized-path (normalize-path (relative-uri-path uri))))
730                 (cond
731                  ((or (rewrite-symlinks normalized-path)
732                       (page-in-intermediate-path normalized-path))
733                   => (lambda (new-path)
734                        (redirect-to-qwiki-page (current-request)
735                                                path: new-path action: action)))
736                  (else (handler normalized-path (current-request))))))))))))
737
738)
Note: See TracBrowser for help on using the repository browser.