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

Last change on this file since 15383 was 15383, checked in by Ivan Raikov, 10 years ago

added table of contents functionality to qwiki

File size: 9.4 KB
Line 
1;;
2;; qwiki - the quick wiki
3;;
4;; Copyright (c) 2009 Peter Bex
5;;
6;;  Redistribution and use in source and binary forms, with or without
7;;  modification, are permitted provided that the following conditions
8;;  are met:
9;;
10;;  - Redistributions of source code must retain the above copyright
11;;  notice, this list of conditions and the following disclaimer.
12;;
13;;  - Redistributions in binary form must reproduce the above
14;;  copyright notice, this list of conditions and the following
15;;  disclaimer in the documentation and/or other materials provided
16;;  with the distribution.
17;;
18;;  - Neither name of the copyright holders nor the names of its
19;;  contributors may be used to endorse or promote products derived
20;;  from this software without specific prior written permission.
21;;
22;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE
23;;  CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
24;;  INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
25;;  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
26;;  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE
27;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
28;;  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
29;;  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
30;;  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
31;;  AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
32;;  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
33;;  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
34;;  POSSIBILITY OF SUCH DAMAGE.
35
36(module qwiki
37  (qwiki-docroot 
38   qwiki-source-path 
39   qwiki-base-uri 
40   qwiki-handler
41   qwiki-show
42   qwiki-edit
43   qwiki-history
44   qwiki-render-file
45   qwiki-transformation-steps
46   qwiki-extensions
47   )
48
49(import chicken scheme)
50(use extras files posix ports data-structures srfi-1 srfi-13
51     intarweb uri-common spiffy sxml-transforms
52     wiki-parse qwiki-sxml doctype sxml-fu sxml-shortcuts
53     ;; There should be a way to parameterize the versioning implementation
54     qwiki-svn)
55
56;; HTML files are stored here, relative to the current Spiffy docroot
57(define qwiki-docroot (make-parameter "/"))
58
59;; The location of the wiki source files (where a checkout will be made)
60(define qwiki-source-path (make-parameter "/tmp/qwiki"))
61
62;; The base URI for this wiki
63(define qwiki-base-uri (make-parameter "/" uri-reference))
64 
65;; The rules used for rendering wiki pages (default is HTML)
66(define qwiki-output-driver
67  (make-parameter qwiki-html-transformation-rules))
68
69(define qwiki-extensions
70  (make-parameter (list)))
71
72;; The rules used for transforming page SXML structure
73(define (qwiki-transformation-steps content)
74  (list (append (qwiki-extensions)
75                ((qwiki-output-driver) content)
76                )))
77
78;; The basic template for SXML wiki pages
79(define (qwiki-sxml-page-template contents . headers)
80   `(wiki-page (Header ,@headers)
81               (body (page-specific-links)
82                     ,contents)))
83
84;; Return the trailing part of the path relative to the docroot/base-uri
85;; eg: If the wiki lives under /qwiki, /qwiki/eggref/4/9p gives /eggref/4/9p
86(define (relative-uri-path uri)
87  ;; Both URIs are assumed to contain absolute paths
88  (let loop ((path (cdr (uri-path uri)))
89             (base-path (cdr (uri-path (qwiki-base-uri)))))
90    (cond
91     ((or (null? base-path) (string-null? (car base-path))) path)
92     ((and (not (null? path))
93           (string=? (car path) (car base-path)))
94      (loop (cdr path) (cdr base-path)))
95     (else (error "Bad request URI path. Please configure qwiki-base-uri.")))))
96
97(define (path->html-filename path)
98  (make-pathname (qwiki-docroot)
99                 (string-join path "/") "html"))
100
101(define (path->source-filename path)
102  (make-pathname (qwiki-source-path) (string-join path "/")))
103
104;; Like with-output-to-file, only this creates parent directories as needed.
105(define (with-output-to-path path thunk)
106  (unless (file-exists? (pathname-directory path))
107    (create-directory (pathname-directory path) #t))
108  (with-output-to-file path thunk))
109
110(define (send-content content)
111  (write-logged-response)
112  (with-output-to-port (response-port (current-response))
113    (lambda ()
114      (output-xml content (qwiki-transformation-steps content))))
115  (close-output-port (response-port (current-response))))
116
117
118
119;;; Actions
120(define (qwiki-history path req)
121  (let* ((source-file (path->source-filename path))
122         (rev (string->number
123               (alist-ref 'rev (uri-query (request-uri req)) eq? "")))
124         (history (get-history source-file rev #f)) ; no pagination yet
125         (content (qwiki-sxml-page-template `(history ,history))))
126    (send-content content)))
127
128(define (qwiki-edit path req)
129  (let* ((html-file (path->html-filename path))
130         (source-file (path->source-filename path))
131         (postdata (if (eq? 'POST (request-method req))
132                       (form-urldecode (read-request-data req))
133                       '()))
134         (source (or (alist-ref 'source postdata)
135                     (and (file-exists? source-file) ;; XXX what if it's a dir?
136                          (with-input-from-file source-file read-string))
137                     ""))
138         ;; TODO: Clean this up, maybe put it in a transformation rule so
139         ;; it can be extended by plugins.  The names of the buttons are
140         ;; pretty much tied to the code though
141         (content (qwiki-sxml-page-template 
142                   `(
143                     ,(if (alist-ref 'preview postdata)
144                          `(div (@ (class "preview"))
145                                (h2 "Preview")
146                                ,(wiki-parse source))
147                          "")
148                     (form (@ (method "post"))
149                           (textarea (@ (name "source"))
150                                     ,source)
151                           (input (@ (type "submit")
152                                     (name "save")
153                                     (value "Save")))
154                           (input (@ (type "submit")
155                                     (name "preview")
156                                     (value "Preview"))))))))
157    (if (alist-ref 'save postdata)
158        (begin
159          (with-output-to-path source-file (lambda () (display source)))
160          (redirect-to-qwiki-page req action: "show"))
161        (send-content content))))
162
163(define (redirect-to-qwiki-page req
164                                #!key
165                                ;; TODO: make path relative to qwiki-base-uri
166                                (path (uri-path (request-uri req)))
167                                (action "show"))
168  (with-headers `((location
169                   ,(update-uri (server-root-uri)
170                                path: path
171                                query: (alist-update!
172                                        'action action
173                                        (or (uri-query (request-uri req))
174                                            '())))))
175    ;; Maybe send a 303?
176    (lambda () (send-status 302 "Found"))))
177
178(define (qwiki-show path req)
179  ;; TODO: What if someone did something else than GET or HEAD?
180  (let* ((html-file (path->html-filename path))
181         (source-file (path->source-filename path))
182         (rev (string->number
183               (alist-ref 'rev (uri-query (request-uri req)) eq? ""))))
184    (if (file-exists? source-file)
185        (if rev
186            (send-content ; Do not store if old rev
187             (qwiki-sxml-page-template
188              (call-with-input-revision
189               source-file rev wiki-parse)))
190            (begin
191             (update-html-file! (make-pathname (root-path) html-file)
192                                source-file)
193             (send-static-file html-file)))
194        (redirect-to-qwiki-page req action: "edit"))))
195
196(define (file-newer? a b)
197  (> (file-modification-time a) (file-modification-time b)))
198
199;; Generate new cached HTML file
200(define (update-html-file! html-file source-file #!optional force-update)
201  (when (or force-update
202            (not (file-exists? html-file))
203            (file-newer? source-file html-file))
204    (with-output-to-path html-file
205      (lambda ()
206        (let ((content (qwiki-sxml-page-template
207                        (call-with-input-file source-file wiki-parse))))
208          (output-xml content (qwiki-transformation-steps content)))))))
209
210;;; Request dispatching
211(define action-handlers
212  `((edit    . ,qwiki-edit)
213    (show    . ,qwiki-show)
214    (history . ,qwiki-history)))
215
216(define (read-request-data req)
217  (let ((len (header-value 'content-length (request-headers req))))
218    ;; If the header is not available, this will read until EOF
219    (read-string len (request-port req))))
220
221;; From Spiffy. Maybe export it there?
222(define (impossible-filename? name)
223  (or (string=? name ".") (string=? name "..") (string-index name #\/)))
224
225(define (ensure-latest-sources!)
226  (if (not (directory-exists? (qwiki-source-path)))
227      (checkout-sources! (qwiki-source-path))
228      ;; Not sure if this should be done every freaking time - it's slow!
229      #;(update-sources! (qwiki-source-path))
230      (void)))
231
232;; Spiffy handler for requests that should be routed to the wiki
233(define (qwiki-handler continue)
234  (ensure-latest-sources!)
235  (let ((uri (request-uri (current-request))))
236    (if (any impossible-filename? (cdr (uri-path uri))) ; assumed to be absolute
237        (begin
238          (read-request-data (current-request))
239          (send-status 404 "Not found"))
240        (let* ((action (string->symbol
241                        (alist-ref 'action (uri-query uri) eq? "show")))
242               (handler (alist-ref action action-handlers eq? qwiki-show)))
243          (handler (relative-uri-path uri) (current-request))))))
244
245(define (qwiki-render-file file)
246  (call-with-input-file file
247    (lambda (input)
248      (let ((content (qwiki-sxml-page-template (wiki-parse input))))
249        (output-xml content (qwiki-transformation-steps content))))))
250
251)
Note: See TracBrowser for help on using the repository browser.