;; 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 mod-lisp) #:use-module (ice-9 rdelim) #:use-module (ice-9 receive) #:use-module (sxml simple) #:use-module (sxml transform) #:use-module (tekuti url) #:use-module (tekuti util) #:use-module (tekuti config) #:export (event-loop)) (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 (write-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 xhtml-doctype (string-append "\n")) (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))) (close-port socket))) (define (with-socket proc) (pk 'listening) (let ((socket (socket PF_INET SOCK_STREAM 0))) (bind socket AF_INET (inet-aton *host*) *port*) (listen socket *backlog*) (unwind-protect (proc socket) (shutdown socket 2)))) (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)))))))