;;
;; qwiki - the quick wiki
;;
;; Copyright (c) 2009-2012 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.
;; TODO: Attempt to split out all Spiffy and URI-related stuff.
;; This makes things like the post-commit-hook much more lightweight.
(module qwiki
(qwiki-docroot
qwiki-web-path
qwiki-source-path
qwiki-base-uri
qwiki-handler
qwiki-show
qwiki-edit
qwiki-history
qwiki-transformation-steps
qwiki-extensions
qwiki-output-driver
qwiki-global-action-handlers
qwiki-page-action-handlers
qwiki-update-handlers
qwiki-update-file!
qwiki-delete-handlers
qwiki-delete-file!
qwiki-clear-cache!
qwiki-css-file
qwiki-title
qwiki-sxml-page-template
send-content
write-content
blocked-ip-addresses-file
)
(import chicken scheme)
(use extras files posix ports data-structures srfi-1 srfi-13 srfi-14
intarweb uri-common spiffy sxml-transforms sxpath
svnwiki-sxml qwiki-sxml doctype sha1 message-digest
;; 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 docroot. This will be parameterized to be identical to the Spiffy
;; docroot when running inside the webserver. The post-commit-hook
;; could need to customize this.
(define qwiki-web-path
(make-parameter
(or (get-environment-variable "QWIKI_WEB_PATH") "/var/www")))
;; The location of the wiki source files (where a checkout will be made)
(define qwiki-source-path
(make-parameter
(or (get-environment-variable "QWIKI_SOURCE_PATH") "/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)))
(define qwiki-update-handlers
(make-parameter (list)))
(define qwiki-delete-handlers
(make-parameter (list)))
;; Not configurable but used during processing; the file currently being
;; processed by the system.
(define qwiki-current-file
(make-parameter #f))
(define qwiki-css-file
(make-parameter #f (lambda (x) (and x (uri-reference x)))))
(define qwiki-title (make-parameter #f))
(define blocked-ip-addresses-file
(make-parameter "edit-deny"))
;; This must match name-to-base in svnwiki/deps.scm
;; It is changed slightly to disallow newlines, tabs or other "weird"
;; whitespace characters.
(define (simplify-pagename pagename)
(let* ((basedir (and (qwiki-current-file) (pathname-directory (qwiki-current-file))))
(pagedir (if (and basedir (not (absolute-pathname? pagename)))
(make-pathname (qwiki-source-path) basedir)
(qwiki-source-path)))
;; Try if any of these exist, first
(attempts (list pagename (string-downcase pagename))))
(or (find (lambda (f)
(let ((path-part (car (string-split f "#" #t))))
(file-exists? (make-pathname pagedir path-part)))) attempts)
;; None match? Then simplify by getting rid of nonalphanumerics and
;; convert spaces to dashes. This results in sane, easy to type URIs.
;; Also keep hash signs; those are probably not part of the filename
;; but URI fragments jumping further into a page.
(string-downcase (string-filter
(char-set-union char-set:letter+digit
(char-set #\space #\/ #\- #\#))
(string-translate pagename " " "-"))))))
(define wiki-link-normalization
`((int-link . ,(lambda (tag tree)
(let* ((href (car tree))
(contents (cdr tree))
(pretty-href (simplify-pagename href)))
(if (pair? contents)
`(int-link ,pretty-href . ,contents)
`(int-link ,pretty-href ,href)))))
. ,alist-conv-rules*))
(define wiki-add-title
`((Header
((title . ,(lambda (tag elems)
(if (not (qwiki-title))
(cons tag elems)
(cons tag `(,@elems " - " ,(qwiki-title)))))))
. ,(lambda (tag elems)
(cons tag elems)))
. ,alist-conv-rules*))
;; The rules used for transforming page SXML structure
(define (qwiki-transformation-steps content)
(append (list wiki-link-normalization wiki-add-title)
(qwiki-extensions)
((qwiki-output-driver) content)
))
;; The basic template for SXML wiki pages
(define (qwiki-sxml-page-template contents . headers)
(let ((headers
(if (qwiki-css-file)
(cons `(style ,(uri->string (uri-relative-to (qwiki-css-file)
(qwiki-base-uri))))
headers)
headers)))
`(wiki-page (Header . ,headers)
(body (page-specific-links . ,headers)
(wiki-content ,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 "/")))
;; Handle index files where needed. Never try to open a directory as file
(define (normalize-path path)
(remove! string-null?
(if (directory? (path->source-filename path))
(append path '("index"))
path)))
;; This exists to normalize the first symlink in a path. Applying this
;; recursively (letting the browser recur) causes all files to be
;; accessed (safely) through their canonical location. Doing so means
;; the search and cache won't get confused by two locations being one.
;; It also helps ward off symlink attacks (though we should only let
;; trusted people on our wiki in the first place) and improve search engine
;; ranking (because there's only one canonical page instead of two identical
;; pages). Also, it will cure cancer and effectuate world peace.
(define (rewrite-symlinks path)
(let lp ((consumed-path '())
(remaining-path path))
(and-let* (((not (null? remaining-path))) ; Return #f when no symlinks
(tgt (path->source-filename
(reverse (cons (car remaining-path) consumed-path))))
((file-exists? tgt)))
(if (symbolic-link? tgt)
(append (reverse consumed-path)
(string-split (read-symbolic-link tgt) "/")
(cdr remaining-path))
(lp (cons (car remaining-path) consumed-path)
(cdr remaining-path))))))
;; If we are accessing foo/bar/qux while foo/bar exists and is not a directory,
;; we can't create the target file, so we need to take action. This procedure
;; detects if this is the case and returns the path to that file, or #f if not.
(define (page-in-intermediate-path path)
(let lp ((path (if (null? path) path (drop-right path 1))))
(if (null? path)
#f
(let ((fn (path->source-filename path)))
(if (file-exists? fn)
(and (not (directory? fn)) path)
(lp (drop-right path 1)))))))
;; 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))
;; From sxml-fu
(define (output-xml tree rulesets)
(SRV:send-reply (fold (lambda (ruleset tree)
(pre-post-order* tree ruleset))
tree rulesets)))
(define (send-content content)
(with-headers `((connection close))
(lambda ()
(write-logged-response)))
(with-output-to-port (response-port (current-response))
(lambda ()
(output-xml content (qwiki-transformation-steps content)))))
(define (write-content content)
(output-xml content (qwiki-transformation-steps content)))
;;; Actions
(define (qwiki-history path req)
(let ((source-file (path->source-filename path)))
(if (not (file-exists? source-file))
(redirect-to-qwiki-page req) ; Default action
(let* ((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)
;; We could determine the current title by parsing
;; the wiki page. That would be a bit wasteful though...
;; Perhaps read out svnwiki:title instead?
`(title ,(sprintf "Edit history for page: ~A"
(string-join path "/")))
(if (frozen? source-file) '(read-only) '(read-write)))))
(send-content content)))))
(define (blocked-ip-address? ip-address)
(and-let* ((f (blocked-ip-addresses-file))
(file (make-pathname (qwiki-source-path) f))
((file-exists? file)))
(call-with-input-file file
(lambda (p)
(let loop ((line (read-line p)))
(if (eof-object? line)
#f
(or (string=? (string-trim-both line) ip-address)
(loop (read-line p)))))))))
(define (qwiki-edit path req)
(let* ((source-file (path->source-filename path))
(auth-required (requires-authentication? source-file))
(postdata (if (eq? 'POST (request-method req))
(read-urlencoded-request-data)
'()))
(new-file (not (file-exists? source-file)))
(file-rev (if new-file 0 (get-last-modified-revision source-file)))
;; Used for the spam check, but not sent into the form
(file-author (if new-file "-" (cadar (get-history source-file file-rev 1))))
(source (string-translate*
(or (alist-ref 'source postdata)
(and (not new-file)
(with-input-from-file source-file read-string))
"")
;; normalize all EOL styles to Unix line endings
'(("\r\n" . "\n") ("\r" . "\n"))))
(sxml (call-with-input-string source svnwiki->sxml))
(comment (alist-ref 'comment postdata eq? ""))
(username (alist-ref 'username postdata eq? ""))
(password (alist-ref 'password postdata eq? ""))
(edit-rev (or (string->number (alist-ref 'edit-rev postdata eq?
(number->string file-rev))) 0))
(make-spam-control-hash
(lambda (answer time)
(message-digest-string
(sha1-primitive)
(sprintf "Answer: ~A for file ~A (r~A by ~A) at ~A"
answer source-file file-rev file-author time))))
(auth (or auth-required (alist-ref 'auth postdata)))
(title (title-for-wiki-page sxml))
;; If spambot provided auth, it will fail on bad credentials later
(likely-human
(or auth (and-let* ((hash (alist-ref 'captcha-hash postdata))
(ans (alist-ref 'captcha-answer postdata))
(time (alist-ref 'captcha-time postdata))
((> (string->number time) ; max half an hour old
(- (current-seconds) 108000)))
(expected-hash (make-spam-control-hash ans time)))
;; The hash is unique for this form since this file
;; will only be changed for this revision once and
;; the revision/filename combination is unforgeable.
;; We could use crypt() instead of sha1 for added
;; security but it hardly seems worth it because the
;; challenge itself is rather weak...
(string=? hash expected-hash))))
;; 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
(make-form
(lambda (#!optional message)
(qwiki-sxml-page-template
`(,(if (alist-ref 'preview postdata)
`(div (@ (class "preview")) (h2 "Preview") ,sxml)
"")
,(if message
`(div (@ class "message") ,message)
"")
(form (@ (method "post") (action ""))
(div (@ (id "article"))
(p "You can edit this page using "
(a (@ (href "/edit-help")) "wiki syntax")
" for markup.")
(label "Article contents:"
(textarea (@ (name "source")
(rows "20") (cols "72"))
,source))
(label "Description of your changes:"
(textarea (@ (name "comment")
(rows "2") (cols "72"))
,comment))
(input (@ (type "hidden") (name "edit-rev")
(value ,edit-rev))))
(div (@ (id "auth"))
,(if auth-required
`(label "This file is " (em "locked.")
" To edit it, you "
(em "must authenticate.")
(input (@ (type "hidden")
(name "auth")
(value "true"))))
`(label "I would like to authenticate"
(input (@ (type "checkbox")
(name "auth")
(id "auth-checkbox")
(value "true")
. ,(if auth
'((checked "checked"))
'())))))
(div (@ (id "credentials"))
(h3 "Authentication")
(label "Username:"
(input (@ (type "text")
(name "username")
(value ,username))))
(label "Password:"
(input (@ (type "password")
(name "password")
(value ,password))))))
,(if auth-required ;; No point in including a spam check
`(div)
(let* ((op (vector-ref '#(+ - *) (random 3)))
(a (random (if (eq? op '*) 10 25)))
(b (random (if (eq? op '*) 10 25)))
(res ((case op ((+) +) ((-) -) ((*) *)) a b))
(time (->string (current-seconds))))
`(div (@ (id "antispam"))
(h3 "Spam control")
(p "What do you get when you "
,(case op
((-) (sprintf " subtract ~A from ~A?" b a))
((*) (sprintf " multiply ~A by ~A?" a b))
((+) (sprintf " add ~A to ~A?" a b))))
(input (@ (type "hidden") (name "captcha-time")
(value ,time)))
(input (@ (type "hidden") (name "captcha-hash")
(value ,(make-spam-control-hash
res time))))
(input (@ (type "text") (name "captcha-answer")
;; prevent Firefox from pre-filling:
(value "")))
;; Really nasty inline JS, but this keeps
;; it lean and mean; no external JS needed.
(script (@ (type "text/javascript"))
"var box = document.getElementById('auth-checkbox');"
"var as = document.getElementById('antispam').style;"
"var cs = document.getElementById('credentials').style;"
"if (box.checked)"
" as.display = 'none';"
" else "
" cs.display = 'none';"
"box.onclick = function() {"
" if (box.checked) {"
" as.display = 'none';"
" cs.display = 'block';"
" } else {"
" as.display = 'block';"
" cs.display = 'none';"
" }"
"};"))))
(div (@ (id "actions"))
(input (@ (type "submit")
(name "save")
(value "Save")))
(input (@ (type "submit")
(name "preview")
(value "Preview"))))))
`(title ,(sprintf "Editing page: ~A" (or title (string-join path "/"))))
(if new-file '(new-file) '(existing-file))))))
(cond
((frozen? source-file) (redirect-to-qwiki-page req)) ; Default action
((blocked-ip-address? (remote-address))
(send-content
(make-form (conc "You have been blocked from making any edits. "
"If you believe this is in error, please contact "
"the administrators of this wiki."))))
((and (alist-ref 'save postdata) (not (= edit-rev file-rev)))
(send-content
(make-form (conc "Warning! Someone else has edited this page while you "
"were editing it. You are blocked from saving this "
"page. Please review the latest version by clicking "
"\"show\", then click \"edit\" and merge in your "
"changes again. Sorry for the inconvenience!"))))
((and (alist-ref 'save postdata) (not likely-human))
(send-content
(make-form (conc "Your answer to the spam control question was "
"incorrect. Are you a spammer? Gosh, I hope not! "
"Try again, but please try a little harder!"))))
((alist-ref 'save postdata)
(with-output-to-path source-file (lambda () (display source)))
(handle-exceptions exn
(begin
(undo-changes! source-file)
;; No idea how to cleanly ensure a proper update...
;; The enclosing directory might have been removed, or the file
;; might have been deleted, renamed etc. Let's just update the
;; whole tree (but this can take a long time)
(ensure-latest-sources! #t)
;; Different type of race condition
(send-content
(make-form (conc "Error! Something went wrong while "
"storing your changes."
(if auth
(conc " It is possible your username/password "
"are incorrect.")
"")
" Please try again. If this error keeps up, "
"please notify a system administrator about it."))))
(store-changes! source-file
(if auth
comment
(sprintf "Anonymous wiki edit for IP [~A]: ~A"
(remote-address) comment))
(and auth username) (and auth password))
(redirect-to-qwiki-page req))) ; Default action
(else (send-content (make-form))))))
(define (->symbol x) (if (symbol? x) x (string->symbol (->string x))))
(define (redirect-to-qwiki-page
req #!key (path (uri-path (request-uri req))) action)
;; Default action is "show" and should not appear in generated URIs
(let ((action (and action (not (eq? (->symbol action) 'show)) action)))
(with-headers `((location
,(uri-relative-to
(update-uri (uri-reference "")
path: path
query: (alist-update!
'action action
(or (uri-query (request-uri req))
'())))
;; qwiki-base-uri may itself be relative, so resolve
;; it against the known-to-be-absolute request-uri
(uri-relative-to (qwiki-base-uri) (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))
(html-path (make-pathname (qwiki-web-path) html-file))
(source-file (path->source-filename path)))
(cond
((not (file-exists? source-file))
(parameterize ((current-response (update-response
(current-response)
code: 404 reason: "Not found")))
(send-content
(qwiki-sxml-page-template
`(div (@ (id "missing-page"))
(h1 "This page does not exist yet")
(p "The page you requested, \"" ,(string-join path "/") "\", "
"does not currently exist. If you want, you can "
(a (@ (rel "nofollow") (href "?action=edit"))
"create this page.")))
`(title ,(string-join path "/"))
`(new-file)))))
((string->number (alist-ref 'rev (uri-query (request-uri req)) eq? ""))
=> (lambda (rev) ; Do not cache HTML file if historical rev was requested
(send-content
(let* ((sxml (call-with-input-revision
source-file rev svnwiki->sxml))
(title (title-for-wiki-page sxml)))
(qwiki-sxml-page-template
`(div (@ (class "old-revision"))
(p (@ (id "old-revision-message"))
,(sprintf "You are looking at historical revision ~A of this page. " rev)
"It may differ significantly from its "
(a (@ (href "?action=show")) "current revision."))
,sxml)
`(title ,(sprintf "~A (historical revision ~A)"
(or title (string-join path "/"))
rev))
`(canonical "?action=show")
(if (frozen? source-file) '(read-only) '(read-write)))))))
(else (when (or (not (file-exists? html-path))
(file-newer? source-file html-path))
(qwiki-update-file! path))
(send-static-file html-file)))))
(define (frozen? source-file)
(and-let* ((value (get-extended-property source-file "svnwiki:frozen")))
(string=? (string-trim-both value) "yes")))
(define (requires-authentication? source-file)
(and-let* ((value (get-extended-property source-file "svnwiki:authenticate")))
(string=? (string-trim-both value) "yes")))
(define (file-newer? a b)
(> (file-modification-time a) (file-modification-time b)))
;; Generate new cached HTML file
(define (regenerate-html-file! path page)
(let* ((html-file (make-pathname (qwiki-web-path) (path->html-filename path)))
(title (title-for-wiki-page page)))
(with-output-to-path html-file
(lambda ()
(let ((content (qwiki-sxml-page-template
page
`(title ,(or title (string-join path "/")))
(if (frozen? (path->source-filename path))
'(read-only)
'(read-write)))))
(output-xml content (qwiki-transformation-steps content)))))))
(define (qwiki-update-file! path)
(let* ((source-file (path->source-filename path))
(page (call-with-input-file source-file
(lambda (f)
(handle-exceptions exn
(begin (close-input-port f) (signal exn))
(svnwiki->sxml f))))))
(parameterize ((qwiki-current-file (string-join path "/")))
(for-each (lambda (handler) (handler path page))
(append (qwiki-update-handlers) (list regenerate-html-file!))))))
(define (delete-html-file! path)
(let ((basename
(make-pathname (qwiki-docroot)
(string-join (cons (qwiki-web-path) path) "/"))))
(if (and (directory? basename) (not (symbolic-link? basename)))
(begin
(for-each delete-html-file! (directory basename #t))
(delete-directory basename))
(delete-file* (string-append basename ".html")))))
;; Destroy all HTML files in the cache
(define (qwiki-clear-cache!)
(find-files (qwiki-web-path)
(lambda (f) (string=? (or (pathname-extension f) "") "html"))
(lambda (f _) (delete-file* f)) #f
(lambda (x) (not (symbolic-link? x)))))
(define (qwiki-delete-file! path)
(parameterize ((qwiki-current-file (string-join path "/")))
(for-each (lambda (handler) (handler path))
(cons delete-html-file! (qwiki-delete-handlers)))))
;;; Request dispatching
(define qwiki-page-action-handlers
(make-parameter
`((edit . ,qwiki-edit)
(show . ,qwiki-show)
(history . ,qwiki-history))))
(define qwiki-global-action-handlers
(make-parameter (list)))
;; From Spiffy. Maybe export it there?
(define (impossible-filename? name)
(or (string=? name ".") (string=? name "..") (string-index name #\/)))
(define (ensure-latest-sources! #!optional force?)
;; Not sure if this should be done every freaking time - it's slow!
(if force?
(update-sources! (qwiki-source-path))
(void)))
;; Spiffy handler for requests that should be routed to the wiki
(define (qwiki-handler continue)
(parameterize ((qwiki-web-path (root-path)))
(cond
((not (directory-exists? (qwiki-source-path)))
(send-status 503 "Missing checkout"
(conc "Checkout not found. Expected it in "
"" (htmlize (qwiki-source-path)) ".
"
"
To fix this, please run qwiki-install or change "
"the value of qwiki-source-path.
")))
(else
(ensure-latest-sources!)
(let ((uri (request-uri (current-request)))
(css (qwiki-css-file)))
(cond
((and css (equal? (uri-path uri) (uri-path css)))
(send-static-file
(make-pathname (qwiki-docroot)
(string-join (cdr (uri-path (qwiki-css-file))) "/"))))
((find (lambda (a)
(equal? (uri-path uri) (list '/ (->string (car a)))))
(qwiki-global-action-handlers))
=> (lambda (handler)
((cdr handler) (current-request))))
((any impossible-filename? (cdr (uri-path uri))) ; should be absolute
(read-urlencoded-request-data) ; Discard possible sent data
(send-status 404 "Not found"))
(else (let* ((action (->symbol (alist-ref
'action (uri-query uri) eq? "show")))
(handler (alist-ref action
(qwiki-page-action-handlers)
eq? qwiki-show))
(normalized-path (normalize-path (relative-uri-path uri))))
(cond
((or (rewrite-symlinks normalized-path)
(page-in-intermediate-path normalized-path))
=> (lambda (new-path)
(redirect-to-qwiki-page (current-request)
path: new-path action: action)))
(else (handler normalized-path (current-request))))))))))))
)