From c2580a017d69faf44cefb2652d17f71b7e4301f0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 19 Feb 2008 08:58:16 +0100 Subject: [PATCH] snapshot --- tekuti/boot.scm | 43 +------------ tekuti/comment.scm | 5 +- tekuti/config.scm | 2 +- tekuti/git.scm | 78 ++++++++++++++++-------- tekuti/mod-lisp.scm | 92 ++++++++++++++-------------- tekuti/page.scm | 144 +++++++++++++++++++++++++++++++++++++------- tekuti/post.scm | 14 +++-- tekuti/request.scm | 103 ++++++++++++++++++++++--------- tekuti/url.scm | 16 ++++- tekuti/web.scm | 140 ++++++++++++++++++------------------------ 10 files changed, 381 insertions(+), 256 deletions(-) diff --git a/tekuti/boot.scm b/tekuti/boot.scm index 4d42fd4..2f35f3a 100644 --- a/tekuti/boot.scm +++ b/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))) diff --git a/tekuti/comment.scm b/tekuti/comment.scm index 0aa04f8..69bff69 100644 --- a/tekuti/comment.scm +++ b/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_AUTHOR_DATE=~a +0100'" ts)))) + (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)))) diff --git a/tekuti/config.scm b/tekuti/config.scm index 589eb37..71cfabe 100644 --- a/tekuti/config.scm +++ b/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) diff --git a/tekuti/git.scm b/tekuti/git.scm index 7c6b07e..09f339e 100644 --- a/tekuti/git.scm +++ b/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) - (unwind-protect - (proc pipe) - (let ((ret (close-pipe pipe))) - (if (not (eq? (status:exit-val ret) 0)) - (throw 'pipe-error proc ret))))) +(define-condition-type &git-condition &condition git-condition? + (argv git-condition-argv) + (output git-condition-output) + (status git-condition-status)) + +(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) - (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)))) + (if input + (call-with-temp-file + input + (lambda (tempname) + (run-git env tempname args))) + (run-git env #f args))) (define (git . args) (git* args)) diff --git a/tekuti/mod-lisp.scm b/tekuti/mod-lisp.scm index 3be65f4..7c22267 100644 --- a/tekuti/mod-lisp.scm +++ b/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) - (format port "~a\n~a\n" k v)) - (map car headers) (map cdr headers)) + (lambda (pair) + (format port "~a\n~a\n" (car pair) (cdr pair))) + headers) (display "end\n" port)) -(define xhtml-doctype - (string-append - "\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)) + (display (rref request 'doctype "") socket) + (sxml->xml (rref request 'sxml '()) socket)) -(define (connection-received socket sockaddr index handle-request) - (let ((headers (read-headers socket)) - (post-data "")) ;; blocks: (read-delimited "" socket))) - - (dbg "~a" headers) +(define (connection-received socket sockaddr index) + (let* ((headers (pk (read-headers socket))) + (post-data (read-chars (string->number + (pk (or (assoc-ref headers "content-length") + "0"))) + socket))) (catch #t (lambda () - (let ((res (pk (handle-request - (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) - (write-body res socket)))) + (let ((res (handle-request (make-request 'headers headers + 'post-data post-data) + index))) + (write-headers (rref res 'output-headers '()) 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) - (inner-loop socket new-cookie new-index handle-request maybe-reindex)))) + (connection-received (car pair) (cdr pair) new-index) + (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)))) diff --git a/tekuti/page.scm b/tekuti/page.scm index 1806c6b..5671c53 100644 --- a/tekuti/page.scm +++ b/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 - page-modify-post - page-new-comment - page-delete-comment - page-delete-post + #:use-module (srfi srfi-34) + #:export (page-admin + page-admin-posts + page-admin-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) - (url:encode (format #f "~a/~a/~a" y m (url:encode post)))) +(define (relurl path . body) + `(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 - 'body `(p "Not implemented:" ,(rref request 'url)))) + 'status 500 + 'body `((h1 "Not yet implemented") + (p "Path handler not yet implemented: " + ,(rref request 'path-str))))) -(define page-new-post not-implemented) -(define page-modify-post not-implemented) +;; thought: url mapping for post modification? probably including git sha1 + +(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 ((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)))))))))) + (let ((slug (make-post-key year month day post))) + (cond + ((false-if-git-error + (git-rev-parse (string-append (assq-ref index 'master) ":" slug))) + => (lambda (tree) + (let ((post (post-from-tree slug tree))) + (rcons* request + 'title "post" + 'body `((pre ,(with-output-to-string + (lambda () + (write post))))))))) + (else + (page-not-found request index))))) (define page-archives not-implemented) (define (page-debug request index) (rcons* request 'title "hello" - 'body `(div - (p "hello world!") + 'body `((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))))) diff --git a/tekuti/post.scm b/tekuti/post.scm index 1436fd8..d2f9a88 100644 --- a/tekuti/post.scm +++ b/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))) diff --git a/tekuti/request.scm b/tekuti/request.scm index 12b7e64..7ac8117 100644 --- a/tekuti/request.scm +++ b/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* rref let-request + #:export (make-request rcons rcons* rpush rpush* 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)) - (nopt (length tail)) - (nreq (- len nopt))) + (let* ((npat (length pat)) + (ntail (length tail)) + (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))) - (if (and pathtail (<= (length pathtail) nopt)) - pathtail + (let ((pathtail (list-head-match pat path (- npat ntail)))) + (pk pat npat ntail req opt nopt nreq path 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) - (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)))) + `(,path-proc-case + (,let-request ,request (method path) + (cons method path)) + ,@clauses)) diff --git a/tekuti/url.scm b/tekuti/url.scm index 459643f..ffac093 100644 --- a/tekuti/url.scm +++ b/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 diff --git a/tekuti/web.scm b/tekuti/web.scm index 833b452..f958ba6 100644 --- a/tekuti/web.scm +++ b/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 - visible-error unimplemented - url-path-split url-path-case url-relative-path-case)) + #:export (let-headers header-ref + handle-request)) -(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 *status-names* + '((200 . "OK") + (201 . "Created") + (404 . "Not Found") + (500 . "Internal Server Error"))) -(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 (status->string status) + (format #f "~a ~a" status (or (assv-ref *status-names* status) + "Unknown Error"))) +(define xhtml-doctype + (string-append + "\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) - (throw 'visible-error 404 html-body)) +(define (finalize request) + ;; 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) - (filter (lambda (x) (not (string-null? x))) - (map url:decode (string-split path #\/)))) +(define (choose-handler request) + (request-path-case + 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) + + ((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))) -(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)) +(define (handle-request request index) + (let ((handler (choose-handler request))) + (pk (finalize (handler request index)))))