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

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

Add history viewing functionality

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 10))
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.