modularization

10 files changed, 787 insertions, 428 deletions

diff --git a/src/tekuti b/src/tekuti
index c68b12d..c3dccfa 100755
--- a/src/tekuti
+++ b/src/tekuti
@@ -29,437 +29,43 @@ exec guile $GUILE_FLAGS -l $0 -e main "$@"
 ;;; Code:
 
 ;;hack!
-(use-modules (ice-9 regex))
 
-(use-modules (ice-9 rdelim)
-             (ice-9 popen)
-             (srfi srfi-1)
-             (sxml simple)
-             (tekuti url)
-             (match-bind)
-             (sxml transform))
 (debug-enable 'backtrace)
-
-(define (expanduser path)
-  (let ((parts (string-split path #\/)))
-    (if (eqv? (string-ref (car parts) 0) #\~)
-        (let ((user (if (= (string-length (car parts)) 1)
-                        (cuserid)
-                        (substring (car parts) 1))))
-          (string-join (cons (passwd:dir (getpwnam user)) (cdr parts)) "/"))
-        path)))
-
-(define *host* "127.0.0.1")
-(define *port* 8081)
-(define *backlog* 5)
-(define *git-dir* (expanduser "~/blog.git"))
-(define *git* "git")
-(define *public-url-base* "/")
-(define *private-url-base* "/blog/")
-(define *debug* #t)
-
-(define (dbg fmt . args)
-  (apply format (current-error-port) fmt args))
-
-(define-macro (unwind-protect form . cleanups)
-  `(dynamic-wind (lambda () #t)
-       (lambda () ,form)
-       (lambda () ,@cleanups)))
-
-(define-macro (with-pipe var make-pipe . body)
-  `(let ((,var ,make-pipe))
-     (unwind-protect
-      (begin ,@body)
-      (let ((ret (close-pipe ,var)))
-        (if (not (eq? (status:exit-val ret) 0))
-            (throw 'pipe-error ,var ret))))))
-
-(define (git . args)
-  (with-pipe
-   pipe (apply open-pipe* OPEN_READ *git* "--bare" args)
-   (read-delimited "" pipe)))
-
-;; true badness
-(define (git/input+env input env . args)
-  (let* ((template (string-copy "/tmp/tekutiXXXXXX"))
-         (tmp (mkstemp! template)))
-    (display input tmp)
-    (close tmp)
-    (let ((cmd (string-join `("env" ,@env ,*git* "--bare" ,@args "<" ,template) " ")))
-      (display cmd)(newline)
-      (unwind-protect
-       (with-pipe
-        pipe (open-pipe* OPEN_BOTH "/bin/sh" "-c"
-                         (string-join `("env" ,@env ,*git* "--bare" ,@args "<" ,template) " "))
-        (read-delimited "" pipe))
-       (delete-file template)))))
-
-(define (is-dir? path)
-  (catch 'system-error
-         (lambda () (eq? (stat:type (stat path)) 'directory))
-         (lambda args #f)))
-
-(define (ensure-git-repo)
-  (if (not (is-dir? *git-dir*))
-      (begin
-        (mkdir *git-dir*)
-        (chdir *git-dir*)
-        (git "init"))
-      (chdir *git-dir*)))
-
-(define (strip-headers socket)
-  (define (read-line*)
-    (let ((line (read-line socket)))
-      (if (eof-object? line)
-          (error "unexpected eof")
-          line)))
-  (let lp ((keys '()) (values '()))
-    (let ((k (read-line*)))
-      (if (string=? k "end")
-          (reverse (map cons keys values))
-          (lp (cons k keys) (cons (read-line*) values))))))
-
-(define (output-headers headers port)
-  (for-each
-   (lambda (k v)
-     (format port "~a\n~a\n" k v))
-   (map car headers) (map cdr headers))
-  (display "end\n" port))
-
-(define-macro (let-headers headers bindings . body)
-  (let ((headers-var (gensym)))
-    `(let ((,headers-var ,headers))
-       (let (,@(map (lambda (binding)
-                      `(,(car binding)
-                        (or (assoc-ref ,headers-var ,(cadr binding))
-                            (error "Missing header:" ,(cadr binding)))))
-                    bindings))
-         ,@body))))
-
-(define (page-debug headers)
-  `(html (head (title "hello"))
-         (body (p "hello world!")
-               (table
-                (tr (th "header") (th "value"))
-                ,@(map (lambda (pair)
-                         `(tr (td ,(car pair)) (td ,(cdr pair))))
-                       headers)))))
-
-(define (visible-error . html-body)
-  (throw 'visible-error 404 html-body))
-
-(define (page-not-found path)
-  (throw 'html-error 404 path))
-
-(define (url-path-split path)
-  (filter (lambda (x) (not (string-null? x)))
-          (map url:decode (string-split path #\/))))
-
-(define-macro (url-path-case method path . clauses)
-  (define (optional-argument arg)
-    (let ((len (string-length arg)))
-      (and (eqv? (string-ref arg (1- len)) #\?)
-           (substring arg 0 (1- len)))))
-  (let ((method-sym (gensym)) (path-parts (gensym)))
-    (define (process-clauses)
-      (map (lambda (clause)
-             (let ((pattern (car clause)) (body (cdr clause)))
-               (cond
-                ((eq? pattern 'else)
-                 clause)
-                (else
-                 (let* ((method-match (car pattern))
-                        (parts-match (map symbol->string (cdr pattern)))
-                        (nargs (length parts-match))
-                        (opt (or (find-tail optional-argument parts-match) '()))
-                        (nopt (length opt))
-                        (nreq (- nargs nopt)))
-                   (cond
-                    ((null? opt)
-                     `((and (eq? ,method-sym ',method-match)
-                            (equal? ,path-parts ',parts-match))
-                       ,@body))
-                    (else
-                     `((and (eq? ,method-sym ',method-match)
-                            (equal? (list-head ,path-parts ,nreq)
-                                    ',(list-head parts-match nreq))
-                            (< (length ,path-parts) ,nargs))
-                       (apply
-                        (lambda ,(map string->symbol (map optional-argument opt))
-                          ,@body)
-                        (let ((tail (list-tail ,path-parts ,nreq)))
-                          (append tail (make-list (- ,nopt (length tail)) #f))))))))))))
-           clauses))
-    `(let ((,method-sym (string->symbol ,method))
-           (,path-parts (url-path-split ,path)))
-       (cond ,@(process-clauses)))))
-
-(define-macro (url-relative-path-case method path . clauses)
-  (let ((infix (map string->symbol (url-path-split *private-url-base*))))
-    (define (munge-clause clause)
-      (cond
-       ((eq? (car clause) 'else) clause)
-       (else
-        (let ((method (caar clause))
-              (parts (cdar clause))
-              (body (cdr clause)))
-          `((,method ,@infix ,@parts) ,@body)))))
-    `(url-path-case ,method ,path
-                    ,@(map munge-clause clauses))))
-
-(define (unimplemented . args)
-  (apply throw 'unimplemented args))
-
-(use-modules (scheme session))
-(use-modules (match-bind))
-
-;;(putenv "GIT_DIR=/home/wingo/blog.git")
-(define-macro (match-lines string pattern bindings expr)
-  (let ((line (gensym)) (seed (gensym)))
-    `(fold
-      (lambda (,line ,seed)
-        (match-bind ,pattern ,line ,bindings
-                    (cons ,expr ,seed)
-                    ,seed))
-      '() (string-split ,string #\newline))))
-
-(define (git-ls-tree treeish path)
-  (match-lines (git "ls-tree" treeish (or path "."))
-               "^(.+) (.+) (.+)\t(.+)$" (_ mode type object name)
-               (list mode type object name)))
-
-(define (git-ls-subdirs treeish path)
-  (match-lines (git "ls-tree" treeish (or path "."))
-               "^(.+) tree (.+)\t(.+)$" (_ mode object name)
-               (cons name object)))
-
-(define (dsu-sort list key less)
-  (map cdr
-       (stable-sort (map (lambda (x) (cons (key x) x)) list)
-                    (lambda (x y) (less (car x) (car y))))))
-
-(define (all-published-posts master)
-  (define (timestamp x)
-    (post-timestamp (cdr x)))
-  (dsu-sort
-   (filter timestamp (git-ls-subdirs master #f))
-   timestamp
-   <))
-
-(define (post-metadata sha1)
-  (match-lines (git "cat-file" "blob" (string-append sha1 ":" "metadata"))
-               "^([^: ]+): +(.*)$" (_ k v)
-               (cons (string->symbol k) v)))
-
-(define (post-timestamp sha1)
-  (and=> (assq-ref (post-metadata sha1) 'timestamp)
-         string->number))
-
-(define (post-categories sha1)
-  (or (and=> (assq-ref (post-metadata sha1) 'categories)
-             (lambda (x) (map string-trim-both (string-split x #\,))))
-      '()))
-             
-(define (comment-metadata sha1)
-  (match-lines (git "cat-file" "blob" (string-append sha1 ":" "metadata"))
-               "^([^: ]+): +(.*)$" (_ k v)
-               (cons (string->symbol k) v)))
-
-(define (comment-timestamp sha1)
-  (and=> (assq-ref (comment-metadata sha1) 'timestamp)
-         string->number))
-
-(define (post-comments sha1)
-  (dsu-sort
-   (map cdr (git-ls-subdirs sha1 "comments/"))
-   comment-timestamp
-   <))
-
-(define (parse-commit commit)
-  (let ((text (git "cat-file" "commit" commit)))
-    (match-bind
-     "\n\n(.*)$" text (_ message)
-     (acons
-      'message message
-      (match-lines (substring text 0 (- (string-length text) (string-length _)))
-                   "^([^ ]+) (.*)$" (_ k v)
-                   (cons (string->symbol k) v))))))
-
-(define (commit-utc-timestamp commit)
-  (match-bind
-   "^(.*) ([0-9]+) ([+-][0-9]+)" (assq-ref (parse-commit commit) 'committer)
-   (_ who ts tz)
-   (let ((ts (string->number ts)) (tz (string->number tz)))
-     (- ts (* (+ (* (quotient tz 100) 60) (remainder tz 100)) 60)))))
-
-(define (commit-parents commit)
-  (map cdr
-       (filter
-        (lambda (x) (eq? (car x) 'parent))
-        (parse-commit commit))))
-
-(define (build-comment-skeleton comments)
-  (fold (lambda (sha1 parent)
-          (let* ((ts (comment-timestamp sha1))
-                 (env (list "GIT_COMMMITTER=tekuti"
-                            ;; this quoting is a hack
-                            (format #f "'GIT_COMMITTER_DATE=~a +0100'" ts)
-                            (format #f "'GIT_AUTHOR_DATE=~a +0100'" ts))))
-            (string-trim-both
-             (apply git/input+env "comment\n" env "commit-tree" sha1
-                    (if parent (list "-p" parent) '())))))
-        #f
-        comments))
-
-(define (build-post-skeleton master posts)
-  (fold (lambda (sha1 parent)
-          (let* ((ts (post-timestamp sha1))
-                 (comments (build-comment-skeleton (post-comments sha1)))
-                 (env (list "GIT_COMMMITTER=tekuti"
-                            ;; this quoting is a hack
-                            (format #f "'GIT_COMMITTER_DATE=~a +0100'" ts)
-                            (format #f "'GIT_AUTHOR_DATE=~a +0100'" ts))))
-            (string-trim-both
-             (apply git/input+env "post\n" env "commit-tree" sha1
-                    "-p" master
-                    (append (if parent (list "-p" parent) '())
-                            (if comments (list "-p" comments) '()))))))
-        #f
-        (map cdr posts)))
-
-(define (reindex-posts master)
-  (build-post-skeleton master (all-published-posts master)))
-
-(define (hash-push! h key value)
-  (let ((handle (hash-create-handle! h key '())))
-    (set-cdr! handle (cons value (cdr handle)))))
-
-(define (make-tree alist)
-  (string-trim-both
-   (git/input+env (string-join
-                   (map (lambda (pair)
-                          (let ((name (car pair)) (sha (cdr pair)))
-                            (format #f "040000 tree ~a\t~a" sha name)))
-                        alist)
-                   "\n" 'suffix)
-                  '()
-                  "mktree")))
-
-(define (compute-categories posts)
-  (let ((hash (make-hash-table)))
-    (for-each
-     (lambda (post-pair)
-       (for-each
-        (lambda (cat)
-          (hash-push! hash cat post-pair))
-        (post-categories (cdr post-pair))))
-     posts)
-    hash))
-
-(define (build-categories-tree master posts)
-  (if (null? posts)
-      #f
-      (let* ((hash (compute-categories posts))
-             (tree (make-tree (hash-map->list
-                               (lambda (k v) (cons k (make-tree v)))
-                               hash)))
-             (ts (commit-utc-timestamp master))
-             (env (list "GIT_COMMMITTER=tekuti"
-                        ;; this quoting is a hack
-                        (format #f "'GIT_COMMITTER_DATE=~a +0000'" ts)
-                        (format #f "'GIT_AUTHOR_DATE=~a +0000'" ts))))
-        (string-trim-both
-         (git/input+env "categories\n" env "commit-tree" tree
-                        "-p" master))))) ;; FIXME: keep history?
-
-(define (reindex-categories master)
-  (build-categories-tree master (all-published-posts master)))
-
-(define (fetch-heads master)
-  (map (lambda (spec)
-         (let ((ref (car spec)) (reindex (cdr spec)))
-           (let ((head (false-if-exception
-                        (string-trim-both (git "rev-parse" (car spec))))))
-             (cons
-              ref
-              (if (and head (member master (commit-parents head)))
-                  head
-                  (and=> (reindex master)
-                    (lambda (new)
-                      (if (not (false-if-exception 
-                                (if head
-                                    (git "update-ref" ref new head)
-                                    (git "branch" ref new))))
-                          (dbg "couldn't update ref ~a to ~a" ref new))
-                      new)))))))
-       `(("posts" . ,reindex-posts)
-         ("categories" . ,reindex-categories))))
+(use-modules (tekuti git)
+             (tekuti page)
+             (tekuti util)
+             (tekuti post)
+             (tekuti categories)
+             (tekuti mod-lisp)
+             (tekuti web))
 
 (define (handle-request headers post-data)
-  (let-headers
-   headers ((method "method") (path "url"))
-   (url-relative-path-case
-    method path
-    ((POST admin new-post)
-     (unimplemented 'new-post))
-    ((POST admin modify-post)
-     (unimplemented 'modify-post))
-    ((POST admin new-comment)
-     (unimplemented 'new-comment))
-    ((POST admin delete-comment)
-     (unimplemented 'delete-comment))
-    ((POST admin delete-post)
-     (unimplemented 'delete-post))
-    ((GET)
-     (unimplemented 'index))
-    ((GET archives year? month? day? post?)
-     (unimplemented 'archives))
-    ((GET debug)
-     (page-debug headers))
-    ((POST search)
-     (unimplemented 'search))
-    (else (page-not-found path)))))
+  (let ((heads (fetch-heads `(posts . ,reindex-posts)
+                            `(categories . ,reindex-categories))))
+    (let-headers
+     headers ((method "method") (path "url"))
+     (url-relative-path-case
+      method path
+      ((POST admin new-post)
+       (unimplemented 'new-post))
+      ((POST admin modify-post)
+       (unimplemented 'modify-post))
+      ((POST admin new-comment)
+       (unimplemented 'new-comment))
+      ((POST admin delete-comment)
+       (unimplemented 'delete-comment))
+      ((POST admin delete-post)
+       (unimplemented 'delete-post))
+      ((GET)
+       (unimplemented 'index))
+      ((GET archives year? month? day? post?)
+       (unimplemented 'archives))
+      ((GET debug)
+       (page-debug headers))
+      ((POST search)
+       (unimplemented 'search))
+      (else (page-not-found path))))))
      
-(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 (connection-received socket sockaddr)
-  (let ((headers (strip-headers socket))
-        (post-data "")) ;; blocks: (read-delimited "" socket)))
-
-    (dbg "~a" headers)
-    (catch #t
-           (lambda ()
-             (let ((sxml (handle-request headers post-data)))
-               (output-headers '(("Status" . "200 OK")
-                                 ("Content-Type" . "text/html"))
-                               socket)
-               (display xhtml-doctype socket)
-               (sxml->xml sxml socket)))
-           (lambda args
-             (output-headers '(("Status" . "500 Internal Server Error")
-                               ("Content-Type" . "text/plain"))
-                             socket)
-             (write args socket)))
-             
-    (close-port socket)))
-
-(define (event-loop socket)
-  (let ((master (string-trim-both (git "rev-parse" "master"))))
-    (pk (fetch-heads master)))
-  (pk 'listening)
-  (bind socket AF_INET (inet-aton *host*) *port*)
-  (listen socket *backlog*)
-  (let lp ((pair (accept socket)))
-    (pk pair)
-    (connection-received (car pair) (cdr pair))
-    (pk 'done)
-    (lp (accept socket))))
-    
-(define (main)
+(define (main args)
   (ensure-git-repo)
-  (event-loop (socket PF_INET SOCK_STREAM 0)))
-
-(main)
+  (event-loop handle-request))
diff --git a/tekuti/categories.scm b/tekuti/categories.scm
new file mode 100644
index 0000000..fd97d76
--- /dev/null
+++ b/tekuti/categories.scm
@@ -0,0 +1,61 @@
+;; Tekuti
+;; Copyright (C) 2008 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   
+;; published by the Free Software Foundation; either version 3 of   
+;; the License, or (at your option) any later version.              
+;;                                                                  
+;; This program is distributed in the hope that it will be useful,  
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of   
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the    
+;; GNU General Public License for more details.                     
+;;                                                                  
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, contact:
+;;
+;; Free Software Foundation           Voice:  +1-617-542-5942
+;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
+;; Boston, MA  02111-1307,  USA       gnu@gnu.org
+
+;;; Commentary:
+;;
+;; This is the main script that will launch tekuti.
+;;
+;;; Code:
+
+(define-module (tekuti categories)
+  #:use-module (tekuti util)
+  #:use-module (tekuti post)
+  #:use-module (tekuti git)
+  #:export (reindex-categories))
+
+(define (compute-categories posts)
+  (let ((hash (make-hash-table)))
+    (for-each
+     (lambda (post-pair)
+       (for-each
+        (lambda (cat)
+          (hash-push! hash cat post-pair))
+        (post-categories (cdr post-pair))))
+     posts)
+    hash))
+
+(define (build-categories-tree master posts)
+  (if (null? posts)
+      #f
+      (let* ((hash (compute-categories posts))
+             (tree (make-tree (hash-map->list
+                               (lambda (k v) (cons k (make-tree v)))
+                               hash)))
+             (ts (commit-utc-timestamp master))
+             (env (list "GIT_COMMMITTER=tekuti"
+                        ;; this quoting is a hack
+                        (format #f "'GIT_COMMITTER_DATE=~a +0000'" ts)
+                        (format #f "'GIT_AUTHOR_DATE=~a +0000'" ts))))
+        (string-trim-both
+         (git/input+env "categories\n" env "commit-tree" tree
+                        "-p" master))))) ;; FIXME: keep history?
+
+(define (reindex-categories master)
+  (build-categories-tree master (all-published-posts master)))
diff --git a/tekuti/comment.scm b/tekuti/comment.scm
new file mode 100644
index 0000000..91f7ffe
--- /dev/null
+++ b/tekuti/comment.scm
@@ -0,0 +1,65 @@
+;; Tekuti
+;; Copyright (C) 2008 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   
+;; published by the Free Software Foundation; either version 3 of   
+;; the License, or (at your option) any later version.              
+;;                                                                  
+;; This program is distributed in the hope that it will be useful,  
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of   
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the    
+;; GNU General Public License for more details.                     
+;;                                                                  
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, contact:
+;;
+;; Free Software Foundation           Voice:  +1-617-542-5942
+;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
+;; Boston, MA  02111-1307,  USA       gnu@gnu.org
+
+;;; Commentary:
+;;
+;; This is the main script that will launch tekuti.
+;;
+;;; Code:
+
+;;hack!
+(define-module (tekuti comment)
+  #:use-module (tekuti git)
+  #:use-module (tekuti util)
+  #:use-module (srfi srfi-1)
+  #:export (comment-from-tree build-comment-skeleton))
+
+(use-modules (ice-9 regex))
+
+(use-modules (ice-9 rdelim)
+             (ice-9 popen)
+             (srfi srfi-1)
+             (sxml simple)
+             (tekuti url)
+             (match-bind)
+             (sxml transform))
+(debug-enable 'backtrace)
+
+(define *comment-spec*
+  `((timestamp ,string->number)))
+(define (comment-from-tree encoded-name sha1)
+  (acons 'encoded-name encoded-name
+         (parse-metadata (string-append sha1 ":" "metadata") *comment-spec*)))
+
+(define (comment-timestamp comment-alist)
+  (or (assq-ref x 'timestamp) #f))
+
+(define (build-comment-skeleton comments)
+  (fold (lambda (sha1 parent)
+          (let* ((ts (comment-timestamp sha1))
+                 (env (list "GIT_COMMMITTER=tekuti"
+                            ;; this quoting is a hack
+                            (format #f "'GIT_COMMITTER_DATE=~a +0100'" ts)
+                            (format #f "'GIT_AUTHOR_DATE=~a +0100'" ts))))
+            (string-trim-both
+             (git* (cons* "commit-tree" sha1 (if parent (list "-p" parent) '()))
+                   #:input "comment\n" #:env env))))
+        #f
+        comments))
diff --git a/tekuti/config.scm b/tekuti/config.scm
new file mode 100644
index 0000000..589eb37
--- /dev/null
+++ b/tekuti/config.scm
@@ -0,0 +1,39 @@
+;; Tekuti
+;; Copyright (C) 2008 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   
+;; published by the Free Software Foundation; either version 3 of   
+;; the License, or (at your option) any later version.              
+;;                                                                  
+;; This program is distributed in the hope that it will be useful,  
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of   
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the    
+;; GNU General Public License for more details.                     
+;;                                                                  
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, contact:
+;;
+;; Free Software Foundation           Voice:  +1-617-542-5942
+;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
+;; Boston, MA  02111-1307,  USA       gnu@gnu.org
+
+;;; Commentary:
+;;
+;; This is the main script that will launch tekuti.
+;;
+;;; Code:
+
+(define-module (tekuti config)
+  #:use-module (tekuti util)
+  #:export (*host* *port* *backlog* *git-dir* *git* *public-url-base*
+            *private-url-base* *debug*))
+
+(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* "/blog/")
+(define *debug* #t)
diff --git a/tekuti/git.scm b/tekuti/git.scm
new file mode 100644
index 0000000..0ebf26c
--- /dev/null
+++ b/tekuti/git.scm
@@ -0,0 +1,172 @@
+;; Tekuti
+;; Copyright (C) 2008 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   
+;; published by the Free Software Foundation; either version 3 of   
+;; the License, or (at your option) any later version.              
+;;                                                                  
+;; This program is distributed in the hope that it will be useful,  
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of   
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the    
+;; GNU General Public License for more details.                     
+;;                                                                  
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, contact:
+;;
+;; Free Software Foundation           Voice:  +1-617-542-5942
+;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
+;; Boston, MA  02111-1307,  USA       gnu@gnu.org
+
+;;; Commentary:
+;;
+;; This is the main script that will launch tekuti.
+;;
+;;; Code:
+
+(define-module (tekuti git)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 popen)
+  #:use-module (tekuti util)
+  #:use-module (tekuti config)
+  #:use-module (scheme kwargs)
+  #:use-module (match-bind)
+  #:use-module (ice-9 regex) ; hack
+  #:export (git git* ensure-git-repo git-ls-tree git-ls-subdirs
+            parse-metadata parse-commit commit-utc-timestamp
+            commit-parents make-tree fetch-heads))
+
+(define (call-with-pipe pipe proc)
+  (unwind-protect
+   (proc pipe)
+   (let ((ret (close-pipe pipe)))
+     (if (not (eq? (status:exit-val ret) 0))
+         (throw 'pipe-error proc ret)))))
+
+(define (call-with-temp-file contents proc)
+  (let* ((template (string-copy "/tmp/tekutiXXXXXX"))
+         (tmp (mkstemp! template)))
+    (display input tmp)
+    (close tmp)
+    (unwind-protect
+     (proc template)
+     (delete-file template))))
+
+(define/kwargs (git* args (input #f) (env '()))
+  ;; foolishness regarding env
+  (define (nyam-nyam-nyam pipe)
+    (read-delimited "" pipe))
+  (cond
+   (input
+    (call-with-temp-file
+     input
+     (lambda (tempname)
+       (let ((cmd (string-join `("env" ,@env ,*git* "--bare" ,@args "<" ,input) " ")))
+         (pk cmd)
+         (call-with-pipe
+          (open-pipe* OPEN_BOTH "/bin/sh" "-c" cmd)
+          nyam-nyam-nyam)))))
+   (else
+    (pk args)
+    (call-with-pipe
+     (apply open-pipe* OPEN_READ *git* "--bare" args)
+     nyam-nyam-nyam))))
+
+(define (git . args)
+  (git* args))
+
+(define (is-dir? path)
+  (catch 'system-error
+         (lambda () (eq? (stat:type (stat path)) 'directory))
+         (lambda args #f)))
+
+(define (ensure-git-repo)
+  (let ((d (expanduser *git-dir*)))
+    (if (not (is-dir? d))
+        (begin
+          (mkdir d)
+          (chdir d)
+          (git "init"))
+        (chdir d))))
+
+(define (git-ls-tree treeish path)
+  (match-lines (git "ls-tree" treeish (or path "."))
+               "^(.+) (.+) (.+)\t(.+)$" (_ mode type object name)
+               (list mode type object name)))
+
+(define (git-ls-subdirs treeish path)
+  (match-lines (git "ls-tree" treeish (or path "."))
+               "^(.+) tree (.+)\t(.+)$" (_ mode object name)
+               (cons name object)))
+
+(define (parse-metadata treeish . specs)
+  (filter
+   identity
+   (match-lines (git "cat-file" "blob" treeish)
+                "^([^: ]+): +(.*)$" (_ k v)
+                (let* ((k (string->symbol k))
+                       (parse (assq-ref k specs)))
+                  (if parse
+                      (catch 'parse-error
+                             (lambda ()
+                               (cons k (parse v)))
+                             (lambda args #f))
+                      (cons k v))))))
+
+(define (parse-commit commit)
+  (let ((text (git "cat-file" "commit" commit)))
+    (match-bind
+     "\n\n(.*)$" text (_ message)
+     (acons
+      'message message
+      (match-lines (substring text 0 (- (string-length text) (string-length _)))
+                   "^([^ ]+) (.*)$" (_ k v)
+                   (cons (string->symbol k) v))))))
+
+(define (commit-utc-timestamp commit)
+  (match-bind
+   "^(.*) ([0-9]+) ([+-][0-9]+)" (assq-ref (parse-commit commit) 'committer)
+   (_ who ts tz)
+   (let ((ts (string->number ts)) (tz (string->number tz)))
+     (- ts (* (+ (* (quotient tz 100) 60) (remainder tz 100)) 60)))))
+
+(define (commit-parents commit)
+  (map cdr
+       (filter
+        (lambda (x) (eq? (car x) 'parent))
+        (parse-commit commit))))
+
+(define (make-tree alist)
+  (string-trim-both
+   (git* '("mktree")
+         #:input (string-join
+                  (map (lambda (pair)
+                         (let ((name (car pair)) (sha (cdr pair)))
+                           (format #f "040000 tree ~a\t~a" sha name)))
+                       alist)
+                  "\n" 'suffix))))
+
+(define (git-rev-parse rev)
+  (string-trim-both (git "rev-parse" rev)))
+
+(define (fetch-heads . heads)
+  (let ((master (git-rev-parse "master")))
+    (acons
+     'master master
+     (map (lambda (spec)
+            (let ((ref (car spec)) (reindex (cdr spec)))
+              (let ((head (false-if-exception
+                           (git-rev-parse (car spec)))))
+                (cons
+                 ref
+                 (if (and head (member master (commit-parents head)))
+                     head
+                     (and=> (reindex master)
+                            (lambda (new)
+                              (if (not (false-if-exception 
+                                        (if head
+                                            (git "update-ref" ref new head)
+                                            (git "branch" ref new))))
+                                  (dbg "couldn't update ref ~a to ~a" ref new))
+                              new)))))))
+          heads))))
diff --git a/tekuti/mod-lisp.scm b/tekuti/mod-lisp.scm
new file mode 100644
index 0000000..613bda9
--- /dev/null
+++ b/tekuti/mod-lisp.scm
@@ -0,0 +1,93 @@
+;; Tekuti
+;; Copyright (C) 2008 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   
+;; published by the Free Software Foundation; either version 3 of   
+;; the License, or (at your option) any later version.              
+;;                                                                  
+;; This program is distributed in the hope that it will be useful,  
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of   
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the    
+;; GNU General Public License for more details.                     
+;;                                                                  
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, contact:
+;;
+;; Free Software Foundation           Voice:  +1-617-542-5942
+;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
+;; Boston, MA  02111-1307,  USA       gnu@gnu.org
+
+;;; Commentary:
+;;
+;; This is the main script that will launch tekuti.
+;;
+;;; Code:
+
+(define-module (tekuti mod-lisp)
+  #:use-module (ice-9 rdelim)
+  #:use-module (sxml simple)
+  #:use-module (sxml transform)
+  #:use-module (tekuti url)
+  #:use-module (tekuti util)
+  #:use-module (tekuti config)
+  #:export (event-loop))
+
+(define (read-headers socket)
+  (define (read-line*)
+    (let ((line (read-line socket)))
+      (if (eof-object? line)
+          (error "unexpected eof")
+          line)))
+  (let lp ((keys '()) (values '()))
+    (let ((k (read-line*)))
+      (if (string=? k "end")
+          (reverse (map cons keys values))
+          (lp (cons k keys) (cons (read-line*) values))))))
+
+(define (write-headers headers port)
+  (for-each
+   (lambda (k v)
+     (format port "~a\n~a\n" k v))
+   (map car headers) (map cdr headers))
+  (display "end\n" port))
+
+(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 (connection-received socket sockaddr handle-request)
+  (let ((headers (read-headers socket))
+        (post-data "")) ;; blocks: (read-delimited "" socket)))
+
+    (dbg "~a" headers)
+    (catch #t
+           (lambda ()
+             (let ((sxml (handle-request headers post-data)))
+               (write-headers '(("Status" . "200 OK")
+                                ("Content-Type" . "text/html"))
+                              socket)
+               (display xhtml-doctype socket)
+               (sxml->xml sxml socket)))
+           (lambda args
+             (write-headers '(("Status" . "500 Internal Server Error")
+                              ("Content-Type" . "text/plain"))
+                            socket)
+             (write args socket)))
+             
+    (close-port socket)))
+
+(define (event-loop handle-request)
+  (pk 'listening)
+  (let ((socket (socket PF_INET SOCK_STREAM 0)))
+    (bind socket AF_INET (inet-aton *host*) *port*)
+    (listen socket *backlog*)
+    (unwind-protect
+     (let lp ((pair (accept socket)))
+       (pk pair)
+       (connection-received (car pair) (cdr pair) handle-request)
+       (pk 'done)
+       (lp (accept socket)))
+     (shutdown socket 2))))
+
diff --git a/tekuti/page.scm b/tekuti/page.scm
new file mode 100644
index 0000000..06ff37a
--- /dev/null
+++ b/tekuti/page.scm
@@ -0,0 +1,37 @@
+;; Tekuti
+;; Copyright (C) 2008 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   
+;; published by the Free Software Foundation; either version 3 of   
+;; the License, or (at your option) any later version.              
+;;                                                                  
+;; This program is distributed in the hope that it will be useful,  
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of   
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the    
+;; GNU General Public License for more details.                     
+;;                                                                  
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, contact:
+;;
+;; Free Software Foundation           Voice:  +1-617-542-5942
+;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
+;; Boston, MA  02111-1307,  USA       gnu@gnu.org
+
+;;; Commentary:
+;;
+;; This is the main script that will launch tekuti.
+;;
+;;; Code:
+
+(define-module (tekuti page)
+  #:export (page-debug))
+
+(define (page-debug headers)
+  `(html (head (title "hello"))
+         (body (p "hello world!")
+               (table
+                (tr (th "header") (th "value"))
+                ,@(map (lambda (pair)
+                         `(tr (td ,(car pair)) (td ,(cdr pair))))
+                       headers)))))
diff --git a/tekuti/post.scm b/tekuti/post.scm
new file mode 100644
index 0000000..77dcf11
--- /dev/null
+++ b/tekuti/post.scm
@@ -0,0 +1,92 @@
+;; Tekuti
+;; Copyright (C) 2008 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   
+;; published by the Free Software Foundation; either version 3 of   
+;; the License, or (at your option) any later version.              
+;;                                                                  
+;; This program is distributed in the hope that it will be useful,  
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of   
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the    
+;; GNU General Public License for more details.                     
+;;                                                                  
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, contact:
+;;
+;; Free Software Foundation           Voice:  +1-617-542-5942
+;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
+;; Boston, MA  02111-1307,  USA       gnu@gnu.org
+
+;;; Commentary:
+;;
+;; This is the main script that will launch tekuti.
+;;
+;;; Code:
+
+(define-module (tekuti post)
+  #:use-module (srfi srfi-1)
+  #:use-module (match-bind)
+  #:use-module (tekuti util)
+  #:use-module (tekuti comment)
+  #:use-module (tekuti git)
+  #:use-module (srfi srfi-1)
+  #:export (reindex-posts post-categories all-published-posts))
+  
+;; introducing new assumption: post urls like yyyy/dd/mm/post; post dirnames the urlencoded post
+
+;; perhaps push this processing into post-from-tree
+(define (post-published? post-alist)
+  (equal? (assq-ref post-alist 'status) "published"))
+
+(define (post-timestamp post-alist)
+  (or (assq-ref x 'timestamp) #f))
+
+(define (post-categories post-alist)
+  (or (assq-ref x 'categories) '()))
+
+(define *post-spec*
+  `((timestamp ,string->number)
+    (categories ,(lambda (v) (map string-trim-both (string-split v #\,))))))
+
+(define (post-from-tree encoded-name sha1)
+  (acons 'url encoded-name
+         (parse-metadata (string-append sha1 ":" "metadata") *post-spec*)))
+
+(define (all-posts master)
+  (map (lambda (pair)
+         (post-from-tree (car pair) (cdr pair)))
+       (git-ls-subdirs master #f)))
+
+(define (all-published-posts master)
+  (dsu-sort
+   (filter post-published? (all-posts master))
+   post-timestamp
+   <))
+
+(define (post-comments sha1)
+  (dsu-sort
+   (map (lambda (pair)
+          (comment-from-tree (car pair) (cdr pair)))
+        (git-ls-subdirs sha1 "comments/"))
+   comment-timestamp
+   <))
+
+(define (build-post-skeleton master posts)
+  (fold (lambda (sha1 parent)
+          (let* ((ts (post-timestamp sha1))
+                 (comments (build-comment-skeleton (post-comments sha1)))
+                 (env (list "GIT_COMMMITTER=tekuti"
+                            ;; this quoting is a hack
+                            (format #f "'GIT_COMMITTER_DATE=~a +0100'" ts)
+                            (format #f "'GIT_AUTHOR_DATE=~a +0100'" ts))))
+            (string-trim-both
+             (git* `("commit-tree" ,sha1
+                     ,@(if parent (list "-p" parent) '())
+                     ,@(if comments (list "-p" comments) '()))
+                   #:input "post\n" #:env env))))
+        #f
+        (map cdr posts)))
+
+(define (reindex-posts master)
+  (build-post-skeleton master (all-published-posts master)))
diff --git a/tekuti/util.scm b/tekuti/util.scm
new file mode 100644
index 0000000..2019f55
--- /dev/null
+++ b/tekuti/util.scm
@@ -0,0 +1,65 @@
+;; Tekuti
+;; Copyright (C) 2008 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   
+;; published by the Free Software Foundation; either version 3 of   
+;; the License, or (at your option) any later version.              
+;;                                                                  
+;; This program is distributed in the hope that it will be useful,  
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of   
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the    
+;; GNU General Public License for more details.                     
+;;                                                                  
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, contact:
+;;
+;; Free Software Foundation           Voice:  +1-617-542-5942
+;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
+;; Boston, MA  02111-1307,  USA       gnu@gnu.org
+
+;;; Commentary:
+;;
+;; This is the main script that will launch tekuti.
+;;
+;;; Code:
+
+(define-module (tekuti util)
+  #:use-module (match-bind)
+  #:use-module (srfi srfi-1)
+  #:export (expanduser match-lines dbg unwind-protect dbg dsu-sort hash-push!))
+
+(define (expanduser path)
+  (let ((parts (string-split path #\/)))
+    (if (eqv? (string-ref (car parts) 0) #\~)
+        (let ((user (if (= (string-length (car parts)) 1)
+                        (cuserid)
+                        (substring (car parts) 1))))
+          (string-join (cons (passwd:dir (getpwnam user)) (cdr parts)) "/"))
+        path)))
+
+(define-macro (match-lines string pattern bindings expr)
+  (let ((line (gensym)) (seed (gensym)))
+    `(,fold
+      (lambda (,line ,seed)
+        (match-bind ,pattern ,line ,bindings
+                    (cons ,expr ,seed)
+                    ,seed))
+      '() (string-split ,string #\newline))))
+
+(define (dbg fmt . args)
+  (apply format (current-error-port) fmt args))
+
+(define-macro (unwind-protect form . cleanups)
+  `(dynamic-wind (lambda () #t)
+       (lambda () ,form)
+       (lambda () ,@cleanups)))
+
+(define (dsu-sort list key less)
+  (map cdr
+       (stable-sort (map (lambda (x) (cons (key x) x)) list)
+                    (lambda (x y) (less (car x) (car y))))))
+
+(define (hash-push! h key value)
+  (let ((handle (hash-create-handle! h key '())))
+    (set-cdr! handle (cons value (cdr handle)))))
diff --git a/tekuti/web.scm b/tekuti/web.scm
new file mode 100644
index 0000000..f84ad2a
--- /dev/null
+++ b/tekuti/web.scm
@@ -0,0 +1,129 @@
+;; Tekuti
+;; Copyright (C) 2008 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   
+;; published by the Free Software Foundation; either version 3 of   
+;; the License, or (at your option) any later version.              
+;;                                                                  
+;; This program is distributed in the hope that it will be useful,  
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of   
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the    
+;; GNU General Public License for more details.                     
+;;                                                                  
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, contact:
+;;
+;; Free Software Foundation           Voice:  +1-617-542-5942
+;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
+;; Boston, MA  02111-1307,  USA       gnu@gnu.org
+
+;;; Commentary:
+;;
+;; This is the main script that will launch tekuti.
+;;
+;;; Code:
+
+(define-module (tekuti web)
+  #:use-module (sxml simple)
+  #:use-module (sxml transform)
+  #:use-module (tekuti url)
+  #:use-module (tekuti config)
+  #:use-module (srfi srfi-1)
+  #:export (read-headers write-headers let-headers
+            visible-error page-not-found unimplemented
+            url-path-split url-path-case url-relative-path-case))
+            
+(define (read-headers socket)
+  (define (read-line*)
+    (let ((line (read-line socket)))
+      (if (eof-object? line)
+          (error "unexpected eof")
+          line)))
+  (let lp ((keys '()) (values '()))
+    (let ((k (read-line*)))
+      (if (string=? k "end")
+          (reverse (map cons keys values))
+          (lp (cons k keys) (cons (read-line*) values))))))
+
+(define (write-headers-headers headers port)
+  (for-each
+   (lambda (k v)
+     (format port "~a\n~a\n" k v))
+   (map car headers) (map cdr headers))
+  (display "end\n" port))
+
+(define-macro (let-headers headers bindings . body)
+  (let ((headers-var (gensym)))
+    `(let ((,headers-var ,headers))
+       (let (,@(map (lambda (binding)
+                      `(,(car binding)
+                        (or (assoc-ref ,headers-var ,(cadr binding))
+                            (error "Missing header:" ,(cadr binding)))))
+                    bindings))
+         ,@body))))
+
+(define (visible-error . html-body)
+  (throw 'visible-error 404 html-body))
+
+(define (page-not-found path)
+  (throw 'html-error 404 path))
+
+(define (url-path-split path)
+  (filter (lambda (x) (not (string-null? x)))
+          (map url:decode (string-split path #\/))))
+
+(define-macro (url-path-case method path . clauses)
+  (define (optional-argument arg)
+    (let ((len (string-length arg)))
+      (and (eqv? (string-ref arg (1- len)) #\?)
+           (substring arg 0 (1- len)))))
+  (let ((method-sym (gensym)) (path-parts (gensym)))
+    (define (process-clauses)
+      (map (lambda (clause)
+             (let ((pattern (car clause)) (body (cdr clause)))
+               (cond
+                ((eq? pattern 'else)
+                 clause)
+                (else
+                 (let* ((method-match (car pattern))
+                        (parts-match (map symbol->string (cdr pattern)))
+                        (nargs (length parts-match))
+                        (opt (or (find-tail optional-argument parts-match) '()))
+                        (nopt (length opt))
+                        (nreq (- nargs nopt)))
+                   (cond
+                    ((null? opt)
+                     `((and (eq? ,method-sym ',method-match)
+                            (equal? ,path-parts ',parts-match))
+                       ,@body))
+                    (else
+                     `((and (eq? ,method-sym ',method-match)
+                            (equal? (list-head ,path-parts ,nreq)
+                                    ',(list-head parts-match nreq))
+                            (< (length ,path-parts) ,nargs))
+                       (apply
+                        (lambda ,(map string->symbol (map optional-argument opt))
+                          ,@body)
+                        (let ((tail (list-tail ,path-parts ,nreq)))
+                          (append tail (make-list (- ,nopt (length tail)) #f))))))))))))
+           clauses))
+    `(let ((,method-sym (string->symbol ,method))
+           (,path-parts (url-path-split ,path)))
+       (cond ,@(process-clauses)))))
+
+(define-macro (url-relative-path-case method path . clauses)
+  (let ((infix (map string->symbol (url-path-split *private-url-base*))))
+    (define (munge-clause clause)
+      (cond
+       ((eq? (car clause) 'else) clause)
+       (else
+        (let ((method (caar clause))
+              (parts (cdar clause))
+              (body (cdr clause)))
+          `((,method ,@infix ,@parts) ,@body)))))
+    `(url-path-case ,method ,path
+                    ,@(map munge-clause clauses))))
+
+(define (unimplemented . args)
+  (apply throw 'unimplemented args))