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

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

Split out subversion implementation to make it easier to plug in something else

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-basic-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.