aliens/tekuti
1
0
Fork 0
Code Activity

another checkpoint, works again!

Browse source
This commit is contained in:
Andy Wingo 2008-02-17 01:17:01 +01:00
parent fa7cc3f267
commit 7fe3def61e
9 changed files with 384 additions and 89 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

54
src/tekuti
View file

@ -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)
(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)))

123
tekuti/boot.scm Normal file
View file

@ -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)))

79
tekuti/mod-lisp.scm
View file

@ -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
(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))))

72
tekuti/page.scm
View file

@ -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 (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))))
(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)))))

2
tekuti/post.scm
View file

@ -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

114
tekuti/request.scm Normal file
View file

@ -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))))

5
tekuti/url.scm
View file

@ -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 #\%)

17
tekuti/util.scm
View file

@ -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)))))

7
tekuti/web.scm
View file

@ -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)