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

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

Update to use latest sxml-fu version

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 qwiki-transformation-steps
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 doctype sxml-fu sxml-shortcuts)
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;; The rules used for transforming page SXML structure into HTML
62(define qwiki-transformation-steps
63  (make-parameter
64   (list qwiki-basic-transformation-rules
65         shortcut-rules
66         (append doctype-rules universal-conversion-rules))))
67
68;; Return the trailing part of the path relative to the docroot/base-uri
69;; eg: If the wiki lives under /qwiki, /qwiki/eggref/4/9p gives /eggref/4/9p
70(define (relative-uri-path uri)
71  ;; Both URIs are assumed to contain absolute paths
72  (let loop ((path (cdr (uri-path uri)))
73             (base-path (cdr (uri-path (qwiki-base-uri)))))
74    (cond
75     ((or (null? base-path) (string-null? (car base-path))) path)
76     ((and (not (null? path))
77           (string=? (car path) (car base-path)))
78      (loop (cdr path) (cdr base-path)))
79     (else (error "Bad request URI path. Please configure qwiki-base-uri.")))))
80
81(define (path->html-filename path)
82  (make-pathname (qwiki-docroot)
83                 (string-join path "/") "html"))
84
85(define (path->source-filename path)
86  (make-pathname (qwiki-source-path) (string-join path "/")))
87
88;; Like with-output-to-file, only this creates parent directories as needed.
89(define (with-output-to-path path thunk)
90  (unless (file-exists? (pathname-directory path))
91    (create-directory (pathname-directory path) #t))
92  (with-output-to-file path thunk))
93
94;;; Actions
95(define (qwiki-history path req)
96  (send-status 404 "Not found")) ;; TODO
97
98(define (qwiki-edit path req)
99  (let* ((html-file (path->html-filename path))
100         (source-file (path->source-filename path))
101         (postdata (if (eq? 'POST (request-method req))
102                       (form-urldecode (read-request-data req))
103                       '()))
104         (source (or (alist-ref 'source postdata)
105                     (and (file-exists? source-file) ;; XXX what if it's a dir?
106                          (with-input-from-file source-file read-string))
107                     ""))
108         ;; TODO: Clean this up, maybe put it in a transformation rule so
109         ;; it can be extended by plugins.  The names of the buttons are
110         ;; pretty much tied to the code though
111         (content `(wiki-page
112                    ,(if (alist-ref 'preview postdata)
113                         `(div (@ (class "preview"))
114                               (h2 "Preview")
115                               ,(wiki-parse source))
116                         "")
117                    (form (@ (method "post"))
118                          (textarea (@ (name "source"))
119                                    ,source)
120                          (input (@ (type "submit")
121                                    (name "save")
122                                    (value "Save")))
123                          (input (@ (type "submit")
124                                    (name "preview")
125                                    (value "Preview")))))))
126    (if (alist-ref 'save postdata)
127        (begin
128          (with-output-to-path source-file (lambda () (display source)))
129          (redirect-to-qwiki-page req action: "show"))
130        (begin
131          (write-logged-response)
132          (with-output-to-port (response-port (current-response))
133            (lambda ()
134              (output-xml content (qwiki-transformation-steps))))))))
135
136(define (redirect-to-qwiki-page req
137                                #!key
138                                ;; TODO: make path relative to qwiki-base-uri
139                                (path (uri-path (request-uri req)))
140                                (action "show"))
141  (with-headers `((location
142                   ,(update-uri (server-root-uri)
143                                path: path
144                                query: (alist-update!
145                                        'action action
146                                        (or (uri-query (request-uri req))
147                                            '())))))
148    ;; Maybe send a 303?
149    (lambda () (send-status 302 "Found"))))
150
151(define (qwiki-show path req)
152  ;; TODO: What if someone did something else than GET or HEAD?
153  (let* ((html-file (path->html-filename path))
154         (source-file (path->source-filename path)))
155    (if (file-exists? source-file)
156        (begin
157          (update-html-file! (make-pathname (root-path) html-file) source-file)
158          (send-static-file html-file))
159        (redirect-to-qwiki-page req action: "edit"))))
160
161(define (file-newer? a b)
162  (> (file-modification-time a) (file-modification-time b)))
163
164;; Generate new cached HTML file
165(define (update-html-file! html-file source-file #!optional force-update)
166  (when (or force-update
167            (not (file-exists? html-file))
168            (file-newer? source-file html-file))
169    (with-output-to-path html-file
170      (lambda ()
171        (let ((content `(wiki-page
172                         ,(call-with-input-file source-file wiki-parse))))
173          (output-xml content (qwiki-transformation-steps)))))))
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.