From 7fe3def61e64fcf144178ddc5f1f5ce1ef3ae25f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 17 Feb 2008 01:17:01 +0100 Subject: another checkpoint, works again! --- src/tekuti | 54 +++-------------------- tekuti/boot.scm | 123 ++++++++++++++++++++++++++++++++++++++++++++++++++++ tekuti/mod-lisp.scm | 79 +++++++++++++++++++++++---------- tekuti/page.scm | 74 ++++++++++++++++++++++++++----- tekuti/post.scm | 2 +- tekuti/request.scm | 114 ++++++++++++++++++++++++++++++++++++++++++++++++ tekuti/url.scm | 5 +-- tekuti/util.scm | 17 +++++++- tekuti/web.scm | 7 +-- 9 files changed, 385 insertions(+), 90 deletions(-) create mode 100644 tekuti/boot.scm create mode 100644 tekuti/request.scm diff --git a/src/tekuti b/src/tekuti index 2873ff6..bfff6b2 100755 --- a/src/tekuti +++ b/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 @@ -30,52 +30,10 @@ exec guile $GUILE_FLAGS -l $0 -e main "$@" ;;hack! -(debug-enable 'backtrace) -(use-modules (tekuti git) - (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))))))) - +(turn-on-debugging) +(use-modules (tekuti boot)) (define (main args) - (ensure-git-repo) - (event-loop handle-request maybe-reindex)) + (start-stack 'tekuti + (boot args))) + diff --git a/tekuti/boot.scm b/tekuti/boot.scm new file mode 100644 index 0000000..4d42fd4 --- /dev/null +++ b/tekuti/boot.scm @@ -0,0 +1,123 @@ +#! /bin/bash +# -*- scheme -*- +exec guile $GUILE_FLAGS -l $0 -e main -- "$@" +!# +;; Tekuti +;; Copyright (C) 2008 Andy Wingo + +;; 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))) diff --git a/tekuti/mod-lisp.scm b/tekuti/mod-lisp.scm index 9e37acd..3be65f4 100644 --- a/tekuti/mod-lisp.scm +++ b/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 @@ "\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 - (lambda () - (let ((sxml (handle-request headers post-data index))) - (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))) + (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)))) + (lambda args + (write-headers '(("Status" . "500 Internal Server Error") + ("Content-Type" . "text/plain")) + 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 (inner-loop socket cookie index handle-request maybe-reindex) + (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)))) + (define (event-loop 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) - (pk cookie index) - (connection-received (car pair) (cdr pair) index handle-request) - (lp cookie index))))))) + (inner-loop socket #f #f handle-request maybe-reindex)))) diff --git a/tekuti/page.scm b/tekuti/page.scm index 06ff37a..1806c6b 100644 --- a/tekuti/page.scm +++ b/tekuti/page.scm @@ -25,13 +25,67 @@ ;;; 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))))) + #: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 (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 (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)))) + (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)))) + diff --git a/tekuti/post.scm b/tekuti/post.scm index 9330611..1436fd8 100644 --- a/tekuti/post.scm +++ b/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 diff --git a/tekuti/request.scm b/tekuti/request.scm new file mode 100644 index 0000000..12b7e64 --- /dev/null +++ b/tekuti/request.scm @@ -0,0 +1,114 @@ +;; Tekuti +;; Copyright (C) 2008 Andy Wingo + +;; 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)))) diff --git a/tekuti/url.scm b/tekuti/url.scm index e55fa10..459643f 100644 --- a/tekuti/url.scm +++ b/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) - (not (memv ch reserved-chars))) + (if (safe-char? ch) (display ch) (begin (display #\%) diff --git a/tekuti/util.scm b/tekuti/util.scm index 2019f55..d594f28 100644 --- a/tekuti/util.scm +++ b/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))))) diff --git a/tekuti/web.scm b/tekuti/web.scm index f84ad2a..833b452 100644 --- a/tekuti/web.scm +++ b/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) -- cgit v1.2.3-54-g00ecf