diff options
| -rw-r--r-- | tekuti/boot.scm | 6 | ||||
| -rw-r--r-- | tekuti/config.scm | 7 | ||||
| -rw-r--r-- | tekuti/mod-lisp.scm | 256 | ||||
| -rw-r--r-- | tekuti/page-helpers.scm | 184 | ||||
| -rw-r--r-- | tekuti/page.scm | 283 | ||||
| -rw-r--r-- | tekuti/request.scm | 165 | ||||
| -rw-r--r-- | tekuti/web.scm | 68 |
7 files changed, 515 insertions, 454 deletions
diff --git a/tekuti/boot.scm b/tekuti/boot.scm index 2380e7c..7ad4c0a 100644 --- a/tekuti/boot.scm +++ b/tekuti/boot.scm @@ -1,5 +1,5 @@ ;; Tekuti -;; Copyright (C) 2008 Andy Wingo <wingo at pobox dot com> +;; Copyright (C) 2008, 2010 Andy Wingo <wingo at pobox dot com> ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as @@ -30,7 +30,7 @@ #:use-module (ice-9 format) #:use-module (ice-9 getopt-long) #:use-module (tekuti git) - #:use-module (tekuti mod-lisp) + #:use-module (tekuti web) #:export (boot)) (define *option-grammar* '((listen) @@ -80,4 +80,4 @@ (set-current-module config-module) (primitive-load config)))))) (ensure-git-repo) - (event-loop))) + (main-loop))) diff --git a/tekuti/config.scm b/tekuti/config.scm index 84a8f8e..4dd97c9 100644 --- a/tekuti/config.scm +++ b/tekuti/config.scm @@ -27,20 +27,15 @@ (define-module (tekuti config) #:use-module (tekuti util) #:use-module ((sxml ssax) #:select (define-parsed-entity!)) - #:export (*host* *port* *backlog* *git-dir* *git* *public-url-base* - *private-url-base* *debug* *admin-user* *admin-pass* + #:export (*host* *git-dir* *git* *debug* *admin-user* *admin-pass* *css-file* *navbar-links* *navbar-infix* *title* *subtitle* *name* *public-path-base* *private-path-base* *server-impl* *server-impl-args*)) (define *host* "127.0.0.1") -(define *port* 8081) -(define *backlog* 5) (define *git-dir* "~/blog.git") (define *git* "git") -(define *public-url-base* "/") -(define *private-url-base* "/") (define *public-path-base* '()) (define *private-path-base* '()) (define *css-file* "/base.css") diff --git a/tekuti/mod-lisp.scm b/tekuti/mod-lisp.scm index f209756..b6c8faf 100644 --- a/tekuti/mod-lisp.scm +++ b/tekuti/mod-lisp.scm @@ -1,5 +1,5 @@ ;; Tekuti -;; Copyright (C) 2008 Andy Wingo <wingo at pobox dot com> +;; Copyright (C) 2008, 2010 Andy Wingo <wingo at pobox dot com> ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as @@ -20,102 +20,196 @@ ;;; Commentary: ;; -;; This is the main script that will launch tekuti. +;; Web server implementation for mod-lisp. ;; ;;; Code: (define-module (tekuti mod-lisp) #:use-module (ice-9 rdelim) - #:use-module (tekuti config) - #:use-module (tekuti util) - #:use-module (tekuti index) - #:use-module (tekuti request) - #:use-module (tekuti web) - #:export (event-loop)) + #:use-module (system repl error-handling) + #:use-module (rnrs bytevectors) + #:use-module (web http) + #:use-module (web request) + #:use-module (web response) + #:use-module (web server)) + ;;; FIXME: ignore SIGPIPE, otherwise apache dying will kill us -(define (read-headers socket) +(define *mod-lisp-headers* (make-hash-table)) + +(define (define-mod-lisp-header! sym name parser) + (hash-set! *mod-lisp-headers* name (cons sym parser))) + +(define (mod-lisp-sym-and-parser name) + (hash-ref *mod-lisp-headers* name)) + +(define-mod-lisp-header! 'server-protocol + "server-protocol" + parse-http-version) + +(define-mod-lisp-header! 'method + "method" + parse-http-method) + +(define-mod-lisp-header! 'url + "URL" + parse-request-uri) + +(define-mod-lisp-header! 'server-ip-addr + "server-ip-addr" + identity) + +(define-mod-lisp-header! 'server-ip-port + "server-ip-port" + string->number) + +(define-mod-lisp-header! 'remote-ip-addr + "remote-ip-addr" + identity) + +(define-mod-lisp-header! 'remote-ip-port + "remote-ip-port" + string->number) + +(define-mod-lisp-header! 'server-id + "server-id" + identity) + +(define-mod-lisp-header! 'server-ip-addr + "server-ip-addr" + identity) + +(define-mod-lisp-header! 'server-baseversion + "server-baseversion" + identity) + +(define-mod-lisp-header! 'modlisp-version + "modlisp-version" + identity) + +(define-mod-lisp-header! 'modlisp-major-version + "modlisp-major-version" + string->number) + +(define (read-headers/mod-lisp socket) (define (read-line*) (let ((line (read-line socket))) (if (eof-object? line) (error "unexpected eof") line))) - (let lp ((keys '()) (values '())) + (let lp ((headers '()) (meta '())) (let ((k (read-line*))) (if (string=? k "end") - (reverse (map cons keys values)) - (lp (cons (string-downcase k) keys) - (cons (read-line*) values)))))) + (values (reverse! headers) (reverse! meta)) + (let ((sym-and-parser (mod-lisp-sym-and-parser k)) + (v (read-line*))) + (if sym-and-parser + (lp headers + (acons (car sym-and-parser) + ((cdr sym-and-parser) v) + meta)) + (call-with-values (lambda () (parse-header k v)) + (lambda (k v) + (lp (acons k v headers) meta))))))))) -(define (read-chars nchars port) - (let ((buf (make-string nchars))) - (read-delimited! "" buf port) - buf)) +(define (read-request/mod-lisp port) + (call-with-values (lambda () (read-headers/mod-lisp port)) + (lambda (headers meta) + (build-request + #:method (assq-ref meta 'method) + #:uri (assq-ref meta 'url) + #:version (assq-ref meta 'url) + #:headers headers + #:meta meta + #:port port)))) -(define (write-headers headers port) +(define (write-header/mod-lisp name val port) + (if (string? name) + ;; assume that it's a header we don't know about... + (begin + (display name port) (newline port) + (display val port) (newline port)) + (let ((decl (lookup-header-decl name))) + (if (not decl) + (error "Unknown header" name) + (begin + (display (header-decl-name decl) port) (newline port) + ((header-decl-writer decl) val port) (newline port)))))) + +(define (write-response-line/mod-lisp code phrase port) + (write-header/mod-lisp "Status" + (string-append (number->string code) " " phrase) + port)) + +(define (write-headers/mod-lisp headers port) (for-each - (lambda (pair) - (format port "~a\n~a\n" (car pair) (cdr pair))) - headers) - (display "end\n" port)) - -(define (write-body request socket) - ((rref request 'output error) socket)) - -(define (request-output-headers request) - (rref request 'output-headers '())) - -(define (connection-received socket sockaddr index) - (let* ((headers (read-headers socket)) - (post-data (read-chars (string->number - (or (assoc-ref headers "content-length") - "0")) - socket))) - (catch - #t - (lambda () - (let ((res (handle-request (make-request 'headers headers - 'post-data post-data) - index))) - (write-headers (request-output-headers res) socket) - (write-body res socket))) - (lambda args - (write-headers '(("Status" . "500 Internal Server Error") - ("Content-Type" . "text/plain")) - socket) - (display "Sorry bub, had an error. Please let the admin know. Thanks!\n" - socket) - (write headers) (newline) - (write args) (newline) - (backtrace)) - (lambda args - (fluid-set! the-last-stack (make-stack #t 2 0)) - (apply throw args))) - - (close-port socket))) - -(define (with-socket proc) - (pk 'listening) - (let ((socket (socket PF_INET SOCK_STREAM 0))) - (setsockopt socket SOL_SOCKET SO_REUSEADDR 1) - (bind socket AF_INET (inet-aton *host*) *port*) - (listen socket *backlog*) - (unwind-protect - (proc socket) - (shutdown socket 2)))) - -(define (inner-loop socket index) - (let* ((pair (accept socket)) - (fd (car pair)) - (sockaddr (cdr pair)) - (new-index (maybe-reindex index))) - (connection-received fd sockaddr (cdr new-index)) - (inner-loop socket new-index))) - -(define (event-loop) - (with-socket - (lambda (socket) - (format #t "entering inner loop\n") - (inner-loop socket (read-index))))) + (lambda (pair) + (write-header (car pair) (cdr pair) port)) + headers)) + +(define (write-response/mod-lisp r port) + (write-response-line/mod-lisp (response-code r) + (response-reason-phrase r) port) + (write-headers (response-headers r) port) + (display "end" port) (newline port) + (if (eq? port (response-port r)) + r + (build-response #:version (response-version r) + #:code (response-code r) + #:reason-phrase (response-reason-phrase r) + #:headers (response-headers r) + #:port port))) + +(define (make-default-socket family addr port) + (let ((sock (socket PF_INET SOCK_STREAM 0))) + (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) + (bind sock family addr port) + sock)) + +;; -> server +(define* (mod-lisp-open #:key + (host #f) + (family AF_INET) + (addr (if host + (inet-pton family host) + INADDR_LOOPBACK)) + (port 8080) + (socket (make-default-socket family addr port))) + (listen socket 5) + socket) + +;; For mod-lisp, we don't do keep-alive. +(define (keep-alive? response) + #f) + +;; -> (keep-alive client request body | keep-alive #f #f #f) +(define (mod-lisp-read server keep-alive) + (let* ((client (accept server)) + (req (read-request/mod-lisp (car client))) + (body-str (read-request-body/latin-1 req))) + (values keep-alive (car client) req body-str))) + +;; -> (#f | client) +(define (mod-lisp-write server client response body) + (let ((response (write-response/mod-lisp response client))) + (cond + ((not body)) ; pass + ((string? body) + (write-response-body/latin-1 response body)) + ((bytevector? body) + (write-response-body/bytevector response body)) + (else + (error "Expected a string or bytevector for body" body))) + (close-port (response-port response)) + #f)) + +;; -> unspecified values +(define (mod-lisp-close server) + (close-port server)) +(define-server-impl mod-lisp + mod-lisp-open + mod-lisp-read + mod-lisp-write + mod-lisp-close) diff --git a/tekuti/page-helpers.scm b/tekuti/page-helpers.scm index b2f9ace..ed6fb8a 100644 --- a/tekuti/page-helpers.scm +++ b/tekuti/page-helpers.scm @@ -25,31 +25,116 @@ ;;; Code: (define-module (tekuti page-helpers) + #:use-module (sxml simple) + #:use-module (web uri) + #:use-module (web http) + #:use-module (web response) #:use-module (tekuti config) #:use-module (tekuti util) #:use-module (tekuti git) #:use-module (tekuti post) #:use-module (tekuti tags) #:use-module (tekuti comment) - #:use-module (tekuti url) #:use-module (tekuti request) + #:use-module (tekuti template) #:use-module (srfi srfi-19) - #:export (relurl rellink redirect post-url + #:export (respond + relurl rellink + post-url published-posts post-editing-form sidebar-ul top-tags tag-cloud main-sidebar post-sidebar related-tag-cloud - post-link admin-post-link admin-post-redirect + post-link admin-post-url admin-post-link show-post with-authentication find-posts-matching atom-header atom-entry)) -(define (relurl . paths) - (apply string-append *public-url-base* paths)) +(define xhtml-doctype + (string-append + "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" " + "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n")) -(define (rellink path . body) - `(a (@ (href ,(relurl path))) - ,@body)) +(define (acons* tail . args) + (let lp ((tail tail) (args args)) + (if (null? args) + tail + (let ((k (car args)) (v (cadr args))) + (lp (if v (acons k v tail) tail) + (cddr args)))))) + +(define* (respond #:optional body #:key + redirect + (status (if redirect 302 200)) + (title *title*) + last-modified + (doctype xhtml-doctype) + (content-type-params '(("charset" . "utf-8"))) + (content-type "text/html") + (extra-headers '()) + (sxml (templatize #:title title #:body body))) + (values (build-response + #:code status + #:headers (acons* + extra-headers + 'location redirect + 'last-modified last-modified + 'content-type (cons content-type content-type-params))) + (lambda (port) + (if sxml + (begin + (display doctype port) + (sxml->xml sxml port)))))) + +(define (unparse-www-form-urlencoded alist) + (string-join (map (lambda (pair) + (if (cdr pair) + (string-append (uri-encode (car pair)) + "=" + (uri-encode (cdr pair))) + (uri-encode (car pair)))) + alist) + "&")) + +(define* (relative-url uri path-components #:key query fragment) + (unparse-uri + (build-uri (uri-scheme uri) + #:userinfo (uri-userinfo uri) #:host (uri-host uri) + #:port (uri-port uri) + #:path (encode-and-join-uri-path + (append (split-and-decode-uri-path (uri-path uri)) + path-components)) + #:query (and=> query unparse-www-form-urlencoded) + #:fragment fragment))) + +(define* (relative-link uri path-components text #:key query fragment) + `(a (@ (href ,(relative-url uri path-components #:query query + #:fragment fragment))) + ,@text)) + +(define* (relative-path base path-components #:key query fragment) + (let ((path (encode-and-join-uri-path (append base path-components))) + (query (and=> query unparse-www-form-urlencoded))) + (if query + (if fragment + (string-append "/" path "?" query "#" fragment) + (string-append "/" path "?" query)) + (if fragment + (string-append "/" path "#" fragment) + (string-append "/" path))))) + +(define* (relative-path-link base path-components text #:key query fragment) + `(a (@ (href ,(relative-path base path-components #:query query + #:fragment fragment))) + ,text)) + +(define* (relurl path-components #:key query fragment) + (relative-path *public-path-base* path-components #:query query + #:fragment fragment)) + +(define* (rellink path-components text #:key query fragment) + (relative-path-link *public-path-base* path-components text #:query query + #:fragment fragment)) (define (published-posts index n) (filter-mapn (lambda (post) @@ -60,10 +145,9 @@ (define (post-editing-form post) `(div (form (@ (method "POST") - (action ,(relurl (if post - (string-append "admin/modify-post/" - (url:encode (post-key post))) - "admin/new-post")))) + (action ,(if post + (relurl `("admin" "modify-post" ,(post-key post))) + (relurl '("admin" "new-post"))))) (p (input (@ (name "title") (type "text") (value ,(if post (post-title post) "")))) (label (@ (for "title")) " <- title")) @@ -97,18 +181,21 @@ `(div (@ (id "menu")) (ul ,@body))) -;; double-encoding is a hack to trick apache (define (admin-post-url post) - (relurl "admin/posts/" (url:encode (post-key post)))) + (relurl `("admin" "posts" ,(post-key post)))) (define (admin-post-link post) `(a (@ (href ,(admin-post-url post))) ,(post-title post))) -(define (post-url post . tail) - (apply relurl "archives/" (url:decode (post-key post)) tail)) +(define* (post-url post #:key fragment) + (relative-path *public-path-base* + (cons "archives" + (split-and-decode-uri-path (uri-decode (post-key post)))) + #:fragment fragment)) -(define (post-link post . tail) - `(a (@ (href ,(apply post-url post tail))) ,(post-title post))) +(define* (post-link post #:key fragment) + `(a (@ (href ,(post-url post #:fragment fragment))) + ,(post-title post))) (define (comment-form post author email url comment) `(form @@ -154,8 +241,7 @@ ,(comment-form post "" "" "" "")))))) (define (tag-link tagname) - (rellink (string-append "tags/" (url:encode tagname)) - tagname)) + (rellink `("tags" ,tagname) tagname)) (define (show-post post comments?) `((h2 (@ (class "storytitle")) @@ -172,19 +258,12 @@ ,@(if comments? '() `((div (@ (class "feedback")) - (a (@ (href ,(post-url post "#comments"))) + (a (@ (href ,(post-url post #:fragment "comments"))) "(" ,(post-n-comments post) ")"))))) ,@(if comments? (list (post-sxml-comments post)) '()))) -(define (redirect request location) - (rpush 'output-headers (cons "Location" location) - (rcons 'status 302 request))) - -(define (admin-post-redirect request post) - (redirect request (admin-post-url post))) - (define (top-tags index n) (let ((hash (assq-ref index 'tags))) (if hash @@ -205,7 +284,7 @@ counts))) (list-intersperse (map (lambda (name size) - `(a (@ (href ,(relurl "tags/" (url:encode name))) + `(a (@ (href ,(relurl `("tags" ,name))) (rel "tag") (style ,(format #f "font-size: ~d%" size))) ,name)) @@ -215,25 +294,25 @@ (define (main-sidebar request index) (sidebar-ul - `((li (h2 (a (@ (href ,(relurl "feed/atom"))) + `((li (h2 (a (@ (href ,(relurl '("feed" "atom")))) "subscribe " - (img (@ (src ,(relurl "wp-content/feed-icon-14x14.png")) + (img (@ (src ,(relurl '("wp-content" "feed-icon-14x14.png"))) (alt "[feed]"))) ))) (li (h2 "search") (form (@ (method "POST") - (action ,(relurl "search"))) + (action ,(relurl '("search")))) (input (@ (name "string") (type "text") (size "15") (value ""))))) - (li (h2 "tags " ,(rellink "tags/" ">>")) + (li (h2 "tags " ,(rellink '("tags") ">>")) (ul (li (@ (style "line-height: 150%")) ,@(tag-cloud (top-tags index 30)))))))) (define (post-sidebar post index) (sidebar-ul - `((li (h2 (a (@ (href ,(relurl "feed/atom"))) + `((li (h2 (a (@ (href ,(relurl '("feed" "atom")))) "subscribe " - (img (@ (src ,(relurl "wp-content/feed-icon-14x14.png")) + (img (@ (src ,(relurl '("wp-content" "feed-icon-14x14.png"))) (alt "[feed]"))) ))) (li (h2 "related") @@ -264,17 +343,17 @@ (define (with-authentication request thunk) (if (request-authenticated? request) (thunk) - (rcons* (rpush 'output-headers - '("WWW-Authenticate" . "Basic realm=\"Tekuti\"") - request) - 'status 401 - 'body `((p "Authentication required, yo"))))) + (respond `((p "Authentication required, yo")) + #:status 401 + #:extra-headers '((www-authenticate . "Basic realm=\"Tekuti\""))))) (define (atom-header server-name last-modified) - (define (relurl tail) - (string-append "http://" server-name *public-url-base* tail)) + (define (relurl . tail) + (string-append "http://" server-name "/" + (encode-and-join-uri-path + (append *public-path-base* tail)))) `(feed - (@ (xmlns "http://www.w3.org/2005/Atom") (xml:base ,(relurl ""))) + (@ (xmlns "http://www.w3.org/2005/Atom") (xml:base ,(relurl))) (title (@ (type "text")) ,*title*) (subtitle (@ (type "text")) ,*subtitle*) ,@(if last-modified @@ -284,20 +363,25 @@ (version "what")) "tekuti") (link (@ (rel "alternate") (type "text/html") - (href ,(relurl "")))) - (id ,(relurl "feed/atom")) + (href ,(relurl)))) + (id ,(relurl "feed" "atom")) (link (@ (rel "self") (type "application/atom+xml") - (href ,(relurl "feed/atom")))))) + (href ,(relurl "feed" "atom")))))) (define (atom-entry server-name post) (define (relurl . tail) - (apply string-append "http://" server-name *public-url-base* tail)) + (string-append "http://" server-name "/" + (encode-and-join-uri-path + (append *public-path-base* tail)))) `(entry - (author (name ,*name*) (uri ,(relurl ""))) + (author (name ,*name*) (uri ,(relurl))) (title (@ (type "text")) ,(post-title post)) - (id ,(relurl (url:decode (post-key post)))) ;hack -- should include archives... + (id ,(apply relurl + ;; hack -- should include archives... + (split-and-decode-uri-path (uri-decode (post-key post))))) (link (@ (rel "alternate") (type "text/html") - (href ,(relurl "archives/" (url:decode (post-key post)))))) + (href ,(apply relurl "archives" (split-and-decode-uri-path + (uri-decode (post-key post))))))) (published ,(timestamp->atom-date (post-timestamp post))) (updated ,(timestamp->atom-date (post-timestamp post))) (content (@ (type "xhtml")) diff --git a/tekuti/page.scm b/tekuti/page.scm index 29cedb8..67d9001 100644 --- a/tekuti/page.scm +++ b/tekuti/page.scm @@ -30,7 +30,8 @@ #:use-module (tekuti git) #:use-module (tekuti post) #:use-module (tekuti comment) - #:use-module (tekuti url) + #:use-module (web uri) + #:use-module (web request) #:use-module (tekuti request) #:use-module (tekuti page-helpers) #:use-module (srfi srfi-34) @@ -55,17 +56,17 @@ page-debug page-not-found)) +;; Encoded twice, so as to form a single path-component. (define (make-post-key . parts) - (url:encode (format #f "~{~a~^/~}" (map url:encode parts)))) + (uri-encode (encode-and-join-uri-path parts))) (define (not-implemented request . args) - (rcons* request - 'status 500 - 'body `((h1 "Not yet implemented") + (respond `((h1 "Not yet implemented") (p "Path handler not yet implemented: " - ,(rref request 'path-str))))) + ,(request-relative-path-str request))) + #:status 500)) -(define (page-admin request index) +(define (page-admin request body index) (with-authentication request (lambda () @@ -77,18 +78,19 @@ n)) (define (recent-changes n) (map (lambda (rev) - `(li ,(rellink (string-append "admin/changes/" (car rev)) + `(li ,(rellink `("admin" "changes" ,(car rev)) (caddr rev)))) (git-rev-list "refs/heads/master" n))) - (rcons* request - 'body `(,(sidebar-ul `((li (h2 "posts " ,(rellink "admin/posts" ">>")) - (ul ,@(post-links 5))) - (li (h2 "changes" ,(rellink "admin/changes" ">>")) - (ul ,(recent-changes 5))))) - (h2 "new post") - ,(post-editing-form #f)))))) + (respond `(,(sidebar-ul `((li (h2 "posts " ,(rellink '("admin" "posts") + ">>")) + (ul ,@(post-links 5))) + (li (h2 "changes" ,(rellink '("admin" "changes") + ">>")) + (ul ,(recent-changes 5))))) + (h2 "new post") + ,(post-editing-form #f)))))) -(define (page-admin-posts request index) +(define (page-admin-posts request body index) (with-authentication request (lambda () @@ -96,100 +98,94 @@ (map (lambda (post) `(h3 ,(admin-post-link post))) (assq-ref index 'posts))) - (rcons* request - 'body `((h1 "all your posts are belong to tekuti") - ,@(post-headers)))))) + (respond `((h1 "all your posts are belong to tekuti") + ,@(post-headers)))))) -(define (page-admin-post request index key) +(define (page-admin-post request body index key) (with-authentication request (lambda () (let ((post (post-from-key (assq-ref index 'master) key #t))) - (rcons* request - 'body `((h1 ,(post-title post)) - ,(post-editing-form post))))))) + (respond `((h1 ,(post-title post)) + ,(post-editing-form post))))))) -(define (page-admin-new-post request index) +(define (page-admin-new-post request body index) (with-authentication request (lambda () - (let ((post (make-new-post (request-form-data request)))) - (rcons* (admin-post-redirect request post) - 'body `((p "redirecting..."))))))) + (let ((post (make-new-post (request-form-data request body)))) + (respond `((p "redirecting...")) + #:redirect (admin-post-url post)))))) -(define (page-admin-modify-post request index key) +(define (page-admin-modify-post request body index key) (with-authentication request (lambda () - (let ((post (modify-post key (request-form-data request)))) - (rcons* (admin-post-redirect request post) - 'body `((p "redirecting..."))))))) + (let ((post (modify-post key (request-form-data request body)))) + (respond `((p "redirecting...")) + #:redirect (admin-post-url post)))))) -(define (page-admin-changes request index) +(define (page-admin-changes request body index) (with-authentication request (lambda () - (let ((revs (git-rev-list (or (assoc-ref (rref request 'query '()) - "start") - "refs/heads/master") + (let ((revs (git-rev-list (request-query-ref request "start" + "refs/heads/master") 10))) - (rcons* request - 'body `((h2 "recent changes") - ,@(map (lambda (rev) - `(div (h3 ,(rellink (string-append "admin/changes/" - (car rev)) - (caddr rev))) - ,(timestamp->rfc822-date (cadr rev)))) - revs) - (h3 ,(rellink (string-append "admin/changes/?start=" (caar (last-pair revs))) - "more" )))))))) + (respond `((h2 "recent changes") + ,@(map (lambda (rev) + `(div (h3 ,(rellink `("admin" "changes" ,(car rev)) + (caddr rev))) + ,(timestamp->rfc822-date (cadr rev)))) + revs) + (h3 ,(rellink '("admin" "changes") + "more" + #:query + `(("start" . ,(caar (last-pair revs)))))))))))) -(define (page-admin-change request index sha1) +(define (page-admin-change request body index sha1) (with-authentication request (lambda () (let ((commit (parse-commit sha1))) - (rcons* request - 'body `((h2 ,(assq-ref commit 'message)) - (p "Committed on " - ,(timestamp->rfc822-date - ;; needlessly goes to git again... - (commit-utc-timestamp sha1))) - (pre ,(git "diff-tree" "-M" "-p" sha1)) - (form (@ (action ,(relurl "admin/revert-change/" sha1)) - (method "POST")) - (input (@ (type "submit") (value "Undo this change")))))))))) + (respond `((h2 ,(assq-ref commit 'message)) + (p "Committed on " + ,(timestamp->rfc822-date + ;; needlessly goes to git again... + (commit-utc-timestamp sha1))) + (pre ,(git "diff-tree" "-M" "-p" sha1)) + (form (@ (action ,(relurl `("admin" "revert-change" ,sha1))) + (method "POST")) + (input (@ (type "submit") (value "Undo this change")))))))))) -(define (page-admin-revert-change request index sha1) +(define (page-admin-revert-change request body index sha1) (with-authentication request (lambda () (let ((new-master (git-revert "refs/heads/master" sha1))) - (rcons* (redirect request (relurl "admin")) - 'body `((h3 "Change reverted"))))))) + (respond `((h3 "Change reverted")) + #:redirect (relurl '("admin"))))))) -(define (page-index request index) - (rcons* request - 'body `(,(main-sidebar request index) - ,@(map (lambda (post) - (show-post post #f)) - (published-posts index 10))))) +(define (page-index request body index) + (respond `(,(main-sidebar request index) + ,@(map (lambda (post) + (show-post post #f)) + (published-posts index 10))))) -(define (page-show-post request index year month day post) +(define (page-show-post request body index year month day post) (cond ((post-from-key (assq-ref index 'master) (make-post-key year month day post)) => (lambda (post) - (rcons* request - 'title (string-append (post-title post) " -- " *title*) - 'body `(,(post-sidebar post index) - ,(show-post post #t))))) + (respond `(,(post-sidebar post index) + ,(show-post post #t)) + #:title (string-append (post-title post) " -- " *title*)))) (else - (page-not-found request index)))) + (page-not-found request body index)))) -(define (page-new-comment request index year month day name) - (let ((data (request-form-data request))) +(define (page-new-comment request body index year month day name) + (let ((data (request-form-data request body))) (cond ((post-from-key (assq-ref index 'master) (make-post-key year month day name)) @@ -197,20 +193,19 @@ (cond ((bad-new-comment-post? data) => (lambda (reason) - (rcons* request - 'body `((p "Bad post data: " ,(pk reason)))))) + (respond `((p "Bad post data: " ,(pk reason)))))) (else (let ((comment (make-new-comment (post-key post) (post-title post) data))) ;; nb: at this point, `post' is out-of-date - (rcons* (redirect request (post-url post "#comments")) - 'title "comment posted" - 'body `((p "Comment posted, thanks.")))))))) + (respond `((p "Comment posted, thanks.")) + #:redirect (post-url post #:fragment "comments") + #:title "comment posted")))))) (else - (page-not-found request index))))) + (page-not-found request body index))))) ;; fixme exception handling for input -(define (page-archives request index year month day) +(define (page-archives request body index year month day) (let ((year (and=> year string->number)) (month (and=> month string->number)) (day (and=> day string->number))) @@ -230,17 +225,15 @@ (let lp ((posts (published-posts index -1))) (cond ((or (null? posts) (too-early? (car posts))) - (rcons* request - 'title *title* - 'body `((h1 "No posts found") - (p "No posts were found in the specified period.")))) + (respond `((h1 "No posts found") + (p "No posts were found in the specified period.")) + #:title *title*)) ((early-enough? (car posts)) (let lp ((posts posts) (new-header (make-date-header #t)) (out '())) (cond ((or (null? posts) (too-early? (car posts))) - (rcons* request - 'title (string-append "archives -- " *title*) - 'body (reverse out))) + (respond (reverse out) + #:title (string-append "archives -- " *title*))) ((new-header (car posts)) => (lambda (sxml) (lp (cdr posts) (make-date-header (car posts)) @@ -249,80 +242,74 @@ (lp (cdr posts) new-header (cons `(p ,(post-link (car posts))) out)))))) (else (lp (cdr posts)))))))) -(define (page-search request index) - (let* ((string (or (assoc-ref (request-form-data request) "string") "")) +(define (page-search request body index) + (let* ((string (or (assoc-ref (request-form-data request body) "string") "")) (posts (find-posts-matching string index))) - (rcons* request - 'body `((h2 "search results: \"" ,string "\"") - ,@(if (null? posts) - `((p "No posts matched your search string.")) - (map (lambda (post) - `(p ,(post-link post))) - posts)))))) + (respond `((h2 "search results: \"" ,string "\"") + ,@(if (null? posts) + `((p "No posts matched your search string.")) + (map (lambda (post) + `(p ,(post-link post))) + posts)))))) -(define (page-show-tags request index) - (rcons* request - 'title (string-append "all tags -- " *title*) - 'body `((div (@ (id "tag-cloud")) - (h2 "all tags") - ,@(tag-cloud (top-tags index 200)))))) +(define (page-show-tags request body index) + (respond `((div (@ (id "tag-cloud")) + (h2 "all tags") + ,@(tag-cloud (top-tags index 200)))) + #:title (string-append "all tags -- " *title*))) -(define (page-show-tag request index tag) +(define (page-show-tag request body index tag) (let* ((tags (assq-ref index 'tags)) (posts (map (lambda (key) (post-from-key (assq-ref index 'master) key)) (hash-ref tags tag '())))) (if (pair? posts) - (rcons* request - 'title (string-append "posts tagged \"" tag "\"") - 'body `((h2 "posts tagged \"" ,tag "\"") - ,@(map (lambda (post) `(p ,(post-link post))) - posts) - ,(related-tag-cloud tag index))) - (rcons* request - 'status 404 - 'body `((h2 "Unknown tag " ,tag) - (p "No posts were found tagged as \"" ,tag "\".")))))) + (respond `((h2 "posts tagged \"" ,tag "\"") + ,@(map (lambda (post) `(p ,(post-link post))) + posts) + ,(related-tag-cloud tag index)) + #:title (string-append "posts tagged \"" tag "\"")) + (respond `((h2 "Unknown tag " ,tag) + (p "No posts were found tagged as \"" ,tag "\".")) + #:status 404)))) -(define (page-debug request index) - (rcons* request - 'title "debug" - 'body `((p "hello world!") - (table - (tr (th "header") (th "value")) - ,@(map (lambda (pair) - `(tr (td ,(car pair)) (td ,(cdr pair)))) - (rref request 'headers)))))) +(define (page-debug request body index) + (respond `((p "hello world!") + (table + (tr (th "header") (th "value")) + ,@(map (lambda (pair) + `(tr (td (tt ,(with-output-to-string + (lambda () (display (car pair)))))) + (td (tt ,(with-output-to-string + (lambda () + (write (cdr pair)))))))) + (request-headers request)))) + #:title "debug")) -(define (page-not-found request index) - (rcons* (pk 'not-found request) - 'status 404 - 'body `((h1 "Page not found") - (p "Unknown path: " ,(rref request 'path-str))))) +(define (page-not-found request body index) + (respond `((h1 "Page not found") + (p "Unknown path: " + ,(request-relative-path-str (pk 'not-found request)))) + #:status 404)) -(define (page-feed-atom request index) +(define (page-feed-atom request body index) (let ((last-modified (let ((posts (published-posts index 1))) (and (pair? posts) (post-timestamp (car posts))))) - (server-name (request-server-name request))) + (server-name (or (request-host request) + (uri-host (request-uri request)) + *host*))) (cond - ((let ((since (assoc-ref (rref request 'headers '()) - "if-modified-since"))) - (and since (>= (rfc822-date->timestamp since) last-modified))) - (rcons* request - 'status 304 - 'doctype #f)) + ((let ((since (request-if-modified-since request))) + (and since (>= (date->timestamp since) last-modified))) + (respond #f #:status 304)) (else - (rcons* (if last-modified - (rpush 'output-headers (cons "Last-Modified" - (timestamp->rfc822-date - last-modified)) - request) - request) - 'doctype "" - 'content-type "application/atom+xml" - 'sxml (append (atom-header server-name last-modified) - (map - (lambda (post) - (atom-entry server-name post)) - (published-posts index 10)))))))) + (respond #f + #:last-modified (and=> last-modified timestamp->date) + #:doctype #f + #:content-type "application/atom+xml" + #:sxml (append (atom-header server-name last-modified) + (map + (lambda (post) + (atom-entry server-name post)) + (published-posts index 10)))))))) diff --git a/tekuti/request.scm b/tekuti/request.scm index 7e797ec..ad49508 100644 --- a/tekuti/request.scm +++ b/tekuti/request.scm @@ -25,126 +25,69 @@ ;;; Code: (define-module (tekuti request) - #:use-module ((srfi srfi-1) #:select (find-tail fold)) + #:use-module ((srfi srfi-1) #:select (find-tail)) #:use-module (tekuti match-bind) #:use-module (tekuti util) - #:use-module (tekuti url) + #:use-module (web uri) + #:use-module (web request) + #:use-module (rnrs bytevectors) #:use-module (tekuti config) #:use-module (tekuti base64) - #:use-module (rnrs bytevectors) - #:export (make-request rcons rcons* rpush rpush* rref let-request - request-path-case request-authenticated? - request-form-data request-server-name)) - -(define (header-ref headers key default) - (let ((pair (assoc key headers))) - (if pair - (cdr pair) - default))) + #:export (request-relative-path + request-relative-path-str + request-query-ref + request-path-case + request-authenticated? + request-form-data)) (define (parse-www-form-urlencoded str) (map (lambda (piece) (let ((equals (string-index piece #\=))) (if equals - (cons (url:decode (substring piece 0 equals)) - (url:decode (substring piece (1+ equals)))) - (cons (url:decode piece) "")))) + (cons (uri-decode (substring piece 0 equals)) + (uri-decode (substring piece (1+ equals)))) + (cons (uri-decode piece) "")))) (string-split str #\&))) -(define *request-initializers* - `((path . ,(lambda (r) - (let ((private-url-path (url:path-split *private-url-base*)) - (path (header-ref (rref r 'headers '()) - "url" *private-url-base*))) - (let* ((tail (list-head-match private-url-path - (url:path-split path) - (length private-url-path)))) - (or tail (error "unexpected path" path *private-url-base*)) - tail)))) - (path-str . ,(lambda (r) - (url:path-join (rref r 'path '())))) - (query . ,(lambda (r) - (or (and=> (url:query-part - (header-ref (rref r 'headers '()) "url" "")) - parse-www-form-urlencoded) - '()))) - (method . ,(lambda (r) - (header-ref (rref r 'headers '()) "method" "GET"))))) - -(define-syntax let-request - (lambda (stx) - (define (make-binding b) - (syntax-case b () - ((id option ...) - (identifier? #'id) - #'(id (rref request-var 'id option ...))) - (id - (identifier? #'id) - #'(id (rref request-var 'id))))) - (syntax-case stx () - ((_ request (binding ...) body ...) - (with-syntax (((binding ...) (map make-binding #'(binding ...)))) - #'(let ((request-var request)) - (let (binding ...) - body ...))))))) - -(define (request-form-data request) - (let-request request (headers post-data) - (if (string-null? post-data) - '() - (let ((content-type (assoc-ref headers "content-type"))) - (cond - ((equal? content-type "application/x-www-form-urlencoded") - (parse-www-form-urlencoded post-data)) - (else - (error "bad content-type" content-type))))))) - -(define (make-request . keys-and-values) - (fold (lambda (pair r) - (rcons (car pair) ((cdr pair) r) r)) - (apply rcons* '() keys-and-values) - *request-initializers*)) +(define (request-relative-path r) + (let ((base *private-path-base*) + (path (split-and-decode-uri-path (uri-path (request-uri r))))) + (let ((tail (list-head-match base path (length base)))) + (or tail + (error "unexpected path" path base))))) -(define (rcons k v request) - (or (symbol? k) (error "request keys should be symbols")) - (acons k v request)) +(define (request-relative-path-str r) + (encode-and-join-uri-path (request-relative-path r))) -(define (rcons* request . keys-and-values) - (let lp ((request request) (kv keys-and-values)) - (if (null? kv) - request - (lp (rcons (car kv) (cadr kv) request) (cddr kv))))) - -(define (rpush k v request) - (rcons k (cons v (rref request k '())) request)) - -(define (rpush* request . keys-and-values) - (let lp ((request request) (kv keys-and-values)) - (if (null? kv) - request - (lp (rpush (car kv) (cadr kv) request) (cddr kv))))) - -(define* (rref request k #:optional (default #f) #:key (default-proc #f)) - (let ((pair (assq k request))) +(define (request-query-ref r param default) + (let ((q (uri-query (request-uri r)))) (cond - (pair (cdr pair)) - (default-proc (default-proc request k)) + ((and q (assoc param (parse-www-form-urlencoded q))) => cdr) (else default)))) +(define (request-form-data request body) + (if (or (not body) (string-null? body)) + '() + (let ((content-type (request-content-type request))) + (cond + ((equal? content-type '("application" "x-www-form-urlencoded")) + (parse-www-form-urlencoded body)) + (else + (error "bad content-type" content-type)))))) + ;; danger here, regarding the optional alternate clauses... (define (request-authenticated? request) - (let ((headers (rref request 'headers '()))) - (let ((auth (assoc-ref headers "authorization"))) - (and auth - (match-bind "^Basic ([A-Za-z0-9+/=]*)$" auth (_ b64) - (match-bind "^([^:]*):(.*)$" - (utf8->string (base64-decode b64)) - (_ user pass) - (and (equal? user *admin-user*) - (equal? pass *admin-pass*)) - #f) - #f))))) + (let ((auth (request-authorization request))) + (and auth + (match-bind "^Basic ([A-Za-z0-9+/=]*)$" auth (_ b64) + (match-bind "^([^:]*):(.*)$" + (utf8->string (base64-decode b64)) + (_ user pass) + (and (equal? user *admin-user*) + (equal? pass *admin-pass*)) + #f) + #f)))) (define-syntax path-proc-case (lambda (stx) @@ -191,22 +134,10 @@ #'(let ((path-var path)) (cond cond-clause ...))))))) -(define (rcons*-fold request . keys-and-procs) - (foldn (lambda (request k proc) - (rcons k (proc request) request)) - 2 request keys-and-procs)) - (define-syntax request-path-case (syntax-rules () ((_ request clause ...) - (path-proc-case - (let-request request (method path) - (cons method path)) - clause ...)))) - -(define (request-server-name request) - (let ((headers (rref request 'headers))) - (or (assoc-ref headers "host") - (assoc-ref headers "server-ip-addr")))) - - + (let ((r request)) + (path-proc-case + (cons (symbol->string (request-method r)) (request-relative-path r)) + clause ...))))) diff --git a/tekuti/web.scm b/tekuti/web.scm index 437ffd8..ae190a8 100644 --- a/tekuti/web.scm +++ b/tekuti/web.scm @@ -1,5 +1,5 @@ ;; Tekuti -;; Copyright (C) 2008 Andy Wingo <wingo at pobox dot com> +;; Copyright (C) 2008, 2010 Andy Wingo <wingo at pobox dot com> ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as @@ -25,54 +25,13 @@ ;;; Code: (define-module (tekuti web) - #:use-module (sxml simple) - #:use-module (sxml transform) - #:use-module (tekuti url) + #:use-module (web server) #:use-module (tekuti request) - #:use-module (tekuti template) + #:use-module (tekuti index) #:use-module (tekuti page) - #:use-module (srfi srfi-1) - #:export (header-ref - handle-request)) + #:use-module (tekuti config) + #:export (main-loop)) -(define *status-names* - '((200 . "OK") - (201 . "Created") - (303 . "See Other") - (304 . "Not Modified") - (401 . "Unauthorized") - (404 . "Not Found") - (500 . "Internal Server Error"))) - -(define (status->string status) - (format #f "~a ~a" status (or (assv-ref *status-names* status) - "Unknown Error"))) - -(define xhtml-doctype - (string-append - "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" " - "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n")) - -(define (make-output request) - (lambda (port) - (let ((sxml (or (rref request 'sxml #f) - (templatize request)))) - (if sxml - (begin (display (rref request 'doctype "") port) - (sxml->xml sxml port)) - (display "" port))))) - -(define (finalize request) - ;; update output headers - ;; templatize body - (rpush* (rcons 'output (make-output request) request) - 'output-headers - (cons "Status" (status->string (rref request 'status 200))) - 'output-headers - (cons "Content-Type" - (string-append (rref request 'content-type "text/html") - "; charset=utf-8")))) - (define (choose-handler request) (request-path-case request @@ -98,6 +57,17 @@ ((GET debug) page-debug) (else page-not-found))) -(define (handle-request request index) - (let ((handler (choose-handler request))) - (finalize (handler (rcons 'doctype xhtml-doctype request) index)))) +(define (handler request body index) + (let ((index (maybe-reindex index))) + (call-with-values (lambda () + ((choose-handler request) request body (cdr index))) + (lambda (response body) + (values response body index))))) + +;; The seemingly useless lambda is to allow for `handler' to be +;; redefined at runtime. +(define (main-loop) + (run-server (lambda (r b i) (handler r b i)) + *server-impl* + *server-impl-args* + (read-index))) |