>From 701ac7028c8f412ade00aee8d9e890f329a3836b Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 7 Mar 2010 22:01:53 +0000 Subject: [PATCH] modlisp wip --- source/modlisp.html | 12 ++ source/modlisp.scm | 32 +++++ source/ossau/template.scm | 211 ++++++++++++++++++++++++++++++ source/server-utils/answer.scm | 38 ++++-- source/server-utils/big-dishing-loop.scm | 32 ++++- source/server-utils/modlisp.scm | 55 ++++++++ source/www | 1 + 7 files changed, 366 insertions(+), 15 deletions(-) create mode 100644 source/modlisp.html create mode 100755 source/modlisp.scm create mode 100644 source/ossau/template.scm create mode 100644 source/server-utils/modlisp.scm create mode 120000 source/www diff --git a/source/modlisp.html b/source/modlisp.html new file mode 100644 index 0000000..cc02e96 --- /dev/null +++ b/source/modlisp.html @@ -0,0 +1,12 @@ + + + + +$ (for-each (lambda (header) $ + +$ ) headers) $ +

Header	Value
$~a (car header)$	$~a (cdr header)$

+Posted data: $~a posted-data$. + + diff --git a/source/modlisp.scm b/source/modlisp.scm new file mode 100755 index 0000000..19a64fc --- /dev/null +++ b/source/modlisp.scm @@ -0,0 +1,32 @@ +#!/usr/bin/env guile +!# + +(set! %load-path (append %load-path '("."))) + +(use-modules (www server-utils big-dishing-loop) + (ossau template)) + +(define (modlisp-get-handler M upath headers) + (write `(upath ,upath)) + (newline) + (M #:use-modlisp-protocol!) + (M #:set-reply-status:success) + (M #:add-header #:Content-Type "text/html") + (M #:add-content (with-output-to-string + (lambda () + (process-template "modlisp.html" + (headers + (posted-data "(none)")) + (guile))))) + (M #:send-reply)) + +(define modlisp-loop + (make-big-dishing-loop #:need-headers #t + #:protocol #:modlisp + #:method-handlers `((GET . ,modlisp-get-handler) + (POST . ,modlisp-get-handler) + (HEAD . ,modlisp-get-handler)) + #:concurrency #:none + #:socket-setup `((,SO_REUSEADDR . 1)))) + +(modlisp-loop 3145) diff --git a/source/ossau/template.scm b/source/ossau/template.scm new file mode 100644 index 0000000..cc8294d --- /dev/null +++ b/source/ossau/template.scm @@ -0,0 +1,211 @@ +;;;; (ossau template) -- template file processor + +;;; Copyright (C) 2005 Neil Jerram +;;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 2.1 of the License, or (at your option) any later version. +;; +;; This library 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 +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +(define-module (ossau template) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:export (template->code) + #:export-syntax (process-template)) + +;*****************************************************************************; +;* A template file is a file of content, such as HTML, that is complete *; +;* except for places where the content needs to be filled in *; +;* programmatically. In the case of the template processor code here, the *; +;* code to fill in the dynamic content is written in Scheme and appears *; +;* inline in the template file. *; +;* *; +;* Areas of Scheme code in the template file are delimited by $. For *; +;* example: *; +;* *; +;* This page was processed by Guile $(display (version))$ *; +;* *; +;* here (display (version)) is interpreted and processed as Scheme code; *; +;* the rest is normal (HTML) content. *; +;* *; +;* If either normal content or Scheme code needs to include a $ character, *; +;* it can do so by doubling the $, as in: Price $$10.20. *; +;* *; +;* Fragments of Scheme code do not have to be individually balanced. For *; +;* example: *; +;* *; +;* $(for-each (lambda (x)$ *; +;*

The square of $(display x)$ is $(display (* x x))$

*; +;* $ ) (iota 11))$ *; +;* *; +;* A shorthand is provided for cases where a fragment only wants to display *; +;* a variable. This is $~FORMAT VARNAME$, for example $~A x$. ~FORMAT is a *; +;* format specifier understood by (ice-9 format), and VARNAME is the name of *; +;* the variable to display. *; +;* *; +;* It may sometimes help to know the exact algorithm in order to write a *; +;* piece of template file code correctly. It is as follows. *; +;* *; +;* 1. Convert the template file - even the normal content - into a big *; +;* Scheme code string by: *; +;* *; +;* - converting each fragment of normal content to `(display FRAGMENT)' *; +;* *; +;* - converting each `~FORMAT VARNAME' fragment to *; +;* `(format #t ~FORMAT VARNAME)' *; +;* *; +;* - copying other Scheme code fragments as written. *; +;* *; +;* 2. Read and evaluate this string in an environment as specified by the *; +;* arguments to process-template. *; +;* *; +;*****************************************************************************; + +;*****************************************************************************; +;* template->code *; +;* *; +;* Reads a template file and returns the Scheme code that should be read and *; +;* evaluated to generate the implied output. *; +;*****************************************************************************; +(define (template->code template) + ;***************************************************************************; + ;* Utility procedure: convert any occurrences of "$$" in STRING to just *; + ;* "$". *; + ;***************************************************************************; + (define (unescape-$$ string) + (cond ((string-match "\\$\\$" string) + => + (lambda (match-data) + (string-append (substring string 0 (match:start match-data 0)) + "$" + (unescape-$$ (substring string + (+ (match:start match-data + 0) + 1)))))) + (else string))) + ;***************************************************************************; + ;* Utility procedure: given a string read from the template file, after *; + ;* splitting between scheme and non-scheme parts, return the Scheme code *; + ;* corresponding to the template string. *; + ;***************************************************************************; + (define (make-code-string template-string in-scheme) + (if in-scheme + ;*********************************************************************; + ;* Template string should be interpreted as Scheme code. If it *; + ;* begins with "~", it is a shorthand for a format expression; *; + ;* otherwise, it is straight Scheme code and doesn't need any *; + ;* further tweaking. *; + ;*********************************************************************; + (cond ((string-match "^~[^ ]+ " template-string) + => + (lambda (match-data) + (let ((beg (match:start match-data 0)) + (end (match:end match-data 0))) + (format #f + "(format #t ~S ~A)" + (substring template-string beg (- end 1)) + (substring template-string end))))) + (else template-string)) + ;*********************************************************************; + ;* Template string is normal file content (i.e. outside Scheme *; + ;* code). The corresponding Scheme code should display it. *; + ;*********************************************************************; + (format #f "(display ~S)" template-string))) + ;***************************************************************************; + ;* Main procedure code. *; + ;***************************************************************************; + (with-input-from-file template + (lambda () + ;***********************************************************************; + ;* Loop reading lines from the template file. *; + ;***********************************************************************; + (let loop ((template-line (read-line (current-input-port) 'concat)) + (in-scheme #f) + (strings '())) + (if (eof-object? template-line) + ;*****************************************************************; + ;* EOF: return the concatenated Scheme code string. *; + ;*****************************************************************; +; (let ((code + (string-append "(begin " + (apply string-append + (reverse strings)) + ")") +; )) +; (with-output-to-file "template-debug.scm" +; (lambda () +; (display code))) +; code) + ;*****************************************************************; + ;* Not yet EOF: normal processing. First check for single "$"; *; + ;* these mark the boundaries between Scheme code and normal *; + ;* (non-Scheme) file content. *; + ;*****************************************************************; + (cond ((string-match "(^|[^$])(\\$)($|[^$])" template-line) + => + ;**********************************************************; + ;* Found a single "$", so process the part of the line *; + ;* before the "$", then toggle the in-scheme flag and *; + ;* loop to process the rest of the line. *; + ;**********************************************************; + (lambda (match-data) + (let (($pos (match:start match-data 2))) + (loop (let ((rest (substring template-line (+ $pos 1)))) + (if (<= (string-length rest) 1) + (read-line (current-input-port) 'concat) + rest)) + (not in-scheme) + (cons (make-code-string (unescape-$$ + (substring template-line + 0 + $pos)) + in-scheme) + strings))))) + ;***********************************************************; + ;* No "$" in this line, so process whole line and loop to *; + ;* read the next line. *; + ;***********************************************************; + (else + (loop (read-line (current-input-port) 'concat) + in-scheme + (cons (make-code-string (unescape-$$ template-line) + in-scheme) + strings))))))))) + +;*****************************************************************************; +;* process-template *; +;* *; +;* Processes a template file, with the generated output going to the current *; +;* output port. Returns unspecified. *; +;* *; +;* Args are: template - Name of template file. *; +;* vars - Variables to define for the Scheme code in the *; +;* template file, in the same form as a set of let *; +;* bindings, i.e. *; +;* ((variable1 value1) *; +;* (variable2 value2) *; +;* ...) *; +;* modules - List of modules that the Scheme code in the *; +;* template file uses. *; +;* *; +;*****************************************************************************; +(define-macro (process-template template vars . modules) + `(let ((module (make-module 31 + (map resolve-interface + ',modules)))) + ,@(map (lambda (vardef) + `(module-define! module + ',(if (pair? vardef) (car vardef) vardef) + ,(if (pair? vardef) (cadr vardef) vardef))) + vars) + (eval (with-input-from-string (template->code ,template) read) + module))) diff --git a/source/server-utils/answer.scm b/source/server-utils/answer.scm index 0a03906..c3cb017 100644 --- a/source/server-utils/answer.scm +++ b/source/server-utils/answer.scm @@ -203,7 +203,8 @@ (inhibit-content? #f) (direct-writers '()) (content '()) - (content-length #f)) + (content-length #f) + (modlisp #f)) (define (reset-protocol!) (set! pre-tree (list #f)) @@ -212,18 +213,29 @@ (set! inhibit-content? #f) (set! direct-writers '()) (set! content '()) - (set! content-length #f)) + (set! content-length #f) + (set! modlisp #f)) + + (define (use-modlisp-protocol!) + (set! modlisp #t)) (define (set-reply-status number msg) (status-number! number) - (let ((s (fs "HTTP/1.0 ~A ~A\r\n" number msg))) - (+! pre-len (string-length s)) - (set-car! pre-tree s))) + (if modlisp + (begin + (add-header #:Status (fs "~A" number)) + (set-car! pre-tree "")) + (let ((s (fs "HTTP/1.0 ~A ~A\r\n" number msg))) + (+! pre-len (string-length s)) + (set-car! pre-tree s)))) (define (set-reply-status:success) - (+! pre-len 17) - (status-number! 200) - (set-car! pre-tree "HTTP/1.0 200 OK\r\n")) + (if modlisp + (set-reply-status 200 "OK") + (begin + (+! pre-len 17) + (status-number! 200) + (set-car! pre-tree "HTTP/1.0 200 OK\r\n")))) (define (preamble-append! len new) (+! pre-len len) @@ -237,6 +249,11 @@ (up! (+ 2 (string-length value)) (list value CRLF))) ((eq? #t name) (up! (string-length value) value)) + (modlisp + (add-header #f (symbol->string (keyword->symbol name))) + (add-header #f (if (string? value) + value + (fs "~A" value)))) (else (let ((l/t (length/tree<-header-components name value))) (up! (car l/t) (cdr l/t)))))) @@ -330,7 +347,9 @@ (loop start)))) (or (car pre-tree) (error "reply status not set")) (and content-length (add-header #:Content-Length content-length)) - (preamble-append! 2 CRLF) + (if modlisp + (add-header #f "end") + (preamble-append! 2 CRLF)) (and (< (string-length preamble) pre-len) (set! preamble (make-string (+ pre-len 64)))) (let ((wp 0)) @@ -363,6 +382,7 @@ (apply (case command ((#:reset-protocol!) reset-protocol!) + ((#:use-modlisp-protocol!) use-modlisp-protocol!) ((#:set-reply-status) set-reply-status) ((#:set-reply-status:success) set-reply-status:success) ((#:add-header) add-header) diff --git a/source/server-utils/big-dishing-loop.scm b/source/server-utils/big-dishing-loop.scm index 6ae46a3..4400bb0 100644 --- a/source/server-utils/big-dishing-loop.scm +++ b/source/server-utils/big-dishing-loop.scm @@ -31,9 +31,10 @@ #:export (named-socket echo-upath make-big-dishing-loop) - #:use-module (ice-9 optargs-kw) + #:use-module (ice-9 optargs) #:use-module (www server-utils parse-request) - #:use-module (www server-utils answer)) + #:use-module (www server-utils answer) + #:use-module (www server-utils modlisp)) ;; Return a new socket in protocol @var{family} with address @var{name}. ;; Keywords are: @code{#:socket-setup}. @@ -252,20 +253,39 @@ (bad-request-handler #f) (concurrency #:new-process) (parent-finish close-port) - (log #f)) + (log #f) + (protocol #:http)) + + (define p-read-first-line + (case protocol + ((#:http) read-first-line) + ((#:modlisp) modlisp-http-request-line) + (else (error "Unknown protocol:" protocol)))) + + (define p-read-headers + (case protocol + ((#:http) read-headers) + ((#:modlisp) modlisp-headers) + (else (error "Unknown protocol:" protocol)))) + + (define p-skip-headers + (case protocol + ((#:http) skip-headers) + ((#:modlisp) modlisp-headers) + (else (error "Unknown protocol:" protocol)))) (define (bdlcore queue-length sock handle-request) (listen sock queue-length) (let loop ((conn (accept sock))) - (and (handle-request conn (read-first-line (car conn))) + (and (handle-request conn (p-read-first-line (car conn))) (loop (accept sock))))) (define (handle-request conn upath method) (let* ((p (car conn)) ;; headers (h (cond ((and (not need-headers) (not need-input-port))) - (need-input-port (read-headers p)) - (else (skip-headers p)))) + (need-input-port (p-read-headers p)) + (else (p-skip-headers p)))) ;; status box (b (and (number? status-box-size) (make-list status-box-size #f))) diff --git a/source/server-utils/modlisp.scm b/source/server-utils/modlisp.scm new file mode 100644 index 0000000..595b860 --- /dev/null +++ b/source/server-utils/modlisp.scm @@ -0,0 +1,55 @@ +;;; (www server-utils modlisp) --- Handlers for Apache mod_lisp protocol + +;; Copyright (C) 2010 Neil Jerram +;; +;; This file is part of Guile-WWW. +;; +;; Guile-WWW 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, or +;; (at your option) any later version. +;; +;; Guile-WWW 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 Guile-WWW; see the file COPYING. If not, +;; write to the Free Software Foundation, Inc., 51 Franklin Street, +;; Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: + +;; The (www server-utils modlisp) module +;; is fully documented in the guile-www.info file. + +;;; Code: + +(define-module (www server-utils modlisp) + #:export (modlisp-http-request-line + modlisp-headers) + #:use-module (ice-9 rdelim) + #:use-module (www server-utils parse-request) + #:use-module (www server-utils answer) + #:use-module (www server-utils modlisp)) + +(define port->headers (make-object-property)) + +(define (modlisp-headers port) + (or (port->headers port) + (begin + (let loop ((headers '()) (key (read-line port)) (value #f)) + (cond (value + (loop (acons key value headers) (read-line port) #f)) + ((string=? key "end") + (set! (port->headers port) (reverse! headers))) + (else + (loop headers key (read-line port))))) + (port->headers port)))) + +(define (modlisp-http-request-line port) + (let ((headers (modlisp-headers port))) + (list (string->symbol (assoc-ref headers "method")) + (assoc-ref headers "url") + (assoc-ref headers "server-protocol")))) diff --git a/source/www b/source/www new file mode 120000 index 0000000..945c9b4 --- /dev/null +++ b/source/www @@ -0,0 +1 @@ +. \ No newline at end of file -- 1.5.6.5