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

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

Do not limit the number of history entries because there's no way to paginate them(?)

File size: 10.9 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 regex files ports posix data-structures srfi-1 srfi-13 srfi-18
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;; Get the history for a given file starting at rev, going back in
95;; time.  If rev is #f, start at the latest revision.  If limit is not
96;; specified or #f, the full history is returned.  Otherwise, a
97;; maximum of that many items is returned.
98(define (get-history file rev #!optional limit)
99  (let ((history '()))
100   (svn-client-log2
101    file (if rev (make-svn-opt-revision-number rev) svn-opt-revision-head)
102    (make-svn-opt-revision-number 0) (or limit 0) #f #f
103    (qwiki-repos-username) (qwiki-repos-password)
104    (lambda (files rev author date msg)
105      ;; What about the timezone?  Is it always GMT?  POSIX strptime
106      ;; doesn't know about this so we may need to use srfi-19...
107      (let* ((seconds-date (string-substitute "\\.[0-9]+.*" "" date))
108             (date (string->time date "%Y-%m-%dT%H:%M")))
109       (set! history (cons (list rev author date msg) history)))))
110   (reverse history)))
111
112(define (call-with-input-revision file rev proc)
113  (let ((filename (svn-client-cat
114                   file (make-svn-opt-revision-number rev)
115                   (qwiki-repos-username) (qwiki-repos-password))))
116    (handle-exceptions exn
117      (begin
118        (delete-file* filename)
119        (raise exn))
120     (let ((result (call-with-input-file filename proc)))
121       (delete-file* filename)
122       result))))
123
124(define (send-content content)
125  (write-logged-response)
126  (with-output-to-port (response-port (current-response))
127    (lambda ()
128      (output-xml content (qwiki-transformation-steps))))
129  (close-output-port (response-port (current-response))))
130
131;;; Actions
132(define (qwiki-history path req)
133  (let* ((source-file (path->source-filename path))
134         (rev (string->number
135               (alist-ref 'rev (uri-query (request-uri req)) eq? "")))
136         (history (get-history source-file rev #f)) ; no pagination yet
137         (content `(page (history ,history))))
138    (send-content content)))
139
140(define (qwiki-edit path req)
141  (let* ((html-file (path->html-filename path))
142         (source-file (path->source-filename path))
143         (postdata (if (eq? 'POST (request-method req))
144                       (form-urldecode (read-request-data req))
145                       '()))
146         (source (or (alist-ref 'source postdata)
147                     (and (file-exists? source-file) ;; XXX what if it's a dir?
148                          (with-input-from-file source-file read-string))
149                     ""))
150         ;; TODO: Clean this up, maybe put it in a transformation rule so
151         ;; it can be extended by plugins.  The names of the buttons are
152         ;; pretty much tied to the code though
153         (content `(wiki-page
154                    ,(if (alist-ref 'preview postdata)
155                         `(div (@ (class "preview"))
156                               (h2 "Preview")
157                               ,(wiki-parse source))
158                         "")
159                    (form (@ (method "post"))
160                          (textarea (@ (name "source"))
161                                    ,source)
162                          (input (@ (type "submit")
163                                    (name "save")
164                                    (value "Save")))
165                          (input (@ (type "submit")
166                                    (name "preview")
167                                    (value "Preview")))))))
168    (if (alist-ref 'save postdata)
169        (begin
170          (with-output-to-path source-file (lambda () (display source)))
171          (redirect-to-qwiki-page req action: "show"))
172        (send-content content))))
173
174(define (redirect-to-qwiki-page req
175                                #!key
176                                ;; TODO: make path relative to qwiki-base-uri
177                                (path (uri-path (request-uri req)))
178                                (action "show"))
179  (with-headers `((location
180                   ,(update-uri (server-root-uri)
181                                path: path
182                                query: (alist-update!
183                                        'action action
184                                        (or (uri-query (request-uri req))
185                                            '())))))
186    ;; Maybe send a 303?
187    (lambda () (send-status 302 "Found"))))
188
189(define (qwiki-show path req)
190  ;; TODO: What if someone did something else than GET or HEAD?
191  (let* ((html-file (path->html-filename path))
192         (source-file (path->source-filename path))
193         (rev (string->number
194               (alist-ref 'rev (uri-query (request-uri req)) eq? ""))))
195    (if (file-exists? source-file)
196        (if rev
197            (send-content ; Do not store if old rev
198             `(wiki-page ,(call-with-input-revision
199                           source-file rev wiki-parse)))
200            (begin
201             (update-html-file! (make-pathname (root-path) html-file)
202                                source-file)
203             (send-static-file html-file)))
204        (redirect-to-qwiki-page req action: "edit"))))
205
206(define (file-newer? a b)
207  (> (file-modification-time a) (file-modification-time b)))
208
209;; Generate new cached HTML file
210(define (update-html-file! html-file source-file #!optional force-update)
211  (when (or force-update
212            (not (file-exists? html-file))
213            (file-newer? source-file html-file))
214    (with-output-to-path html-file
215      (lambda ()
216        (let ((content `(wiki-page
217                         ,(call-with-input-file source-file wiki-parse))))
218          (output-xml content (qwiki-transformation-steps)))))))
219
220;;; Request dispatching
221(define action-handlers
222  `((edit    . ,qwiki-edit)
223    (show    . ,qwiki-show)
224    (history . ,qwiki-history)))
225
226(define (read-request-data req)
227  (let ((len (header-value 'content-length (request-headers req))))
228    ;; If the header is not available, this will read until EOF
229    (read-string len (request-port req))))
230
231;; From Spiffy. Maybe export it there?
232(define (impossible-filename? name)
233  (or (string=? name ".") (string=? name "..") (string-index name #\/)))
234
235(define (checkout-sources!)
236  (svn-update (qwiki-repos-uri) (qwiki-source-path) svn-opt-revision-head
237              (qwiki-repos-username) (qwiki-repos-password)))
238
239(define (update-sources!)
240  (svn-update (qwiki-repos-uri) (qwiki-source-path) svn-opt-revision-head
241              (qwiki-repos-username) (qwiki-repos-password)))
242
243(define (ensure-latest-sources!)
244  (if (not (directory-exists? (qwiki-source-path)))
245      (checkout-sources!)
246      ;; Not sure if this should be done every freaking time - it's slow!
247      #;(update-sources!)
248      (void)))
249
250;; Spiffy handler for requests that should be routed to the wiki
251(define (qwiki-handler continue)
252  (ensure-latest-sources!)
253  (let ((uri (request-uri (current-request))))
254    (if (any impossible-filename? (cdr (uri-path uri))) ; assumed to be absolute
255        (begin
256          (read-request-data (current-request))
257          (send-status 404 "Not found"))
258        (let* ((action (string->symbol
259                        (alist-ref 'action (uri-query uri) eq? "show")))
260               (handler (alist-ref action action-handlers eq? qwiki-show)))
261          (handler (relative-uri-path uri) (current-request))))))
262
263)
Note: See TracBrowser for help on using the repository browser.