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

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

additions to the sxml rendering parts of qwiki

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