another checkpoint, works again!

src/tekuti

@@ -1,6 +1,6 @@
 #! /bin/bash
 # -*- scheme -*-
-exec guile $GUILE_FLAGS -l $0 -e main "$@"
+exec guile $GUILE_FLAGS -l $0 -e main -- "$@"
 !#
 ;; Tekuti
 ;; Copyright (C) 2008 Andy Wingo <wingo at pobox dot com>
@@ -30,52 +30,10 @@ exec guile $GUILE_FLAGS -l $0 -e main "$@"
 
 ;;hack!
 
-(debug-enable 'backtrace)
+(turn-on-debugging)
-(use-modules (tekuti git)
+(use-modules (tekuti boot))
-             (tekuti page)
-             (tekuti util)
-             (tekuti post)
-             (tekuti categories)
-             (tekuti mod-lisp)
-             (tekuti web))
-
-(define (handle-request headers post-data index)
-  (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 (maybe-reindex old-master old-index)
-  (let ((master (git-rev-parse "master")))
-    (values
-     master 
-     (if (equal? master old-master)
-         old-index
-         (acons 'master master
-                (map (lambda (k reindex)
-                       (cons k (reindex master)))
-                     (list 'posts 'categories)
-                     (list reindex-posts reindex-categories)))))))
-
 (define (main args)
-  (ensure-git-repo)
+  (start-stack 'tekuti
-  (event-loop handle-request maybe-reindex))
+               (boot args)))
+
 

tekuti/boot.scm

@@ -0,0 +1,123 @@
+#! /bin/bash
+# -*- scheme -*-
+exec guile $GUILE_FLAGS -l $0 -e main -- "$@"
+!#
+;; 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 boot)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 getopt-long)
+  #:use-module (ice-9 threads)
+  #:use-module (tekuti git)
+  #:use-module (tekuti page)
+  #:use-module (tekuti util)
+  #:use-module (tekuti post)
+  #:use-module (tekuti url)
+  #:use-module (tekuti request)
+  #:use-module (tekuti categories)
+  #:use-module (tekuti mod-lisp)
+  #:use-module (tekuti web)
+  #:export (boot))
+
+(define (make-post-slug y m day post)
+  (url:encode (format #f "~a/~a/~a" y m (url:encode post))))
+
+(define (show-post slug index)
+  `(sxml . (p "hello" ,slug)))
+
+(define (handle-request request index)
+  ((request-path-case
+    request
+    ((POST admin new-post) page-new-post)
+    ((POST admin modify-post) page-modify-post)
+    ((POST admin new-comment) page-new-comment)
+    ((POST admin delete-comment) page-delete-comment)
+    ((POST admin delete-post) page-delete-post)
+    ((GET) page-index)
+    ((GET archives year? month? day?) page-archives)
+    ((GET archives year? month? day? post?) page-show-post)
+    ((GET debug) page-debug)
+    ((POST search) page-search)
+    (else page-not-found))
+   request index))
+
+(define (maybe-reindex old-master old-index)
+  (let ((master (git-rev-parse "master")))
+    (values
+     master 
+     (if (equal? master old-master)
+         old-index
+         (acons 'master master
+                (map (lambda (k reindex)
+                       (cons k (reindex master)))
+                     (list 'posts 'categories)
+                     (list reindex-posts reindex-categories)))))))
+
+(define *option-grammar* '((gds)
+                           (usage)
+                           (version (single-char #\v))
+                           (help (single-char #\h))))
+
+(define (usage)
+  ;; trying out `format'. mixed results.
+  (define (repr-option opt)
+    (let ((required (and=> (assq 'required (cdr opt)) cadr)))
+      (format #f "~:[[~;~]--~a~@*~:[]~;~]"
+              (assq 'required? (cdr opt)) (car opt))))
+        
+  (format #t "usage: tekuti ~{~a~^ ~}~%"
+          (map repr-option *option-grammar*)))
+
+(define (version)
+  (format #t "tekuti version 0.1" (car (program-arguments))))
+
+;; krap code
+(define (parse-options args)
+  (let ((opts (getopt-long args '((gds)
+                                  (usage)
+                                  (version (single-char #\v))
+                                  (help (single-char #\h))))))
+    (if (or (option-ref opts 'usage #f)
+            (option-ref opts 'help #f)
+            (not (null? (option-ref (cdr opts) '() '()))))
+        (begin
+          (usage)
+          (exit 0)))
+    (if (option-ref opts 'version #f)
+        (begin
+          (version)
+          (exit 0)))
+    (if (option-ref opts 'gds #f)
+        (make-thread (@ (ice-9 gds-client) run-utility)))
+    opts))
+
+(define (boot args)
+  (let ((options (parse-options args)))
+    (ensure-git-repo)
+    (event-loop handle-request maybe-reindex)))

tekuti/mod-lisp.scm

@@ -27,13 +27,17 @@
 (define-module (tekuti mod-lisp)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 receive)
+  #:use-module (ice-9 stack-catch)
   #:use-module (sxml simple)
   #:use-module (sxml transform)
   #:use-module (tekuti url)
   #:use-module (tekuti util)
   #:use-module (tekuti config)
+  #:use-module (tekuti request)
   #:export (event-loop))
 
+;;; thought: ignore SIGPIPE, otherwise apache dying will kill us
+
 (define (read-headers socket)
   (define (read-line*)
     (let ((line (read-line socket)))
@@ -58,24 +62,53 @@
    "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" "
    "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n"))
 
+(define (templatize request)
+  (let-request request (title body)
+    `(html (head
+            (title ,(or title "foo")))
+           (body
+            ,(or body '(p "what"))))))
+
+(define *status-names*
+  '((200 . "OK")
+    (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 (write-body request socket)
+  (display xhtml-doctype socket)
+  (sxml->xml (templatize request) socket))
+
 (define (connection-received socket sockaddr index handle-request)
   (let ((headers (read-headers socket))
         (post-data "")) ;; blocks: (read-delimited "" socket)))
 
     (dbg "~a" headers)
-    (catch #t
+    (catch
+     #t
      (lambda ()
-             (let ((sxml (handle-request headers post-data index)))
+       (let ((res (pk (handle-request
-               (write-headers '(("Status" . "200 OK")
+                    (make-request 'headers headers
+                                  'post-data post-data)
+                    index))))
+         (let-request res ((status 200))
+           (write-headers `(("Status" . ,(status->string status))
                             ("Content-Type" . "text/html"))
                           socket)
-               (display xhtml-doctype socket)
+           (write-body res socket))))
-               (sxml->xml sxml socket)))
      (lambda args
        (write-headers '(("Status" . "500 Internal Server Error")
                         ("Content-Type" . "text/plain"))
                       socket)
-             (write args socket)))
+       (write args socket)
+       (newline)
+       (with-output-to-port socket backtrace))
+     (lambda args
+       (fluid-set! the-last-stack (make-stack #t 2 0))
+       (apply throw args)))
              
     (close-port socket)))
 
@@ -88,15 +121,17 @@
      (proc socket)
      (shutdown socket 2))))
 
-(define (event-loop handle-request maybe-reindex)
+(define (inner-loop socket cookie index handle-request maybe-reindex)
-  (with-socket
-   (lambda (socket)
-     (let lp ((old-cookie #f) (old-index #f))
   (let* ((pair (accept socket))
          (fd (car pair))
          (sockaddr (cdr pair)))
     (receive
-          (cookie index) (maybe-reindex old-cookie old-index)
+     (new-cookie new-index) (maybe-reindex cookie index)
-          (pk cookie index)
+     (pk new-cookie new-index)
-          (connection-received (car pair) (cdr pair) index handle-request)
+     (connection-received (car pair) (cdr pair) new-index handle-request)
-          (lp cookie index)))))))
+     (inner-loop socket new-cookie new-index handle-request maybe-reindex))))
+
+(define (event-loop handle-request maybe-reindex)
+  (with-socket
+   (lambda (socket)
+     (inner-loop socket #f #f handle-request maybe-reindex))))

tekuti/page.scm

@@ -25,13 +25,67 @@
 ;;; Code:
 
 (define-module (tekuti page)
-  #:export (page-debug))
+  #:use-module (tekuti git)
+  #:use-module (tekuti post)
+  #:use-module (tekuti request)
+  #:export (page-new-post 
+            page-modify-post 
+            page-new-comment 
+            page-delete-comment 
+            page-delete-post 
+            page-index 
+            page-show-post 
+            page-archives 
+            page-debug 
+            page-search 
+            page-show-post 
+            page-debug
+            page-not-found))
 
-(define (page-debug headers)
+(define (make-post-slug y m day post)
-  `(html (head (title "hello"))
+  (url:encode (format #f "~a/~a/~a" y m (url:encode post))))
-         (body (p "hello world!")
+
+(define (show-post slug index)
+  `(sxml . (p "hello" ,slug)))
+
+(define (not-implemented request . args)
+  (rcons* request
+          'status 404
+          'body `(p "Not implemented:" ,(rref request 'url))))
+
+(define page-new-post not-implemented)
+(define page-modify-post not-implemented)
+(define page-new-comment not-implemented)
+(define page-delete-comment not-implemented)
+(define page-delete-post not-implemented)
+(define page-index not-implemented)
+
+(define (page-show-post request index year month day post)
+  (let ((slug (make-post-slug year month day post)))
+    (let ((tree (git-rev-parse (string-append (assq-ref index 'master) ":" slug))))
+      (let ((post (post-from-tree slug tree)))
+        `((title . "post")
+          (sxml . (pre ,(with-output-to-string
+                          (lambda ()
+                            (write post))))))))))
+
+(define page-archives not-implemented)
+
+(define (page-debug request index)
+  (rcons* request
+          'title "hello"
+          'body `(div
+                  (p "hello world!")
                   (table
                    (tr (th "header") (th "value"))
                    ,@(map (lambda (pair)
                             `(tr (td ,(car pair)) (td ,(cdr pair))))
-                       headers)))))
+                          (rref request 'headers))))))
+
+(define page-search not-implemented)
+
+(define (page-not-found request index)
+  (rcons* request
+          'status 404
+          'body `(p "Not found:" ,(rref request 'url))))
+

tekuti/post.scm

@@ -31,7 +31,7 @@
   #:use-module (tekuti comment)
   #:use-module (tekuti git)
   #:use-module (srfi srfi-1)
-  #:export (reindex-posts post-categories all-published-posts))
+  #:export (reindex-posts post-from-tree post-categories all-published-posts))
   
 ;; introducing new assumption: post urls like yyyy/dd/mm/post; post dirnames the urlencoded post
 

tekuti/request.scm

@@ -0,0 +1,114 @@
+;; 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 request)
+  #:use-module ((srfi srfi-1) #:select (find-tail))
+  #:use-module (scheme kwargs)
+  #:use-module (tekuti util)
+  #:use-module (tekuti config)
+  #:use-module (tekuti web)
+  #:export (make-request rcons rcons* rref let-request
+            request-path-case))
+
+(define (make-request . keys-and-values)
+  (apply rcons* '() keys-and-values))
+
+(define (rcons k v request)
+  (or (symbol? k) (error "request keys should be symbols"))
+  (acons k v request))
+
+(define (rcons* request . keys-and-values)
+  (let lp ((request '()) (kv keys-and-values))
+    (if (null? kv)
+        request
+        (lp (rcons (car kv) (cadr kv) request) (cddr kv)))))
+
+(define/kwargs (rref request k (default #f) (default-proc #f))
+  (let ((pair (assq k request)))
+    (cond
+     (pair (cdr pair))
+     (default-proc (default-proc request k))
+     (else default))))
+
+(define-macro (let-request request bindings . body)
+  (let ((request-var (gensym)))
+    (define (make-binding b)
+      (cond
+       ((symbol? b) `(,b (,rref ,request-var ',b)))
+       ((list? b) `(,(car b) (,rref ,request-var ',(car b) ,@(cdr b))))
+       (else (error "what" b))))
+    `(let ((,request-var ,request))
+       (let (,@(map make-binding bindings))
+         ,@body))))
+
+(define-macro (path-proc-case path . clauses)
+  (let ((path-var (gensym)))
+    (define (optional-argument? arg)
+      (eqv? (string-ref arg (1- (string-length arg))) #\?))
+    (define (process-clause clause)
+      (or (list-has-length? clause 2) (error "foo"))
+      (if (eq? (car clause) 'else)
+          clause
+          (let ((pat (map symbol->string (car clause)))
+                (proc (cadr clause)))
+            (cond
+             ((find-tail optional-argument? pat)
+              => (lambda (tail)
+                   (define test
+                     (let* ((len (length pat))
+                            (nopt (length tail))
+                            (nreq (- len nopt)))
+                       (lambda (path)
+                         (let ((pathtail (list-head-match pat path nreq)))
+                           (if (and pathtail (<= (length pathtail) nopt))
+                               pathtail
+                               #f)))))
+                   `((,test ,path-var)
+                     => (lambda (optargs)
+                          (lambda args
+                            (apply ,proc (append args optargs)))))))
+             (else
+              `((equal? ,path-var ',pat) ,proc))))))
+    `(let ((,path-var ,path))
+       (cond ,@(map process-clause clauses)))))
+
+;; hmm, style mismatch between these let macros
+(define-macro (request-path-case request . clauses)
+  (define (make-path request)
+    (let ((private-url-path (url-path-split *private-url-base*)))
+      (let-request request (headers)
+        (let-headers headers ((method "method") (path "url"))
+          (let* ((tail (list-head-match private-url-path
+                                        (url-path-split path)
+                                        (length private-url-path))))
+            (if (not tail)
+                (error "unexpected path" path *private-url-base*)
+                (cons method tail)))))))
+  (let ((req-sym (gensym)))
+    `(let* ((,req-sym ,request))
+       (,path-proc-case
+        (,make-path ,req-sym)
+        ,@clauses))))

tekuti/url.scm

@@ -145,12 +145,11 @@
 ;; include any character not in the SAFE-CHARS list and any
 ;; character that *is* in the RESERVED-CHARS list argument.
 
-(define-public (url:encode str reserved-chars)
+(define-public (url:encode str)
   (with-output-to-string
     (lambda ()
       (for-each (lambda (ch)
-		  (if (and (safe-char? ch)
+		  (if (safe-char? ch)
-			   (not (memv ch reserved-chars)))
 		      (display ch)
 		      (begin
 			(display #\%)

tekuti/util.scm

@@ -27,7 +27,8 @@
 (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!))
+  #:export (expanduser match-lines dbg unwind-protect dbg dsu-sort
+            hash-push! list-has-length? list-head-match))
 
 (define (expanduser path)
   (let ((parts (string-split path #\/)))
@@ -63,3 +64,17 @@
 (define (hash-push! h key value)
   (let ((handle (hash-create-handle! h key '())))
     (set-cdr! handle (cons value (cdr handle)))))
+
+(define (list-has-length? list len)
+  (cond
+   ((zero? len) (null? list))
+   ((null? list) #f)
+   (else (list-has-length? (cdr list) (1- len)))))
+
+;; returns tail of l2
+(define (list-head-match l1 l2 n)
+  (cond
+   ((zero? n) l2)
+   ((null? l2) #f)
+   ((not (equal? (car l1) (car l2))) #f)
+   (else (list-head-match (cdr l1) (cdr l2) (1- n)))))

tekuti/web.scm

@@ -31,7 +31,7 @@
   #:use-module (tekuti config)
   #:use-module (srfi srfi-1)
   #:export (read-headers write-headers let-headers
-            visible-error page-not-found unimplemented
+            visible-error unimplemented
             url-path-split url-path-case url-relative-path-case))
             
 (define (read-headers socket)
@@ -66,9 +66,6 @@
 (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 #\/))))
@@ -101,7 +98,7 @@
                      `((and (eq? ,method-sym ',method-match)
                             (equal? (list-head ,path-parts ,nreq)
                                     ',(list-head parts-match nreq))
-                            (< (length ,path-parts) ,nargs))
+                            (<= (length ,path-parts) ,nargs))
                        (apply
                         (lambda ,(map string->symbol (map optional-argument opt))
                           ,@body)