big change to use new (web server) infrastructure

Change to use (web server) instead of our own loop. This also means that
requests are request objects from (web request), and responses are from
(web response).

* tekuti/boot.scm (boot): Run the main loop from (tekuti web).

* tekuti/config.scm (*port*, *backlog*, *public-url-base*)
  (*private-url-base*): Remove extraneous config vars.

* tekuti/mod-lisp.scm: Rewrite to be a (web server) server-impl. Not
  tested very well.

* tekuti/page-helpers.scm (respond): New procedure, now the primary way
  to respond to a request.
  (relurl, rellink): Take path components as a list, and encode the
  parts when making the resulting URL. All callers changed.

* tekuti/page.scm: Change all handlers to take an additional `body'
  argument, to respond using `respond', and to use the new `relurl' /
  `rellink' protocol.

* tekuti/request.scm: Eviscerate, leaving only pieces that deal in
  request objects from `(web request)'.

* tekuti/web.scm: Update to use (weeb server).

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)))