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

Last change on this file since 15374 was 15374, checked in by Ivan Raikov, 12 years ago

created qwiki-sxml-page-template procedure

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