snapshot

tekuti/boot.scm

@@ -35,50 +35,9 @@ exec guile $GUILE_FLAGS -l $0 -e main -- "$@"
   #: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))
@@ -120,4 +79,4 @@ exec guile $GUILE_FLAGS -l $0 -e main -- "$@"
 (define (boot args)
   (let ((options (parse-options args)))
     (ensure-git-repo)
-    (event-loop handle-request maybe-reindex)))
+    (event-loop)))

tekuti/comment.scm

@@ -55,9 +55,8 @@
   (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_COMMITTER_DATE=~a +0100'" ts)
+                            (format #f "GIT_AUTHOR_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))))

tekuti/config.scm

@@ -34,6 +34,6 @@
 (define *backlog* 5)
 (define *git-dir* "~/blog.git")
 (define *git* "git")
-(define *public-url-base* "/")
+(define *public-url-base* "/blog/")
 (define *private-url-base* "/blog/")
 (define *debug* #t)

tekuti/git.scm

@@ -32,16 +32,57 @@
   #: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
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:export (&git-condition git-condition? git-condition-argv
+            git-condition-output git-condition-status false-if-git-error
+
+            git git* ensure-git-repo git-ls-tree git-ls-subdirs
             parse-metadata parse-commit commit-utc-timestamp
             commit-parents make-tree git-rev-parse))
 
-(define (call-with-pipe pipe proc)
+(define-condition-type &git-condition &condition git-condition?
-  (unwind-protect
+  (argv git-condition-argv)
-   (proc pipe)
+  (output git-condition-output)
-   (let ((ret (close-pipe pipe)))
+  (status git-condition-status))
-     (if (not (eq? (status:exit-val ret) 0))
+
-         (throw 'pipe-error proc ret)))))
+(define-macro (false-if-git-error . body)
+  `(,guard (c ((,git-condition? c) #f))
+           ,@body))
+
+(define (shell:quote str)
+  (with-output-to-string
+    (lambda ()
+      (display #\')
+      (for-each (lambda (ch)
+		  (if (eqv? ch #\')
+                      (begin (display #\\) (display #\'))
+                      (display ch)))
+		(string->list str))
+      (display #\'))))
+      
+(define (run-git env input-file args)
+  (define (prepend-env args)
+    (if (null? env)
+        args
+        (cons "/usr/bin/env" (append env args))))
+  (define (prepend-git args)
+    (cons* *git* "--bare" args))
+  (define (redirect-input args)
+    (if input-file
+        (list "/bin/sh" "-c" (string-join (map shell:quote args) " ")
+              "<" input-file)
+        args))
+  (let* ((real-args (pk (redirect-input (prepend-env (prepend-git args)))))
+         (pipe (apply open-pipe* OPEN_READ real-args))
+         (output (read-delimited "" pipe))
+         (ret (close-pipe pipe)))
+    (case (status:exit-val ret)
+      ((0) (if (eof-object? output) "" output))
+      (else (raise (condition (&git-condition
+                               (argv real-args)
+                               (output output)
+                               (status ret))))))))
 
 (define (call-with-temp-file contents proc)
   (let* ((template (string-copy "/tmp/tekutiXXXXXX"))
@@ -54,23 +95,12 @@
 
 (define/kwargs (git* args (input #f) (env '()))
   ;; foolishness regarding env
-  (define (nyam-nyam-nyam pipe)
+  (if input
-    (read-delimited "" pipe))
-  (cond
-   (input
       (call-with-temp-file
        input
        (lambda (tempname)
-       (let ((cmd (string-join `("env" ,@env ,*git* "--bare" ,@args "<" ,input) " ")))
+         (run-git env tempname args)))
-         (pk cmd)
+      (run-git env #f args)))
-         (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))

tekuti/mod-lisp.scm

@@ -30,10 +30,15 @@
   #: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 util)
+  #:use-module (tekuti git) ; rev-parse
   #:use-module (tekuti request)
+  #:use-module (tekuti web)
+
+  ;; these for their reindex methods
+  #:use-module (tekuti post)
+  #:use-module (tekuti categories)
   #:export (event-loop))
 
 ;;; thought: ignore SIGPIPE, otherwise apache dying will kill us
@@ -50,55 +55,36 @@
           (reverse (map cons keys values))
           (lp (cons k keys) (cons (read-line*) values))))))
 
+(define (read-chars nchars port)
+  (let ((buf (make-string nchars)))
+    (read-delimited! "" buf port)
+    buf))
+
 (define (write-headers headers port)
   (for-each
-   (lambda (k v)
+   (lambda (pair)
-     (format port "~a\n~a\n" k v))
+     (format port "~a\n~a\n" (car pair) (cdr pair)))
-   (map car headers) (map cdr headers))
+   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 (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)
+  (display (rref request 'doctype "") socket)
-  (sxml->xml (templatize request) socket))
+  (sxml->xml (rref request 'sxml '()) socket))
 
-(define (connection-received socket sockaddr index handle-request)
+(define (connection-received socket sockaddr index)
-  (let ((headers (read-headers socket))
+  (let* ((headers (pk (read-headers socket)))
-        (post-data "")) ;; blocks: (read-delimited "" socket)))
+         (post-data (read-chars (string->number
-
+                                 (pk (or (assoc-ref headers "content-length")
-    (dbg "~a" headers)
+                                         "0")))
+                                socket)))
     (catch
      #t
      (lambda ()
-       (let ((res (pk (handle-request
+       (let ((res (handle-request (make-request 'headers headers
-                    (make-request 'headers headers
                                                 'post-data post-data)
-                    index))))
+                                  index)))
-         (let-request res ((status 200))
+         (write-headers (rref res 'output-headers '()) socket)
-           (write-headers `(("Status" . ,(status->string status))
+         (write-body res socket)))
-                            ("Content-Type" . "text/html"))
-                          socket)
-           (write-body res socket))))
      (lambda args
        (write-headers '(("Status" . "500 Internal Server Error")
                         ("Content-Type" . "text/plain"))
@@ -121,17 +107,29 @@
      (proc socket)
      (shutdown socket 2))))
 
-(define (inner-loop socket cookie index handle-request maybe-reindex)
+(define (inner-loop socket cookie index)
   (let* ((pair (accept socket))
          (fd (car pair))
          (sockaddr (cdr pair)))
     (receive
      (new-cookie new-index) (maybe-reindex cookie index)
      (pk new-cookie new-index)
-     (connection-received (car pair) (cdr pair) new-index handle-request)
+     (connection-received (car pair) (cdr pair) new-index)
-     (inner-loop socket new-cookie new-index handle-request maybe-reindex))))
+     (inner-loop socket new-cookie new-index))))
 
-(define (event-loop handle-request maybe-reindex)
+(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 (event-loop)
   (with-socket
    (lambda (socket)
-     (inner-loop socket #f #f handle-request maybe-reindex))))
+     (inner-loop socket #f #f))))

tekuti/page.scm

@@ -25,14 +25,20 @@
 ;;; Code:
 
 (define-module (tekuti page)
+  #:use-module (tekuti config)
   #:use-module (tekuti git)
   #:use-module (tekuti post)
+  #:use-module (tekuti url)
   #:use-module (tekuti request)
-  #:export (page-new-post 
+  #:use-module (srfi srfi-34)
-            page-modify-post 
+  #:export (page-admin
-            page-new-comment 
+            page-admin-posts
-            page-delete-comment 
+            page-admin-post
-            page-delete-post 
+            page-admin-new-post
+            page-admin-new-comment
+            page-admin-modify-post 
+            page-admin-delete-comment 
+            page-admin-delete-post 
             page-index 
             page-show-post 
             page-archives 
@@ -42,40 +48,133 @@
             page-debug
             page-not-found))
 
-(define (make-post-slug y m day post)
+(define (relurl path . body)
-  (url:encode (format #f "~a/~a/~a" y m (url:encode post))))
+  `(a (@ (href ,(string-append *public-url-base* path)))
+      ,@body))
+
+(define (make-post-key . parts)
+  (url:encode (format #f "~{~a~^/~}" (map url:encode parts))))
 
 (define (show-post slug index)
   `(sxml . (p "hello" ,slug)))
 
 (define (not-implemented request . args)
   (rcons* request
-          'status 404
+          'status 500
-          'body `(p "Not implemented:" ,(rref request 'url))))
+          'body `((h1 "Not yet implemented")
+                  (p "Path handler not yet implemented: "
+                     ,(rref request 'path-str)))))
 
-(define page-new-post not-implemented)
+;; thought: url mapping for post modification? probably including git sha1
-(define page-modify-post not-implemented)
+
+(define (relform path . body)
+  `(form (@ (method "POST")
+            (action ,(string-append *public-url-base* path)))
+      ,@body))
+
+(define (page-admin request index)
+  ;; here we need to be giving a dashboard view instead of this
+  (define (post-headers)
+    (map (lambda (post)
+           ;; double-encoding is a hack to trick apache
+           `(li ,(relurl (string-append "admin/posts/" (url:encode (assq-ref post 'key)))
+                         (assq-ref post 'title))))
+         (assq-ref index 'posts)))
+  (rcons* request
+          'body `((h2 "all your posts")
+                  (ul ,@(post-headers))
+                  (h2 "are belong to tekuti")
+                  ,(apply
+                    relform
+                    "admin/new-post"
+                    `((div "title" (input (@ (name "title") (type "text"))))
+                      (div (textarea (@ (name "body") (rows "20") (cols "80"))
+                                     ""))
+                      (input (@ (type "submit") (value "new post"))))))))
+
+(define (page-admin-posts request index)
+  (define (post-headers)
+    (map (lambda (post)
+           ;; double encoding is a hack
+           `(div (h3 ,(relurl (string-append "admin/posts/"
+                                             (url:encode (assq-ref post 'key)))
+                              (assq-ref post 'title)))
+                 (p "This is a post")))
+         (assq-ref index 'posts)))
+  (rcons* request
+          'body `((h1 "all your posts are belong to tekuti")
+                  ,@(post-headers))))
+
+(define (page-admin-post request index key)
+  (let ((post (post-from-key (assq-ref index 'master) key)))
+    (pk 'foo post)
+    (rcons* request
+          'body `((h1 ,(assq-ref post 'title))
+                  "foo?"))))
+
+(define (decode-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")
+            (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) ""))))
+             (string-split post-data #\&)))
+           (else
+            (error "bad content-type" content-type)))))))
+
+(define (page-admin-new-post request index)
+  (let ((form-data (decode-form-data request)))
+    (rcons* request
+            'status 201         ; created
+            'output-headers (acons "Location" *public-url-base*
+                                   (rref request 'output-headers '()))
+            'body `((h1 "Created")
+                    (p "Created new post: " ,(assoc-ref form-data "title"))
+                    (pre ,(assoc-ref form-data "body"))))))
+
+
+;;                     (a (@ (href ,new-url)) ,new-url)
+
+(define (page-new-post request index)
+  ()
+  not-implemented)
+(define (page-modify-post request index)
+  ()
+  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 ((slug (make-post-key year month day post)))
-    (let ((tree (git-rev-parse (string-append (assq-ref index 'master) ":" slug))))
+    (cond
+     ((false-if-git-error
+       (git-rev-parse (string-append (assq-ref index 'master) ":" slug)))
+      => (lambda (tree)
            (let ((post (post-from-tree slug tree)))
-        `((title . "post")
+             (rcons* request
-          (sxml . (pre ,(with-output-to-string
+                     'title "post"
+                     'body `((pre ,(with-output-to-string
                                      (lambda ()
-                            (write post))))))))))
+                                       (write post)))))))))
+     (else
+      (page-not-found request index)))))
 
 (define page-archives not-implemented)
 
 (define (page-debug request index)
   (rcons* request
           'title "hello"
-          'body `(div
+          'body `((p "hello world!")
-                  (p "hello world!")
                   (table
                    (tr (th "header") (th "value"))
                    ,@(map (lambda (pair)
@@ -85,7 +184,8 @@
 (define page-search not-implemented)
 
 (define (page-not-found request index)
+  (pk request)
   (rcons* request
           'status 404
-          'body `(p "Not found:" ,(rref request 'url))))
+          'body `((h1 "Page not found")
-
+                  (p "Unknown path: " ,(rref request 'path-str)))))

tekuti/post.scm

@@ -31,13 +31,13 @@
   #:use-module (tekuti comment)
   #:use-module (tekuti git)
   #:use-module (srfi srfi-1)
-  #:export (reindex-posts post-from-tree post-categories all-published-posts))
+  #:export (reindex-posts post-from-tree post-from-key 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"))
+  (equal? (assq-ref post-alist 'status) "publish"))
 
 (define (post-timestamp post-alist)
   (or (assq-ref post-alist 'timestamp) #f))
@@ -47,12 +47,18 @@
 
 (define *post-spec*
   `((timestamp . ,string->number)
-    (categories . ,(lambda (v) (map string-trim-both (string-split v #\,))))))
+    (categories . ,(lambda (v) (map string-trim-both (string-split v #\,))))
+    (title . ,identity)))
 
 (define (post-from-tree encoded-name sha1)
-  (acons 'url encoded-name
+  (acons 'key encoded-name
          (parse-metadata (string-append sha1 ":" "metadata") *post-spec*)))
 
+(define (post-from-key master key)
+  (let ((pairs (git-ls-subdirs master key)))
+    (and (= (length pairs) 1)
+         (post-from-tree key (cdar pairs)))))
+
 (define (all-posts master)
   (map (lambda (pair)
          (post-from-tree (car pair) (cdr pair)))

tekuti/request.scm

@@ -25,27 +25,60 @@
 ;;; Code:
 
 (define-module (tekuti request)
-  #:use-module ((srfi srfi-1) #:select (find-tail))
+  #:use-module ((srfi srfi-1) #:select (find-tail fold))
   #:use-module (scheme kwargs)
   #:use-module (tekuti util)
+  #:use-module (tekuti url)
   #:use-module (tekuti config)
-  #:use-module (tekuti web)
+  #:export (make-request rcons rcons* rpush rpush* rref let-request
-  #:export (make-request rcons rcons* rref let-request
             request-path-case))
 
+(define (header-ref headers key default)
+  (let ((pair (assoc key headers)))
+    (if pair
+        (cdr pair)
+        default)))
+
+(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 '()))))
+    (method . ,(lambda (r)
+                 (header-ref (rref r 'headers '()) "method" "GET")))))
+
 (define (make-request . keys-and-values)
-  (apply rcons* '() keys-and-values))
+  (fold (lambda (pair r)
+          (rcons (car pair) ((cdr pair) r) r))
+        (apply rcons* '() keys-and-values)
+        *request-initializers*))
 
 (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))
+  (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/kwargs (rref request k (default #f) (default-proc #f))
   (let ((pair (assq k request)))
     (cond
@@ -68,6 +101,10 @@
   (let ((path-var (gensym)))
     (define (optional-argument? arg)
       (eqv? (string-ref arg (1- (string-length arg))) #\?))
+    (define (required-argument? arg)
+      (eqv? (string-ref arg (1- (string-length arg))) #\!))
+    (define (output-argument? arg)
+      (or (optional-argument? arg) (required-argument? arg)))
     (define (process-clause clause)
       (or (list-has-length? clause 2) (error "foo"))
       (if (eq? (car clause) 'else)
@@ -75,40 +112,46 @@
           (let ((pat (map symbol->string (car clause)))
                 (proc (cadr clause)))
             (cond
-             ((find-tail optional-argument? pat)
+             ((find-tail output-argument? pat)
               => (lambda (tail)
                    (define test
-                     (let* ((len (length pat))
+                     (let* ((npat (length pat))
-                            (nopt (length tail))
+                            (ntail (length tail))
-                            (nreq (- len nopt)))
+                            (req (find-tail required-argument? tail))
+                            (opt (find-tail optional-argument? tail))
+                            (nopt (if opt (length opt) 0))
+                            (nreq (if req (- (length req) nopt) 0)))
                        (lambda (path)
-                         (let ((pathtail (list-head-match pat path nreq)))
+                         (let ((pathtail (list-head-match pat path (- npat ntail))))
-                           (if (and pathtail (<= (length pathtail) nopt))
+                           (pk pat npat ntail req opt nopt nreq path pathtail)
-                               pathtail
+                           (if (and pathtail (>= (length pathtail) nreq)
+                                    (<= (length pathtail) (+ nreq nopt)))
+                               (append pathtail
+                                       (make-list (- (+ nreq nopt) (length pathtail)) #f))
                                #f)))))
                    `((,test ,path-var)
-                     => (lambda (optargs)
+                     => (lambda (outargs)
                           (lambda args
-                            (apply ,proc (append args optargs)))))))
+                            (apply ,proc (append args outargs)))))))
              (else
               `((equal? ,path-var ',pat) ,proc))))))
     `(let ((,path-var ,path))
        (cond ,@(map process-clause clauses)))))
 
-;; hmm, style mismatch between these let macros
+(define (foldn kons n knil values)
+  (if (null? values)
+      knil
+      (foldn kons n
+             (apply kons knil (list-head values n))
+             (list-tail values n))))
+
+(define (rcons*-fold request . keys-and-procs)
+  (foldn (lambda (request k proc)
+           (rcons k (proc request) request))
+         2 request keys-and-procs))
+
 (define-macro (request-path-case request . clauses)
-  (define (make-path request)
+  `(,path-proc-case
-    (let ((private-url-path (url-path-split *private-url-base*)))
+    (,let-request ,request (method path)
-      (let-request request (headers)
+                  (cons method path))
-        (let-headers headers ((method "method") (path "url"))
+    ,@clauses))
-          (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

@@ -48,6 +48,7 @@
 ;;     encoding methods (e.g. a url-scheme-reserved-char-alist)
 
 (define-module (tekuti url)
+  #:use-module ((srfi srfi-1) #:select (filter))
   #:use-module (ice-9 regex))
 
 ;; `url:scheme' is an unfortunate term, but it is the technical
@@ -156,8 +157,10 @@
 			(display (number->string (char->integer ch) 16)))))
 		(string->list str)))))
 
-(define safe-chars
+(define special-chars
-  '(#\$ #\- #\_ #\. #\+ #\! #\* #\' #\( #\) #\, #\; #\/ #\? #\: #\@ #\& #\=))
+  (string->list "$-_.+!*'()"))
+(define reserved-chars
+  (string->list ";/?:@&="))
 
 (define (safe-char? ch)
   ;; ``Thus, only alphanumerics, the special characters "$-_.+!*'(),", and
@@ -165,6 +168,13 @@
   ;; unencoded within a URL.'' RFC 1738, #2.2.
   (or (char-alphabetic? ch)
       (char-numeric? ch)
-      (memv ch safe-chars)))
+      (memv ch special-chars)))
+
+(define-public (url:path-split path)
+  (filter (lambda (x) (not (string-null? x)))
+          (map url:decode (string-split path #\/))))
+
+(define-public (url:path-join path)
+  (string-join (map url:encode path) "/"))
 
 ;;; www/url.scm ends here

tekuti/web.scm

@@ -28,31 +28,37 @@
   #:use-module (sxml simple)
   #:use-module (sxml transform)
   #:use-module (tekuti url)
-  #:use-module (tekuti config)
+  #:use-module (tekuti request)
+  #:use-module (tekuti template)
+  #:use-module (tekuti page)
   #:use-module (srfi srfi-1)
-  #:export (read-headers write-headers let-headers
+  #:export (let-headers header-ref
-            visible-error unimplemented
+            handle-request))
-            url-path-split url-path-case url-relative-path-case))
             
-(define (read-headers socket)
+(define *status-names*
-  (define (read-line*)
+  '((200 . "OK")
-    (let ((line (read-line socket)))
+    (201 . "Created")
-      (if (eof-object? line)
+    (404 . "Not Found")
-          (error "unexpected eof")
+    (500 . "Internal Server Error")))
-          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)
+(define (status->string status)
-  (for-each
+  (format #f "~a ~a" status (or (assv-ref *status-names* status)
-   (lambda (k v)
+                                "Unknown Error")))
-     (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 (request-output-headers request)
+  (let-request request ((output-headers '())
+                        (status 200)
+                        (content-type "text/html"))
+    (acons "Status" (status->string status)
+           (acons "Content-Type" content-type
+                  output-headers))))
+
+;;; useless macro
 (define-macro (let-headers headers bindings . body)
   (let ((headers-var (gensym)))
     `(let ((,headers-var ,headers))
@@ -63,64 +69,38 @@
                     bindings))
          ,@body))))
 
-(define (visible-error . html-body)
+(define (finalize request)
-  (throw 'visible-error 404 html-body))
+  ;; update output headers
+  ;; templatize body
+  (rpush* (rcons* request
+                  'sxml (templatize request)
+                  'doctype xhtml-doctype)
+          'output-headers
+          (cons "Status" (status->string (rref request 'status 200)))
+          'output-headers
+          (cons "Content-Type" (rref request 'content-type "text/html"))))
 
-(define (url-path-split path)
+(define (choose-handler request)
-  (filter (lambda (x) (not (string-null? x)))
+  (request-path-case
-          (map url:decode (string-split path #\/))))
+   request
+   ((GET admin) page-admin)
+   ((GET admin posts) page-admin-posts)
+   ((GET admin posts post-key!) page-admin-post)
+   ((POST admin new-post) page-admin-new-post)
+   ((POST admin new-comment post-key!) page-admin-new-comment)
+   ;; would be fine to have e.g. (DELETE admin posts posts-key!), but
+   ;; web browsers don't handle that
+   ((POST admin modify-post post-key!) page-admin-modify-post)
+   ((POST admin delete-comment comment-key!) page-admin-delete-comment)
+   ((POST admin delete-post post-key!) page-admin-delete-post)
     
-(define-macro (url-path-case method path . clauses)
+   ((GET) page-index)
-  (define (optional-argument arg)
+   ((GET archives year? month? day?) page-archives)
-    (let ((len (string-length arg)))
+   ((GET archives year! month! day! post!) page-show-post)
-      (and (eqv? (string-ref arg (1- len)) #\?)
+   ((GET debug) page-debug)
-           (substring arg 0 (1- len)))))
+   ((POST search) page-search)
-  (let ((method-sym (gensym)) (path-parts (gensym)))
+   (else page-not-found)))
-    (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)
+(define (handle-request request index)
-  (let ((infix (map string->symbol (url-path-split *private-url-base*))))
+  (let ((handler (choose-handler request)))
-    (define (munge-clause clause)
+    (pk (finalize (handler request index)))))
-      (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))