From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Neil Jerram Newsgroups: gmane.lisp.guile.user Subject: mod_lisp support for guile-www Date: Sun, 07 Mar 2010 23:00:13 +0000 Message-ID: <873a0bwxdu.fsf@ossau.uklinux.net> NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: dough.gmane.org 1268002854 12286 80.91.229.12 (7 Mar 2010 23:00:54 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Sun, 7 Mar 2010 23:00:54 +0000 (UTC) To: Thien-Thi Nguyen , Guile User List Original-X-From: guile-user-bounces+guile-user=m.gmane.org@gnu.org Mon Mar 08 00:00:50 2010 Return-path: Envelope-to: guile-user@m.gmane.org Original-Received: from lists.gnu.org ([199.232.76.165]) by lo.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1NoPSq-0000X7-J5 for guile-user@m.gmane.org; Mon, 08 Mar 2010 00:00:49 +0100 Original-Received: from localhost ([127.0.0.1]:57179 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1NoPSp-0001u9-TD for guile-user@m.gmane.org; Sun, 07 Mar 2010 18:00:47 -0500 Original-Received: from mailman by lists.gnu.org with tmda-scanned (Exim 4.43) id 1NoPSg-0001sm-5h for guile-user@gnu.org; Sun, 07 Mar 2010 18:00:38 -0500 Original-Received: from [140.186.70.92] (port=41365 helo=eggs.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1NoPSc-0001rL-GA for guile-user@gnu.org; Sun, 07 Mar 2010 18:00:35 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.69) (envelope-from ) id 1NoPSa-0003ME-GD for guile-user@gnu.org; Sun, 07 Mar 2010 18:00:34 -0500 Original-Received: from mail3.uklinux.net ([80.84.72.33]:58756) by eggs.gnu.org with esmtp (Exim 4.69) (envelope-from ) id 1NoPSZ-0003M5-Nt for guile-user@gnu.org; Sun, 07 Mar 2010 18:00:32 -0500 Original-Received: from arudy (host86-182-154-126.range86-182.btcentralplus.com [86.182.154.126]) by mail3.uklinux.net (Postfix) with ESMTP id AA7E01F6BA7; Sun, 7 Mar 2010 23:00:29 +0000 (GMT) Original-Received: from arudy (arudy [127.0.0.1]) by arudy (Postfix) with ESMTP id 1166D3801F; Sun, 7 Mar 2010 23:00:14 +0000 (GMT) User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/23.1 (gnu/linux) X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.4-2.6 X-BeenThere: guile-user@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: General Guile related discussions List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Original-Sender: guile-user-bounces+guile-user=m.gmane.org@gnu.org Errors-To: guile-user-bounces+guile-user=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.user:7666 Archived-At: --=-=-= Hi all! I'm working on a project that needs a web data server, and I'd like to use Apache + mod_lisp + Guile for that. I know that there is a mod_lisp_for_guile written by Alan Grover, but it bothers me that our various bits of www function aren't better integrated, and guile-www seems like the biggest and best-integrated collection of such function so far... so I've taken a look at adding mod_lisp support to guile-www. Conceptually, I think this works well. Just as an HTTP server is a "big dishing loop" that reads and writes the HTTP protocol, a mod_lisp server is a big dishing loop that reads and writes the mod_lisp protocol. In either case, above the protocol-handling layer you have the "so what do I do with this request" logic, which is conceptually the same. So another benefit of integrating mod_lisp support into guile-www is that someone can write their request-handling logic, and decide later whether to run it as part of a standalone guile-www server, or using Apache, via mod_lisp. Anyway, I attach my work in progress, for the sake of soliciting any comments that people may have, as a patch against 2.27. Please note that I'm not necessarily proposing _everything_ here for incorporation into guile-www - e.g. I think my (ossau template) module might fit better elsewhere - but I've included everything in the patch that's needed for a complete example. Thanks in advance for any comments! Neil --=-=-= Content-Type: text/x-diff Content-Disposition: attachment; filename=0001-modlisp-wip.patch >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) $ +
HeaderValue
$~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 --=-=-=--