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

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

Implement user authentication

File size: 11.0 KB
Line 
1;;
2;; qwiki - the quick wiki
3;;
4;; Copyright (c) 2009 Peter Bex and Ivan Raikov
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 
38   qwiki-source-path 
39   qwiki-base-uri 
40   qwiki-handler
41   qwiki-show
42   qwiki-edit
43   qwiki-history
44   qwiki-render-file
45   qwiki-transformation-steps
46   qwiki-extensions
47   )
48
49(import chicken scheme)
50(use extras files posix ports data-structures srfi-1 srfi-13
51     intarweb uri-common spiffy sxml-transforms
52     wiki-parse qwiki-sxml doctype sxml-fu sxml-shortcuts
53     ;; There should be a way to parameterize the versioning implementation
54     qwiki-svn)
55
56;; HTML files are stored here, relative to the current Spiffy docroot
57(define qwiki-docroot (make-parameter "/"))
58
59;; The location of the wiki source files (where a checkout will be made)
60(define qwiki-source-path (make-parameter "/tmp/qwiki"))
61
62;; The base URI for this wiki
63(define qwiki-base-uri (make-parameter "/" uri-reference))
64 
65;; The rules used for rendering wiki pages (default is HTML)
66(define qwiki-output-driver
67  (make-parameter qwiki-html-transformation-rules))
68
69(define qwiki-extensions
70  (make-parameter (list)))
71
72;; The rules used for transforming page SXML structure
73(define (qwiki-transformation-steps content)
74  (append (qwiki-extensions)
75          ((qwiki-output-driver) content)
76          ))
77
78;; The basic template for SXML wiki pages
79(define (qwiki-sxml-page-template contents . headers)
80   `(wiki-page (Header ,@headers)
81               (body (page-specific-links)
82                     ,contents)))
83
84;; Return the trailing part of the path relative to the docroot/base-uri
85;; eg: If the wiki lives under /qwiki, /qwiki/eggref/4/9p gives /eggref/4/9p
86(define (relative-uri-path uri)
87  ;; Both URIs are assumed to contain absolute paths
88  (let loop ((path (cdr (uri-path uri)))
89             (base-path (cdr (uri-path (qwiki-base-uri)))))
90    (cond
91     ((or (null? base-path) (string-null? (car base-path))) path)
92     ((and (not (null? path))
93           (string=? (car path) (car base-path)))
94      (loop (cdr path) (cdr base-path)))
95     (else (error "Bad request URI path. Please configure qwiki-base-uri.")))))
96
97(define (path->html-filename path)
98  (make-pathname (qwiki-docroot)
99                 (string-join path "/") "html"))
100
101(define (path->source-filename path)
102  (make-pathname (qwiki-source-path) (string-join path "/")))
103
104;; Like with-output-to-file, only this creates parent directories as needed.
105(define (with-output-to-path path thunk)
106  (unless (file-exists? (pathname-directory path))
107    (create-directory (pathname-directory path) #t))
108  (with-output-to-file path thunk))
109
110(define (send-content content)
111  (write-logged-response)
112  (with-output-to-port (response-port (current-response))
113    (lambda ()
114      (output-xml content (qwiki-transformation-steps content))))
115  (close-output-port (response-port (current-response))))
116
117
118
119;;; Actions
120(define (qwiki-history path req)
121  (let* ((source-file (path->source-filename path))
122         (rev (string->number
123               (alist-ref 'rev (uri-query (request-uri req)) eq? "")))
124         (history (get-history source-file rev #f)) ; no pagination yet
125         (content (qwiki-sxml-page-template `(history ,history))))
126    (send-content content)))
127
128(define (qwiki-edit path req)
129  (let* ((html-file (path->html-filename path))
130         (source-file (path->source-filename path))
131         (postdata (if (eq? 'POST (request-method req))
132                       (form-urldecode (read-request-data req))
133                       '()))
134         (source (or (alist-ref 'source postdata)
135                     (and (file-exists? source-file) ;; XXX what if it's a dir?
136                          (with-input-from-file source-file read-string))
137                     ""))
138         (comment (alist-ref 'comment postdata eq? ""))
139         (username (alist-ref 'username postdata eq? ""))
140         (password (alist-ref 'password postdata eq? ""))
141         (auth (alist-ref 'auth postdata eq?))
142         ;; TODO: Clean this up, maybe put it in a transformation rule so
143         ;; it can be extended by plugins.  The names of the buttons are
144         ;; pretty much tied to the code though
145         (content (qwiki-sxml-page-template 
146                   `(
147                     ,(if (alist-ref 'preview postdata)
148                          `(div (@ (class "preview"))
149                                (h2 "Preview")
150                                ,(wiki-parse source))
151                          "")
152                     (p "username: " ,username " password: " ,password " auth: " ,auth)
153                     (form (@ (method "post"))
154                           (label "Article contents:"
155                                  (textarea (@ (name "source"))
156                                            ,source))
157                           (label "Description of your changes:"
158                                  (textarea (@ (name "comment"))
159                                            ,comment))
160                           (label "I would like to authenticate"
161                                  (input (@ (type "checkbox")
162                                            (name "auth")
163                                            ,@(if auth
164                                                  '((checked "checked"))
165                                                  '()))))
166                           (label "Username:"
167                                  (input (@ (type "text")
168                                            (name "username")
169                                            (value ,username))))
170                           (label "Password:"
171                                  (input (@ (type "password")
172                                            (name "password")
173                                            (value ,password))))
174                           (input (@ (type "submit")
175                                     (name "save")
176                                     (value "Save")))
177                           (input (@ (type "submit")
178                                     (name "preview")
179                                     (value "Preview"))))))))
180    (if (alist-ref 'save postdata)
181        (begin
182          (with-output-to-path source-file (lambda () (display source)))
183          (store-changes! source-file comment
184                          (and auth username) (and auth password))
185          (redirect-to-qwiki-page req action: "show"))
186        (send-content content))))
187
188(define (redirect-to-qwiki-page req
189                                #!key
190                                ;; TODO: make path relative to qwiki-base-uri
191                                (path (uri-path (request-uri req)))
192                                (action "show"))
193  (with-headers `((location
194                   ,(update-uri (server-root-uri)
195                                path: path
196                                query: (alist-update!
197                                        'action action
198                                        (or (uri-query (request-uri req))
199                                            '())))))
200    ;; Maybe send a 303?
201    (lambda () (send-status 302 "Found"))))
202
203(define (qwiki-show path req)
204  ;; TODO: What if someone did something else than GET or HEAD?
205  (let* ((html-file (path->html-filename path))
206         (source-file (path->source-filename path))
207         (rev (string->number
208               (alist-ref 'rev (uri-query (request-uri req)) eq? ""))))
209    (if (file-exists? source-file)
210        (if rev
211            (send-content ; Do not store if old rev
212             (qwiki-sxml-page-template
213              (call-with-input-revision
214               source-file rev wiki-parse)))
215            (begin
216             (update-html-file! (make-pathname (root-path) html-file)
217                                source-file)
218             (send-static-file html-file)))
219        (redirect-to-qwiki-page req action: "edit"))))
220
221(define (file-newer? a b)
222  (> (file-modification-time a) (file-modification-time b)))
223
224;; Generate new cached HTML file
225(define (update-html-file! html-file source-file #!optional force-update)
226  (when (or force-update
227            (not (file-exists? html-file))
228            (file-newer? source-file html-file))
229    (with-output-to-path html-file
230      (lambda ()
231        (let ((content (qwiki-sxml-page-template
232                        (call-with-input-file source-file wiki-parse))))
233          (output-xml content (qwiki-transformation-steps content)))))))
234
235;;; Request dispatching
236(define action-handlers
237  `((edit    . ,qwiki-edit)
238    (show    . ,qwiki-show)
239    (history . ,qwiki-history)))
240
241(define (read-request-data req)
242  (let ((len (header-value 'content-length (request-headers req))))
243    ;; If the header is not available, this will read until EOF
244    (read-string len (request-port req))))
245
246;; From Spiffy. Maybe export it there?
247(define (impossible-filename? name)
248  (or (string=? name ".") (string=? name "..") (string-index name #\/)))
249
250(define (ensure-latest-sources!)
251  (if (not (directory-exists? (qwiki-source-path)))
252      (checkout-sources! (qwiki-source-path))
253      ;; Not sure if this should be done every freaking time - it's slow!
254      #;(update-sources! (qwiki-source-path))
255      (void)))
256
257;; Spiffy handler for requests that should be routed to the wiki
258(define (qwiki-handler continue)
259  (ensure-latest-sources!)
260  (let ((uri (request-uri (current-request))))
261    (if (any impossible-filename? (cdr (uri-path uri))) ; assumed to be absolute
262        (begin
263          (read-request-data (current-request))
264          (send-status 404 "Not found"))
265        (let* ((action (string->symbol
266                        (alist-ref 'action (uri-query uri) eq? "show")))
267               (handler (alist-ref action action-handlers eq? qwiki-show)))
268          (handler (relative-uri-path uri) (current-request))))))
269
270(define (qwiki-render-file file)
271  (call-with-input-file file
272    (lambda (input)
273      (let ((content (qwiki-sxml-page-template (wiki-parse input))))
274        (output-xml content (qwiki-transformation-steps content))))))
275
276)
Note: See TracBrowser for help on using the repository browser.