From: Neil Jerram <neil@ossau.uklinux.net>
To: Thien-Thi Nguyen <ttn@gnuvola.org>, Guile User List <guile-user@gnu.org>
Subject: mod_lisp support for guile-www
Date: Sun, 07 Mar 2010 23:00:13 +0000 [thread overview]
Message-ID: <873a0bwxdu.fsf@ossau.uklinux.net> (raw)
[-- Attachment #1: Type: text/plain, Size: 1436 bytes --]
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
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-modlisp-wip.patch --]
[-- Type: text/x-diff, Size: 23276 bytes --]
From 701ac7028c8f412ade00aee8d9e890f329a3836b Mon Sep 17 00:00:00 2001
From: Neil Jerram <neiljerram@googlemail.com>
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 @@
+<html>
+<body>
+<table border=1>
+<tr><th>Header</th><th>Value</th></tr>
+$ (for-each (lambda (header) $
+<tr><td>$~a (car header)$</td><td>$~a (cdr header)$</td></tr>
+$ ) headers) $
+</table>
+<p>
+Posted data: $~a posted-data$.
+</body>
+</html>
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: *;
+;* *;
+;* <I>This page was processed by Guile $(display (version))$</I> *;
+;* *;
+;* 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)$ *;
+;* <LI>The square of $(display x)$ is $(display (* x x))$</LI> *;
+;* $ ) (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
next reply other threads:[~2010-03-07 23:00 UTC|newest]
Thread overview: 11+ messages / expand[flat|nested] mbox.gz Atom feed top
2010-03-07 23:00 Neil Jerram [this message]
2010-03-09 16:30 ` mod_lisp support for guile-www Thien-Thi Nguyen
2010-03-12 20:29 ` Neil Jerram
2010-03-12 21:45 ` Ludovic Courtès
2010-03-12 23:21 ` Neil Jerram
2010-03-13 4:16 ` Thien-Thi Nguyen
2010-03-16 19:48 ` Neil Jerram
2010-03-16 22:48 ` Ludovic Courtès
2010-06-17 21:42 ` Thien-Thi Nguyen
2010-07-06 23:04 ` Neil Jerram
2010-07-06 23:48 ` Thien-Thi Nguyen
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=873a0bwxdu.fsf@ossau.uklinux.net \
--to=neil@ossau.uklinux.net \
--cc=guile-user@gnu.org \
--cc=ttn@gnuvola.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).