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

Last change on this file since 15373 was 15373, checked in by Ivan Raikov, 11 years ago

some more modifications to content rendering in qwiki

File size: 9.2 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   )
47
48(import chicken scheme)
49(use extras files posix ports data-structures srfi-1 srfi-13
50     intarweb uri-common spiffy sxml-transforms
51     wiki-parse qwiki-sxml doctype sxml-fu sxml-shortcuts
52     ;; There should be a way to parameterize the versioning implementation
53     qwiki-svn)
54
55;; HTML files are stored here, relative to the current Spiffy docroot
56(define qwiki-docroot (make-parameter "/"))
57
58;; The location of the wiki source files (where a checkout will be made)
59(define qwiki-source-path (make-parameter "/tmp/qwiki"))
60
61;; The base URI for this wiki
62(define qwiki-base-uri (make-parameter "/" uri-reference))
63
64;; The rules used for rendering wiki pages (default is HTML)
65(define qwiki-output-driver
66  (make-parameter qwiki-html-transformation-rules))
67
68(define qwiki-extensions
69  (make-parameter (list)))
70
71;; The rules used for transforming page SXML structure
72(define (qwiki-transformation-steps)
73  (list (append (qwiki-extensions)
74                (qwiki-output-driver)
75                )))
76
77;; Return the trailing part of the path relative to the docroot/base-uri
78;; eg: If the wiki lives under /qwiki, /qwiki/eggref/4/9p gives /eggref/4/9p
79(define (relative-uri-path uri)
80  ;; Both URIs are assumed to contain absolute paths
81  (let loop ((path (cdr (uri-path uri)))
82             (base-path (cdr (uri-path (qwiki-base-uri)))))
83    (cond
84     ((or (null? base-path) (string-null? (car base-path))) path)
85     ((and (not (null? path))
86           (string=? (car path) (car base-path)))
87      (loop (cdr path) (cdr base-path)))
88     (else (error "Bad request URI path. Please configure qwiki-base-uri.")))))
89
90(define (path->html-filename path)
91  (make-pathname (qwiki-docroot)
92                 (string-join path "/") "html"))
93
94(define (path->source-filename path)
95  (make-pathname (qwiki-source-path) (string-join path "/")))
96
97;; Like with-output-to-file, only this creates parent directories as needed.
98(define (with-output-to-path path thunk)
99  (unless (file-exists? (pathname-directory path))
100    (create-directory (pathname-directory path) #t))
101  (with-output-to-file path thunk))
102
103(define (send-content content)
104  (write-logged-response)
105  (with-output-to-port (response-port (current-response))
106    (lambda ()
107      (output-xml content (qwiki-transformation-steps))))
108  (close-output-port (response-port (current-response))))
109
110
111
112;;; Actions
113(define (qwiki-history path req)
114  (let* ((source-file (path->source-filename path))
115         (rev (string->number
116               (alist-ref 'rev (uri-query (request-uri req)) eq? "")))
117         (history (get-history source-file rev #f)) ; no pagination yet
118         (content `(wiki-page (Header) (body (history ,history)))))
119    (send-content content)))
120
121(define (qwiki-edit path req)
122  (let* ((html-file (path->html-filename path))
123         (source-file (path->source-filename path))
124         (postdata (if (eq? 'POST (request-method req))
125                       (form-urldecode (read-request-data req))
126                       '()))
127         (source (or (alist-ref 'source postdata)
128                     (and (file-exists? source-file) ;; XXX what if it's a dir?
129                          (with-input-from-file source-file read-string))
130                     ""))
131         ;; TODO: Clean this up, maybe put it in a transformation rule so
132         ;; it can be extended by plugins.  The names of the buttons are
133         ;; pretty much tied to the code though
134         (content `(wiki-page 
135                    (Header)
136                    (body
137                     ,(if (alist-ref 'preview postdata)
138                          `(div (@ (class "preview"))
139                                (h2 "Preview")
140                                ,(wiki-parse source))
141                          "")
142                     (form (@ (method "post"))
143                           (textarea (@ (name "source"))
144                                     ,source)
145                           (input (@ (type "submit")
146                                     (name "save")
147                                     (value "Save")))
148                           (input (@ (type "submit")
149                                     (name "preview")
150                                     (value "Preview"))))))))
151    (if (alist-ref 'save postdata)
152        (begin
153          (with-output-to-path source-file (lambda () (display source)))
154          (redirect-to-qwiki-page req action: "show"))
155        (send-content content))))
156
157(define (redirect-to-qwiki-page req
158                                #!key
159                                ;; TODO: make path relative to qwiki-base-uri
160                                (path (uri-path (request-uri req)))
161                                (action "show"))
162  (with-headers `((location
163                   ,(update-uri (server-root-uri)
164                                path: path
165                                query: (alist-update!
166                                        'action action
167                                        (or (uri-query (request-uri req))
168                                            '())))))
169    ;; Maybe send a 303?
170    (lambda () (send-status 302 "Found"))))
171
172(define (qwiki-show path req)
173  ;; TODO: What if someone did something else than GET or HEAD?
174  (let* ((html-file (path->html-filename path))
175         (source-file (path->source-filename path))
176         (rev (string->number
177               (alist-ref 'rev (uri-query (request-uri req)) eq? ""))))
178    (if (file-exists? source-file)
179        (if rev
180            (send-content ; Do not store if old rev
181             `(wiki-page (Header)
182                         (body 
183                          ,(call-with-input-revision
184                            source-file rev wiki-parse))))
185            (begin
186             (update-html-file! (make-pathname (root-path) html-file)
187                                source-file)
188             (send-static-file html-file)))
189        (redirect-to-qwiki-page req action: "edit"))))
190
191(define (file-newer? a b)
192  (> (file-modification-time a) (file-modification-time b)))
193
194;; Generate new cached HTML file
195(define (update-html-file! html-file source-file #!optional force-update)
196  (when (or force-update
197            (not (file-exists? html-file))
198            (file-newer? source-file html-file))
199    (with-output-to-path html-file
200      (lambda ()
201        (let ((content `(wiki-page 
202                         (Header)
203                         (body 
204                          ,(call-with-input-file source-file wiki-parse)))))
205          (output-xml content (qwiki-transformation-steps)))))))
206
207;;; Request dispatching
208(define action-handlers
209  `((edit    . ,qwiki-edit)
210    (show    . ,qwiki-show)
211    (history . ,qwiki-history)))
212
213(define (read-request-data req)
214  (let ((len (header-value 'content-length (request-headers req))))
215    ;; If the header is not available, this will read until EOF
216    (read-string len (request-port req))))
217
218;; From Spiffy. Maybe export it there?
219(define (impossible-filename? name)
220  (or (string=? name ".") (string=? name "..") (string-index name #\/)))
221
222(define (ensure-latest-sources!)
223  (if (not (directory-exists? (qwiki-source-path)))
224      (checkout-sources! (qwiki-source-path))
225      ;; Not sure if this should be done every freaking time - it's slow!
226      #;(update-sources! (qwiki-source-path))
227      (void)))
228
229;; Spiffy handler for requests that should be routed to the wiki
230(define (qwiki-handler continue)
231  (ensure-latest-sources!)
232  (let ((uri (request-uri (current-request))))
233    (if (any impossible-filename? (cdr (uri-path uri))) ; assumed to be absolute
234        (begin
235          (read-request-data (current-request))
236          (send-status 404 "Not found"))
237        (let* ((action (string->symbol
238                        (alist-ref 'action (uri-query uri) eq? "show")))
239               (handler (alist-ref action action-handlers eq? qwiki-show)))
240          (handler (relative-uri-path uri) (current-request))))))
241
242(define (qwiki-render-file file)
243  (call-with-input-file file
244    (lambda (input)
245      (let ((content `(wiki-page (Header) (body ,(wiki-parse input)))))
246        (output-xml content (qwiki-transformation-steps))))))
247
248)
Note: See TracBrowser for help on using the repository browser.