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

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

Add initial really quick 'n dirty qwiki implementation

File size: 8.8 KB
Line 
1;;
2;; qwiki - the quick wiki
3;;
4;; Copyright 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
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     wiki-parse intarweb uri-common spiffy sxml-transforms svn-client)
44
45;; HTML files are stored here, relative to the current Spiffy docroot
46(define qwiki-docroot (make-parameter "/"))
47
48;; The version control system's repos uri, username and password
49;; TODO: Move this elsewhere
50(define qwiki-repos-uri (make-parameter #f)) ; string, not uri-reference!
51(define qwiki-repos-username (make-parameter "anonymous"))
52(define qwiki-repos-password (make-parameter ""))
53
54;; The location of the wiki source files (where a checkout will be made)
55(define qwiki-source-path (make-parameter "/tmp/qwiki"))
56
57;; The base URI for this wiki
58(define qwiki-base-uri (make-parameter "/" uri-reference))
59
60;; TODO: Make this use some kind of wiki-html-transformations, which
61;; should end up in their own egg for reusability
62(define qwiki-transformation-rules (make-parameter universal-conversion-rules))
63
64;; Return the trailing part of the path relative to the docroot/base-uri
65;; eg: If the wiki lives under /qwiki, /qwiki/eggref/4/9p gives /eggref/4/9p
66(define (relative-uri-path uri)
67  ;; Both URIs are assumed to contain absolute paths
68  (let loop ((path (cdr (uri-path uri)))
69             (base-path (cdr (uri-path (qwiki-base-uri)))))
70    (cond
71     ((or (null? base-path) (string-null? (car base-path))) path)
72     ((and (not (null? path))
73           (string=? (car path) (car base-path)))
74      (loop (cdr path) (cdr base-path)))
75     (else (error "Bad request URI path. Please configure qwiki-base-uri.")))))
76
77(define (path->html-filename path)
78  (make-pathname (qwiki-docroot)
79                 (string-join path "/") "html"))
80
81(define (path->source-filename path)
82  (make-pathname (qwiki-source-path) (string-join path "/")))
83
84;; Like with-output-to-file, only this creates parent directories as needed.
85(define (with-output-to-path path thunk)
86  (unless (file-exists? (pathname-directory path))
87    (create-directory (pathname-directory path) #t))
88  (with-output-to-file path thunk))
89
90;;; Actions
91(define (qwiki-history path req)
92  (send-status 404 "Not found")) ;; TODO
93
94(define (qwiki-edit path req)
95  (let* ((html-file (path->html-filename path))
96         (source-file (path->source-filename path))
97         (postdata (if (eq? 'POST (request-method req))
98                       (form-urldecode (read-request-data req))
99                       '()))
100         (source (or (alist-ref 'source postdata)
101                     (with-input-from-file source-file read-string)))
102         ;; TODO: Clean this up, maybe put it in a transformation rule so
103         ;; it can be extended by plugins.  The names of the buttons are
104         ;; pretty much tied to the code though
105         (content `(page
106                    ,(if (alist-ref 'preview postdata)
107                         `(div (@ (class "preview"))
108                               (h2 "Preview")
109                               ,(wiki-parse source))
110                         "")
111                    (form (@ (method "post"))
112                          (textarea (@ (name "source"))
113                                    ,source)
114                          (input (@ (type "submit")
115                                    (name "save")
116                                    (value "Save")))
117                          (input (@ (type "submit")
118                                    (name "preview")
119                                    (value "Preview")))))))
120    (if (alist-ref 'save postdata)
121        (begin
122          (with-output-to-path source-file (lambda () (display source)))
123          (redirect-to-qwiki-page req action: "show"))
124        (begin
125          (write-logged-response)
126          (with-output-to-port (response-port (current-response))
127            (lambda ()
128             (SRV:send-reply
129              (pre-post-order content (qwiki-transformation-rules)))))))))
130
131(define (redirect-to-qwiki-page req
132                                #!key
133                                ;; TODO: make path relative to qwiki-base-uri
134                                (path (uri-path (request-uri req)))
135                                (action "show"))
136  (with-headers `((location
137                   ,(update-uri (server-root-uri)
138                                path: path
139                                query: (alist-update!
140                                        'action action
141                                        (or (uri-query (request-uri req))
142                                            '())))))
143    ;; Maybe send a 303?
144    (lambda () (send-status 302 "Found"))))
145
146(define (qwiki-show path req)
147  ;; TODO: What if someone did something else than GET or HEAD?
148  (let* ((html-file (path->html-filename path))
149         (source-file (path->source-filename path)))
150    (if (file-exists? source-file)
151        (begin
152          (update-html-file! (make-pathname (root-path) html-file) source-file)
153          (send-static-file html-file))
154        (redirect-to-qwiki-page req action: "edit"))))
155
156(define (file-newer? a b)
157  (> (file-modification-time a) (file-modification-time b)))
158
159;; Generate new cached HTML file
160(define (update-html-file! html-file source-file #!optional force-update)
161  (when (or force-update
162            (not (file-exists? html-file))
163            (file-newer? source-file html-file))
164    (with-output-to-path html-file
165      (lambda ()
166        (let ((content `(page
167                         ,(call-with-input-file source-file wiki-parse))))
168          (SRV:send-reply
169           (pre-post-order content (qwiki-transformation-rules))))))))
170
171;;; Request dispatching
172(define action-handlers
173  `((edit    . ,qwiki-edit)
174    (show    . ,qwiki-show)
175    (history . ,qwiki-history)))
176
177(define (read-request-data req)
178  (let ((len (header-value 'content-length (request-headers req))))
179    ;; If the header is not available, this will read until EOF
180    (read-string len (request-port req))))
181
182;; From Spiffy. Maybe export it there?
183(define (impossible-filename? name)
184  (or (string=? name ".") (string=? name "..") (string-index name #\/)))
185
186(define (checkout-sources!)
187  (svn-update (qwiki-repos-uri) (qwiki-source-path) svn-opt-revision-head
188              (qwiki-repos-username) (qwiki-repos-password)))
189
190(define (update-sources!)
191  (svn-update (qwiki-repos-uri) (qwiki-source-path) svn-opt-revision-head
192              (qwiki-repos-username) (qwiki-repos-password)))
193
194(define (ensure-latest-sources!)
195  (if (not (directory-exists? (qwiki-source-path)))
196      (checkout-sources!)
197      ;; Not sure if this should be done every freaking time - it's slow!
198      #;(update-sources!)
199      (void)))
200
201;; Spiffy handler for requests that should be routed to the wiki
202(define (qwiki-handler continue)
203  (ensure-latest-sources!)
204  (let ((uri (request-uri (current-request))))
205    (if (any impossible-filename? (cdr (uri-path uri))) ; assumed to be absolute
206        (begin
207          (read-request-data (current-request))
208          (send-status 404 "Not found"))
209        (let* ((action (string->symbol
210                        (alist-ref 'action (uri-query uri) eq? "show")))
211               (handler (alist-ref action action-handlers eq? qwiki-show)))
212          (handler (relative-uri-path uri) (current-request))))))
213
214)
Note: See TracBrowser for help on using the repository browser.