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

Last change on this file since 15351 was 15351, checked in by sjamaan, 11 years ago

Move the SXML rules into their own file, and update them to make complete and correct HTML pages (assuming a complete SXML ruleset for the output of wiki-parse)

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