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

;; 
;; qwiki - the quick wiki
;; 
;; Copyright (c) 2009 Peter Bex and Ivan Raikov
;;
;;  Redistribution and use in source and binary forms, with or without
;;  modification, are permitted provided that the following conditions
;;  are met:
;; 
;;  - Redistributions of source code must retain the above copyright
;;  notice, this list of conditions and the following disclaimer.
;; 
;;  - Redistributions in binary form must reproduce the above
;;  copyright notice, this list of conditions and the following
;;  disclaimer in the documentation and/or other materials provided
;;  with the distribution.
;; 
;;  - Neither name of the copyright holders nor the names of its
;;  contributors may be used to endorse or promote products derived
;;  from this software without specific prior written permission.
;; 
;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE
;;  CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
;;  INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
;;  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;;  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE
;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;;  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
;;  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
;;  AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
;;  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
;;  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;  POSSIBILITY OF SUCH DAMAGE.

(module qwiki
  (qwiki-docroot 
   qwiki-source-path 
   qwiki-base-uri 
   qwiki-handler
   qwiki-show
   qwiki-edit
   qwiki-history
   qwiki-render-file
   qwiki-transformation-steps
   qwiki-extensions
   )

(import chicken scheme)
(use extras files posix ports data-structures srfi-1 srfi-13
     intarweb uri-common spiffy sxml-transforms
     wiki-parse qwiki-sxml doctype sxml-fu sxml-shortcuts
     ;; There should be a way to parameterize the versioning implementation
     qwiki-svn)

;; HTML files are stored here, relative to the current Spiffy docroot
(define qwiki-docroot (make-parameter "/"))

;; The location of the wiki source files (where a checkout will be made)
(define qwiki-source-path (make-parameter "/tmp/qwiki"))

;; The base URI for this wiki
(define qwiki-base-uri (make-parameter "/" uri-reference))
  
;; The rules used for rendering wiki pages (default is HTML)
(define qwiki-output-driver
  (make-parameter qwiki-html-transformation-rules))

(define qwiki-extensions
  (make-parameter (list)))

;; The rules used for transforming page SXML structure
(define (qwiki-transformation-steps content)
  (append (qwiki-extensions)
          ((qwiki-output-driver) content)
          ))

;; The basic template for SXML wiki pages
(define (qwiki-sxml-page-template contents . headers)
   `(wiki-page (Header ,@headers)
               (body (page-specific-links)
                     ,contents)))

;; Return the trailing part of the path relative to the docroot/base-uri
;; eg: If the wiki lives under /qwiki, /qwiki/eggref/4/9p gives /eggref/4/9p
(define (relative-uri-path uri)
  ;; Both URIs are assumed to contain absolute paths
  (let loop ((path (cdr (uri-path uri)))
             (base-path (cdr (uri-path (qwiki-base-uri)))))
    (cond
     ((or (null? base-path) (string-null? (car base-path))) path)
     ((and (not (null? path))
           (string=? (car path) (car base-path)))
      (loop (cdr path) (cdr base-path)))
     (else (error "Bad request URI path. Please configure qwiki-base-uri.")))))

(define (path->html-filename path)
  (make-pathname (qwiki-docroot)
                 (string-join path "/") "html"))

(define (path->source-filename path)
  (make-pathname (qwiki-source-path) (string-join path "/")))

;; Like with-output-to-file, only this creates parent directories as needed.
(define (with-output-to-path path thunk)
  (unless (file-exists? (pathname-directory path))
    (create-directory (pathname-directory path) #t))
  (with-output-to-file path thunk))

(define (send-content content)
  (write-logged-response)
  (with-output-to-port (response-port (current-response))
    (lambda ()
      (output-xml content (qwiki-transformation-steps content))))
  (close-output-port (response-port (current-response))))



;;; Actions
(define (qwiki-history path req)
  (let* ((source-file (path->source-filename path))
         (rev (string->number
               (alist-ref 'rev (uri-query (request-uri req)) eq? "")))
         (history (get-history source-file rev #f)) ; no pagination yet
         (content (qwiki-sxml-page-template `(history ,history))))
    (send-content content)))

(define (qwiki-edit path req)
  (let* ((html-file (path->html-filename path))
         (source-file (path->source-filename path))
         (postdata (if (eq? 'POST (request-method req))
                       (form-urldecode (read-request-data req))
                       '()))
         (source (or (alist-ref 'source postdata)
                     (and (file-exists? source-file) ;; XXX what if it's a dir?
                          (with-input-from-file source-file read-string))
                     ""))
         (comment (alist-ref 'comment postdata eq? ""))
         (username (alist-ref 'username postdata eq? ""))
         (password (alist-ref 'password postdata eq? ""))
         (auth (alist-ref 'auth postdata eq?))
         ;; TODO: Clean this up, maybe put it in a transformation rule so
         ;; it can be extended by plugins.  The names of the buttons are
         ;; pretty much tied to the code though
         (content (qwiki-sxml-page-template 
                   `(
                     ,(if (alist-ref 'preview postdata)
                          `(div (@ (class "preview"))
                                (h2 "Preview")
                                ,(wiki-parse source))
                          "")
                     (p "username: " ,username " password: " ,password " auth: " ,auth)
                     (form (@ (method "post"))
                           (label "Article contents:"
                                  (textarea (@ (name "source"))
                                            ,source))
                           (label "Description of your changes:"
                                  (textarea (@ (name "comment"))
                                            ,comment))
                           (label "I would like to authenticate"
                                  (input (@ (type "checkbox")
                                            (name "auth")
                                            ,@(if auth
                                                  '((checked "checked"))
                                                  '()))))
                           (label "Username:"
                                  (input (@ (type "text")
                                            (name "username")
                                            (value ,username))))
                           (label "Password:"
                                  (input (@ (type "password")
                                            (name "password")
                                            (value ,password))))
                           (input (@ (type "submit")
                                     (name "save")
                                     (value "Save")))
                           (input (@ (type "submit")
                                     (name "preview")
                                     (value "Preview"))))))))
    (if (alist-ref 'save postdata)
        (begin
          (with-output-to-path source-file (lambda () (display source)))
          (store-changes! source-file comment
                          (and auth username) (and auth password))
          (redirect-to-qwiki-page req action: "show"))
        (send-content content))))

(define (redirect-to-qwiki-page req
                                #!key
                                ;; TODO: make path relative to qwiki-base-uri
                                (path (uri-path (request-uri req)))
                                (action "show"))
  (with-headers `((location
                   ,(update-uri (server-root-uri)
                                path: path
                                query: (alist-update!
                                        'action action
                                        (or (uri-query (request-uri req))
                                            '())))))
    ;; Maybe send a 303?
    (lambda () (send-status 302 "Found"))))

(define (qwiki-show path req)
  ;; TODO: What if someone did something else than GET or HEAD?
  (let* ((html-file (path->html-filename path))
         (source-file (path->source-filename path))
         (rev (string->number
               (alist-ref 'rev (uri-query (request-uri req)) eq? ""))))
    (if (file-exists? source-file)
        (if rev
            (send-content ; Do not store if old rev
             (qwiki-sxml-page-template
              (call-with-input-revision
               source-file rev wiki-parse)))
            (begin
             (update-html-file! (make-pathname (root-path) html-file)
                                source-file)
             (send-static-file html-file)))
        (redirect-to-qwiki-page req action: "edit"))))

(define (file-newer? a b)
  (> (file-modification-time a) (file-modification-time b)))

;; Generate new cached HTML file
(define (update-html-file! html-file source-file #!optional force-update)
  (when (or force-update
            (not (file-exists? html-file))
            (file-newer? source-file html-file))
    (with-output-to-path html-file
      (lambda ()
        (let ((content (qwiki-sxml-page-template
                        (call-with-input-file source-file wiki-parse))))
          (output-xml content (qwiki-transformation-steps content)))))))

;;; Request dispatching
(define action-handlers
  `((edit    . ,qwiki-edit)
    (show    . ,qwiki-show)
    (history . ,qwiki-history)))

(define (read-request-data req)
  (let ((len (header-value 'content-length (request-headers req))))
    ;; If the header is not available, this will read until EOF
    (read-string len (request-port req))))

;; From Spiffy. Maybe export it there?
(define (impossible-filename? name)
  (or (string=? name ".") (string=? name "..") (string-index name #\/)))

(define (ensure-latest-sources!)
  (if (not (directory-exists? (qwiki-source-path)))
      (checkout-sources! (qwiki-source-path))
      ;; Not sure if this should be done every freaking time - it's slow!
      #;(update-sources! (qwiki-source-path))
      (void)))

;; Spiffy handler for requests that should be routed to the wiki
(define (qwiki-handler continue)
  (ensure-latest-sources!)
  (let ((uri (request-uri (current-request))))
    (if (any impossible-filename? (cdr (uri-path uri))) ; assumed to be absolute
        (begin
          (read-request-data (current-request))
          (send-status 404 "Not found"))
        (let* ((action (string->symbol
                        (alist-ref 'action (uri-query uri) eq? "show")))
               (handler (alist-ref action action-handlers eq? qwiki-show)))
          (handler (relative-uri-path uri) (current-request))))))

(define (qwiki-render-file file)
  (call-with-input-file file
    (lambda (input)
      (let ((content (qwiki-sxml-page-template (wiki-parse input))))
        (output-xml content (qwiki-transformation-steps content))))))

)