Skip to content

Instantly share code, notes, and snippets.

@jamessanders

jamessanders/.gitignore

Forked from weaver/.gitignore
Created February 6, 2011 22:05
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save jamessanders/813764 to your computer and use it in GitHub Desktop.
Save jamessanders/813764 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
.gitignore
gambit-server/web-server
snap-hello-server/bin
snap-hello-server/dist/
Raw
README.md

Informal Web Server Benchmarks

"Hello World" webservers are compared here using the Apache Benchmark mean time per request.

Compiled Gambit is fastest. Node and Thin are neck and neck. Both are a little faster than interpreted Gambit, but not by much. The Python servers hang in there respectably.

Running the Benchmarks

  1. Install Apache, Node, Racket, Gambit-C, Eventlets, Tornado, Thin, and GHC.
  2. Run ./bin/setup
  3. Run ./bin/start in one shell to start the servers.
  4. Run ./bin/bench in another shell to run the benchmarks.

ab -n 10000 -c 32

Mean Time / Request

+ Gambit-C Compiled (gsc):    1.668 [ms]
+ Node:                       3.344 [ms]
+ Thin:                       5.007 [ms]
+ Gambit-C Interpreted (gsi): 5.160 [ms]
+ Snap:                       6.316 [ms]
+ Tornado:                    9.500 [ms]
+ Eventlets:                  11.886 [ms]
+ Racket:                     23.860 [ms]

ab -n 10000 -c 1000

Mean Time / Request

+ Gambit-C Compiled (gsc):    51.208 [ms]
+ Thin:                       133.488 [ms]
+ Node:                       135.573 [ms]
+ Gambit-C Interpreted (gsi): 167.708 [ms]
+ Snap:                       210.533 [ms]
+ Tornado:                    301.794 [ms]
+ Eventlets:                  609.218 [ms]
+ Racket:                     failed
Raw
base64#.scm
;==============================================================================
; File: "base64#.scm", Time-stamp: <2007-04-04 14:42:16 feeley>
; Copyright (c) 2005-2007 by Marc Feeley, All Rights Reserved.
;==============================================================================
(##namespace ("base64#"
; procedures
base64-string->u8vector
base64-substring->u8vector
u8vector->base64-string
u8vector->base64-substring
))
;==============================================================================
Raw
base64.scm
;==============================================================================
; File: "base64.scm", Time-stamp: <2008-12-15 11:54:22 feeley>
; Copyright (c) 2005-2008 by Marc Feeley, All Rights Reserved.
;==============================================================================
(##namespace ("base64#"))
(##include "~~lib/gambit#.scm")
(##include "base64#.scm")
(declare
(standard-bindings)
(extended-bindings)
(block)
(not safe)
(fixnum)
)
;==============================================================================
; Representation of fifos.
(##define-macro (macro-make-fifo)
`(let ((fifo (##cons '() '())))
(macro-fifo-tail-set! fifo fifo)
fifo))
(##define-macro (macro-fifo-next fifo) `(##cdr ,fifo))
(##define-macro (macro-fifo-next-set! fifo x) `(##set-cdr! ,fifo ,x))
(##define-macro (macro-fifo-tail fifo) `(##car ,fifo))
(##define-macro (macro-fifo-tail-set! fifo x) `(##set-car! ,fifo ,x))
(##define-macro (macro-fifo-elem fifo) `(##car ,fifo))
(##define-macro (macro-fifo-elem-set! fifo x) `(##set-car! ,fifo ,x))
(##define-macro (macro-fifo->list fifo)
`(macro-fifo-next ,fifo))
(##define-macro (macro-fifo-remove-all! fifo)
`(let ((fifo ,fifo))
(##declare (not interrupts-enabled))
(let ((head (macro-fifo-next fifo)))
(macro-fifo-tail-set! fifo fifo)
(macro-fifo-next-set! fifo '())
head)))
(##define-macro (macro-fifo-remove-head! fifo)
`(let ((fifo ,fifo))
(##declare (not interrupts-enabled))
(let ((head (macro-fifo-next fifo)))
(if (##pair? head)
(let ((next (macro-fifo-next head)))
(if (##null? next)
(macro-fifo-tail-set! fifo fifo))
(macro-fifo-next-set! fifo next)
(macro-fifo-next-set! head '())))
head)))
(##define-macro (macro-fifo-insert-at-tail! fifo elem)
`(let ((fifo ,fifo) (elem ,elem))
(let ((x (##cons elem '())))
(##declare (not interrupts-enabled))
(let ((tail (macro-fifo-tail fifo)))
(macro-fifo-next-set! tail x)
(macro-fifo-tail-set! fifo x)
(##void)))))
(##define-macro (macro-fifo-insert-at-head! fifo elem)
`(let ((fifo ,fifo) (elem ,elem))
(let ((x (##cons elem '())))
(##declare (not interrupts-enabled))
; To obtain an atomic update of the fifo, we must force a
; garbage-collection to occur right away if needed by the
; ##cons, so that any finalization that might mutate this fifo
; will be done before updating the fifo.
(##check-heap-limit)
(let ((head (macro-fifo-next fifo)))
(if (##null? head)
(macro-fifo-tail-set! fifo x))
(macro-fifo-next-set! fifo x)
(macro-fifo-next-set! x head)
(##void)))))
(##define-macro (macro-fifo-advance-to-tail! fifo)
`(let ((fifo ,fifo))
; It is assumed that the fifo contains at least one element
; (i.e. the fifo's tail does not change).
(let ((new-head (macro-fifo-tail fifo)))
(macro-fifo-next-set! fifo new-head)
(macro-fifo-elem new-head))))
(##define-macro (macro-fifo-advance! fifo)
`(let ((fifo ,fifo))
; It is assumed that the fifo contains at least two elements
; (i.e. the fifo's tail does not change).
(let* ((head (macro-fifo-next fifo))
(new-head (macro-fifo-next head)))
(macro-fifo-next-set! fifo new-head)
(macro-fifo-elem new-head))))
(##define-macro (fifo->u8vector fifo start end)
`(##fifo->u8vector ,fifo ,start ,end))
(##define-macro (u8vector-shrink! u8vect len)
`(##u8vector-shrink! ,u8vect ,len))
(##define-macro (fifo->string fifo start end)
`(##fifo->string ,fifo ,start ,end))
(##define-macro (string-shrink! str len)
`(##string-shrink! ,str ,len))
;==============================================================================
(define base64-string->u8vector
(lambda (str)
(base64-substring->u8vector str 0 (string-length str))))
(define base64-substring->u8vector
(lambda (str start end)
(define err
(lambda ()
(error "base64 decoding error")))
(define chunk-len 64) ; must be a power of 2
(define state
(vector 0
(macro-make-fifo)))
(define (wr-u8 x)
(let ((ptr (vector-ref state 0)))
(vector-set! state 0 (+ ptr 1))
(let ((fifo (vector-ref state 1))
(i (bitwise-and ptr (- chunk-len 1))))
(u8vector-set!
(if (= i 0)
(let ((chunk (make-u8vector chunk-len)))
(macro-fifo-insert-at-tail! fifo chunk)
chunk)
(macro-fifo-elem (macro-fifo-tail fifo)))
i
x))))
(define (get-output-u8vector)
(let ((ptr (vector-ref state 0))
(fifo (vector-ref state 1)))
(if (and (< 0 ptr) (<= ptr chunk-len))
(let ((u8vect (macro-fifo-elem (macro-fifo-tail fifo))))
(u8vector-shrink! u8vect ptr)
u8vect)
(fifo->u8vector fifo 0 ptr))))
(define decode
(lambda (c)
(cond ((and (char>=? c #\A) (char<=? c #\Z))
(- (char->integer c) (char->integer #\A)))
((and (char>=? c #\a) (char<=? c #\z))
(+ 26 (- (char->integer c) (char->integer #\a))))
((and (char>=? c #\0) (char<=? c #\9))
(+ 52 (- (char->integer c) (char->integer #\0))))
((char=? c #\+)
62)
((char=? c #\/)
63)
(else
#f))))
(define done
(lambda ()
(get-output-u8vector)))
(define add1
(lambda (x0 x1)
(add (+ (arithmetic-shift x0 2)
(arithmetic-shift x1 -4)))))
(define add2
(lambda (x0 x1 x2)
(add1 x0 x1)
(add (bitwise-and #xff
(+ (arithmetic-shift x1 4)
(arithmetic-shift x2 -2))))))
(define add3
(lambda (x0 x1 x2 x3)
(add2 x0 x1 x2)
(add (bitwise-and #xff
(+ (arithmetic-shift x2 6)
x3)))))
(define add
(lambda (x)
(wr-u8 x)))
(let loop0 ((i start))
(if (>= i end)
(done)
(let* ((c0 (string-ref str i))
(x0 (decode c0)))
(if x0
(let loop1 ((i (+ i 1)))
(if (>= i end)
(err)
(let* ((c1 (string-ref str i))
(x1 (decode c1)))
(if x1
(let loop2 ((i (+ i 1)))
(if (>= i end)
(err)
(let* ((c2 (string-ref str i))
(x2 (decode c2)))
(if x2
(let loop3 ((i (+ i 1)))
(if (>= i end)
(err)
(let* ((c3 (string-ref str i))
(x3 (decode c3)))
(if x3
(begin
(add3 x0 x1 x2 x3)
(loop0 (+ i 1)))
(if (char=? c3 #\=)
(begin
(add2 x0 x1 x2)
(done))
(loop3 (+ i 1)))))))
(if (char=? c2 #\=)
(begin
(add1 x0 x1)
(done))
(loop2 (+ i 1)))))))
(if (char=? c1 #\=)
(err)
(loop1 (+ i 1)))))))
(if (char=? c0 #\=)
(err)
(loop0 (+ i 1)))))))))
(define u8vector->base64-string
(lambda (u8vect #!optional (width 0))
(subu8vector->base64-string u8vect 0 (u8vector-length u8vect) width)))
(define subu8vector->base64-string
(lambda (u8vect start end #!optional (width 0))
(define chunk-len 64) ; must be a power of 2
(define state
(vector 0
(macro-make-fifo)))
(define (wr-char c)
(let ((ptr (vector-ref state 0)))
(vector-set! state 0 (+ ptr 1))
(let ((fifo (vector-ref state 1))
(i (bitwise-and ptr (- chunk-len 1))))
(string-set!
(if (= i 0)
(let ((chunk (make-string chunk-len)))
(macro-fifo-insert-at-tail! fifo chunk)
chunk)
(macro-fifo-elem (macro-fifo-tail fifo)))
i
c))))
(define (get-output-string)
(let ((ptr (vector-ref state 0))
(fifo (vector-ref state 1)))
(if (and (< 0 ptr) (<= ptr chunk-len))
(let ((str (macro-fifo-elem (macro-fifo-tail fifo))))
(string-shrink! str ptr)
str)
(fifo->string fifo 0 ptr))))
(define add
(lambda (c)
(wr-char c)))
(define out
(lambda (x n)
(let ((new-n
(cond ((= -1 n)
n)
((= 0 n)
(add #\newline)
(- width 1))
(else
(- n 1)))))
(add (cond ((<= x 25)
(integer->char (+ x (char->integer #\A))))
((<= x 51)
(integer->char (+ (- x 26) (char->integer #\a))))
((<= x 61)
(integer->char (+ (- x 52) (char->integer #\0))))
((= x 62)
#\+)
((= x 63)
#\/)
(else
#\=)))
new-n)))
(let loop ((i start)
(n (if (> width 0) width -1)))
(if (<= (+ i 3) end)
(let ((b0 (u8vector-ref u8vect i))
(b1 (u8vector-ref u8vect (+ i 1)))
(b2 (u8vector-ref u8vect (+ i 2))))
(let ((x0
(arithmetic-shift b0 -2))
(x1
(bitwise-and #x3f
(+ (arithmetic-shift b0 4)
(arithmetic-shift b1 -4))))
(x2
(bitwise-and #x3f
(+ (arithmetic-shift b1 2)
(arithmetic-shift b2 -6))))
(x3
(bitwise-and #x3f b2)))
(loop (+ i 3)
(out x3 (out x2 (out x1 (out x0 n)))))))
(let ((rest (- end i)))
(cond ((= rest 2)
(let ((b0 (u8vector-ref u8vect i))
(b1 (u8vector-ref u8vect (+ i 1))))
(let ((x0
(arithmetic-shift b0 -2))
(x1
(bitwise-and #x3f
(+ (arithmetic-shift b0 4)
(arithmetic-shift b1 -4))))
(x2
(bitwise-and #x3f
(arithmetic-shift b1 2)))
(x3
64))
(out x3 (out x2 (out x1 (out x0 n)))))))
((= rest 1)
(let ((b0 (u8vector-ref u8vect i)))
(let ((x0
(arithmetic-shift b0 -2))
(x1
(bitwise-and #x3f
(arithmetic-shift b0 4)))
(x2
64)
(x3
64))
(out x3 (out x2 (out x1 (out x0 n))))))))
(get-output-string))))))
;==============================================================================
Raw
bench
#!/bin/sh
run() {
sleep 1
echo "## Benchmarking $1 ##"
./bin/test $2 $3 $4 > ./results/$1-$2-$3.txt
}
suite() {
run node $1 $2 8124
run snap $1 $2 9000
run racket $1 $2 8080
run gsi $1 $2 8000
run gsc $1 $2 8001
run tornado $1 $2 8888
run eventlets $1 $2 8090
run thin $1 $2 3000
}
mkdir -p ./results
suite 10000 32
suite 10000 1000
Raw
eventlet_server.py
"""This is a simple example of running a wsgi application with eventlet.
For a more fully-featured server which supports multiple processes,
multiple threads, and graceful code reloading, see:
http://pypi.python.org/pypi/Spawning/
"""
import eventlet
from eventlet import wsgi
def hello_world(env, start_response):
if env['PATH_INFO'] != '/':
start_response('404 Not Found', [('Content-Type', 'text/plain')])
return ['Not Found\r\n']
start_response('200 OK', [('Content-Type', 'text/plain')])
return ['<html><body>Hello World</body></html>\r\n']
class DummyLog(object):
def write(self, message):
pass
wsgi.server(eventlet.listen(('', 8090)), hello_world, log=DummyLog())
Raw
html#.scm
;==============================================================================
; File: "html#.scm", Time-stamp: <2007-04-04 14:42:33 feeley>
; Copyright (c) 2005-2007 by Marc Feeley, All Rights Reserved.
;==============================================================================
(##namespace ("html#"
; procedures
write-html
<a>
<abbr>
<acronym>
<address>
<applet>
<area>
<b>
<base>
<basefont>
<bdo>
<big>
<blockquote>
<body>
<br>
<button>
<caption>
<center>
<cite>
<code>
<col>
<colgroup>
<dd>
<del>
<dfn>
<dir>
<div>
<dl>
<em>
<field-set>
<font>
<form>
<frame>
<frameset>
<h1>
<h2>
<h3>
<h4>
<h5>
<h6>
<head>
<hr>
<html>
<i>
<iframe>
<img>
<input>
<ins>
<isindex>
<kbd>
<label>
<legend>
<li>
<link>
<map>
<menu>
<meta>
<noframes>
<noscript>
<object>
<ol>
<optgroup>
<option>
<p>
<param>
<plaintext>
<pre>
<q>
<s>
<samp>
<script>
<select>
<small>
<span>
<strike>
<strong>
<style>
<sub>
<sup>
<table>
<td>
<textarea>
<tfoot>
<th>
<thead>
<title>
<tr>
<tt>
<u>
<ul>
<var>
make-unprotected
))
;==============================================================================
Raw
html.scm
;==============================================================================
; File: "html.scm", Time-stamp: <2008-12-15 11:53:45 feeley>
; Copyright (c) 2000-2008 by Brad Lucier, All Rights Reserved.
; Copyright (c) 2005-2008 by Marc Feeley, All Rights Reserved.
; This is an attempt at a complete implementation of HTML 4.0 in
; Scheme without any Netscape or Microsoft extensions.
;==============================================================================
(##namespace ("html#"))
(##include "~~lib/gambit#.scm")
(##include "html#.scm")
(declare
(standard-bindings)
(extended-bindings)
(block)
(not safe)
)
;==============================================================================
;;; All html tags are translated to scheme functions with name
;;; <tagname> that takes keyword arguments for the attributes and an
;;; optional rest parameter if the tag has an end-tag.
(define-type html
id: a121f3a9-a905-4db5-b2c2-6da0a7e47046
read-only:
unprintable:
pre-tag
body
post-tag
)
(define-type unprotected
id: 33754754-e720-4e7a-b84d-2a205415f1ff
read-only:
unprintable:
content
)
;;; Display the structure we built, which is a tree of Scheme objects.
(define (write-html x #!optional (port (current-output-port)))
(declare (fixnum))
;;; This table has a non-#f entry for every character that is valid in
;;; a standard HTML document. The entry is what should be displayed when
;;; this character occurs.
(define character-entity-table
'#(#\nul
#f; #\x01
#f; #\x02
#f; #\x03
#f; #\x04
#f; #\x05
#f; #\x06
#f; #\alarm
#f; #\backspace
#\tab
#\newline
#f; #\vtab
#f; #\page
#\return
#f; #\x0E
#f; #\x0F
#f; #\x10
#f; #\x11
#f; #\x12
#f; #\x13
#f; #\x14
#f; #\x15
#f; #\x16
#f; #\x17
#f; #\x18
#f; #\x19
#f; #\x1A
#f; #\x1B
#f; #\x1C
#f; #\x1D
#f; #\x1E
#f; #\x1F
#\space
#\!
"&quot;"
#\#
#\$
#\%
"&amp;"
#\'
#\(
#\)
#\*
#\+
#\,
#\-
#\.
#\/
#\0
#\1
#\2
#\3
#\4
#\5
#\6
#\7
#\8
#\9
#\:
#\;
"&lt;"
#\=
"&gt;"
#\?
#\@
#\A
#\B
#\C
#\D
#\E
#\F
#\G
#\H
#\I
#\J
#\K
#\L
#\M
#\N
#\O
#\P
#\Q
#\R
#\S
#\T
#\U
#\V
#\W
#\X
#\Y
#\Z
#\[
#\\
#\]
#\^
#\_
#\`
#\a
#\b
#\c
#\d
#\e
#\f
#\g
#\h
#\i
#\j
#\k
#\l
#\m
#\n
#\o
#\p
#\q
#\r
#\s
#\t
#\u
#\v
#\w
#\x
#\y
#\z
#\{
#\|
#\}
#\~
#f; #\rubout
#f; "&#128;"
#f; "&#129;"
"&#130;"
"&#131;"
"&#132;"
"&#133;"
"&#134;"
"&#135;"
"&#136;"
"&#137;"
"&#138;"
"&#139;"
"&#140;"
#f; "&#141;"
"&#142;"
#f; "&#143;"
#f; "&#144;"
"&#145;"
"&#146;"
"&#147;"
"&#148;"
"&#149;"
"&#150;"
"&#151;"
"&#152;"
"&#153;"
"&#154;"
"&#155;"
"&#156;"
#f; "&#157;"
"&#158;"
"&#159;"
"&#160;"
"&#161;"
"&#162;"
"&#163;"
"&#164;"
"&#165;"
"&#166;"
"&#167;"
"&#168;"
"&#169;"
"&#170;"
"&#171;"
"&#172;"
"&#173;"
"&#174;"
"&#175;"
"&#176;"
"&#177;"
"&#178;"
"&#179;"
"&#180;"
"&#181;"
"&#182;"
"&#183;"
"&#184;"
"&#185;"
"&#186;"
"&#187;"
"&#188;"
"&#189;"
"&#190;"
"&#191;"
"&#192;"
"&#193;"
"&#194;"
"&#195;"
"&#196;"
"&#197;"
"&#198;"
"&#199;"
"&#200;"
"&#201;"
"&#202;"
"&#203;"
"&#204;"
"&#205;"
"&#206;"
"&#207;"
"&#208;"
"&#209;"
"&#210;"
"&#211;"
"&#212;"
"&#213;"
"&#214;"
"&#215;"
"&#216;"
"&#217;"
"&#218;"
"&#219;"
"&#220;"
"&#221;"
"&#222;"
"&#223;"
"&#224;"
"&#225;"
"&#226;"
"&#227;"
"&#228;"
"&#229;"
"&#230;"
"&#231;"
"&#232;"
"&#233;"
"&#234;"
"&#235;"
"&#236;"
"&#237;"
"&#238;"
"&#239;"
"&#240;"
"&#241;"
"&#242;"
"&#243;"
"&#244;"
"&#245;"
"&#246;"
"&#247;"
"&#248;"
"&#249;"
"&#250;"
"&#251;"
"&#252;"
"&#253;"
"&#254;"
"&#255;"
))
(define (protect x)
(cond ((unprotected? x)
(d (unprotected-content x)))
((pair? x)
(for-each protect x))
((html? x)
(d (html-pre-tag x))
(protect (html-body x))
(d (html-post-tag x)))
((null? x)
(void))
((string? x)
(let ((n (string-length x)))
(let loop ((start 0) (end 0))
(if (= end n)
(write-substring x start end port)
(let* ((ch (string-ref x end))
(index (char->integer ch)))
(cond ((and (< index 256)
(vector-ref character-entity-table index))
=>
(lambda (character-value)
(if (char? character-value)
(loop start (+ end 1))
(begin ; it's a string
(write-substring
x
start
end
port)
(write-substring
character-value
0
(string-length character-value)
port)
(loop (+ end 1) (+ end 1))))))
(else
(display
(string-append
"Warning: Character (integer->char "
(number->string index)
") is not a valid HTML 4.0 character entity\n")
(current-error-port))
(loop start (+ end 1)))))))))
((char? x)
(let ((index (char->integer x)))
(cond ((and (< index 256)
(vector-ref character-entity-table index))
=>
(lambda (character-value)
(if (char? character-value)
(write-char character-value port)
(write-substring
character-value
0
(string-length character-value)
port))))
(else
(display
(string-append
"Warning: Character (integer->char "
(number->string index)
") is not a valid HTML 4.0 character entity\n")
(current-error-port))
(write-char x port)))))
(else
(display x port))))
(define (d x)
(cond ((pair? x)
(for-each d x))
((html? x)
(error "Shouldn't be a form here" x))
((null? x)
(void))
((string? x)
(write-substring x 0 (string-length x) port))
(else
(display x port))))
(protect x))
;;; this function parses the args of such a form.
(define (html-parse-args form-name end-tag? attribute-alist single-attribute-alist args)
(let loop ((args args))
(cond ((and (not (null? args)) (keyword? (car args)))
(let ((key (car args))
(args (cdr args)))
(cond ((assq key attribute-alist)
=> (lambda (entry)
(cond ((cdr entry)
(error "Keyword used more than once" form-name key))
((null? args)
(error "Keyword must take an argument" form-name key))
(else
(set-cdr! entry (car args))
(loop (cdr args))))))
((assq key single-attribute-alist)
=> (lambda (entry)
(cond ((cdr entry)
(error "Keyword used more than once" form-name key))
(else
(set-cdr! entry #t)
(loop args)))))
(else
(error "Unrecognized keyword" form-name key)))))
((and (not end-tag?) (not (null? args)))
(error "Body found in tag without end-tag" form-name args))
(else
args)))) ; return
;;; this function builds the form
(define (html-build-form pre-tag-start post-tag attribute-alist attribute-strings single-attribute-alist single-attribute-strings args)
(let ((pre-tag
(let loop ((alist attribute-alist)
(strings attribute-strings)
(out (list ">")))
(if (not (null? alist))
(let ((entry (car alist)))
(if (cdr entry)
(loop (cdr alist)
(cdr strings)
(cons (list (car strings)
(cdr entry))
out))
(loop (cdr alist)
(cdr strings)
out)))
(let loop ((alist single-attribute-alist)
(strings single-attribute-strings)
(out out))
(if (not (null? alist))
(let ((entry (car alist)))
(if (cdr entry)
(loop (cdr alist)
(cdr strings)
(cons (car strings)
out))
(loop (cdr alist)
(cdr strings)
out)))
(cons pre-tag-start out)))))))
(make-html pre-tag args post-tag)))
;;; tags are defined with this macro. It takes a required tag-name as
;;; the first argument, and the following key arguments:
;;; allow-core-attributes?: Takes the generic HTML 4.0 core attributes (default #t)
;;; end-tag?: takes an end tag and a body (default #t)
;;; start-newline?: start a newline with this tag and with its end tag
;;; attributes: the attributes of the tag that take values
;;; single-attributes: the attributes of the tag that don't take a value.
;;; There should also be a required: argument giving required
;;; attributes for each tag.
(define-macro (define-tag . args)
(let ((internal-define-tag
(lambda (tag-name
#!key
(allow-core-attributes? #t)
(end-tag? #t)
(start-newline? #f)
(end-tag-start-newline? #f)
(attributes '())
(single-attributes '()))
(let ((core-attributes '(class
dir
id
lang
onclick
ondblclick
onkeydown
onkeypress
onkeyup
onmousedown
onmousemove
onmouseout
onmouseover
onmouseup
style
title)))
(let* ((attributes
(if allow-core-attributes? (append attributes core-attributes) attributes))
(attribute-keywords
(map (lambda (x) (string->keyword (symbol->string x))) attributes))
(attribute-strings
(map (lambda (x) (string-append " " (symbol->string x) "=")) attributes))
(single-attribute-keywords
(map (lambda (x) (string->keyword (symbol->string x))) single-attributes))
(single-attribute-strings
(map (lambda (x) (string-append " " (symbol->string x))) single-attributes))
(form-name
(string->symbol (string-append "<" (symbol->string tag-name) ">"))))
`(define (,form-name . args)
(let ((attribute-alist (map (lambda (x) (cons x #f)) ,(list 'quote attribute-keywords)))
(single-attribute-alist (map (lambda (x) (cons x #f)) ,(list 'quote single-attribute-keywords))))
(let ((args (html-parse-args ,(list 'quote form-name) ,end-tag? attribute-alist single-attribute-alist args)))
(html-build-form
,(string-append (if start-newline? "\n" "")
"<"
(symbol->string tag-name))
,(if end-tag?
(string-append (if end-tag-start-newline? "\n" "")
"</"
(symbol->string tag-name)
">")
''())
attribute-alist
,(list 'quote attribute-strings)
single-attribute-alist
,(list 'quote single-attribute-strings)
args)))))))))
(apply internal-define-tag args)))
(define-macro (foo x) 111)
(define-macro (bar x) 222)
(define-tag a attributes: (accesskey charset coords href hreflang name rel rev shape tabindex target type))
(define-tag abbr)
(define-tag acronym)
(define-tag address)
(define-tag applet allow-core-attributes?: #f attributes: (align alt archive class code codebase height hspace id name object style title vspace width))
(define-tag area end-tag?: #f attributes: (accesskey alt coords href onblur onfocus shape tabindex taborder target) single-attributes: (nohref))
(define-tag b)
(define-tag base allow-core-attributes?: #f end-tag?: #f attributes: (href target))
(define-tag basefont allow-core-attributes?: #f end-tag?: #f attributes: (color face id size))
(define-tag bdo allow-core-attributes?: #f attributes: (class dir id lang style title))
(define-tag big)
(define-tag blockquote start-newline?: #t end-tag-start-newline?: #t attributes: (cite))
(define-tag body start-newline?: #t end-tag-start-newline?: #t attributes: (alink background bgcolor link onload onunload text vlink))
(define-tag br start-newline?: #t allow-core-attributes?: #f end-tag?: #f attributes: (class clear id style title))
(define-tag button start-newline?: #t attributes: (accesskey name onblur onfocus type tabindex value) single-attributes: (disabled))
(define-tag caption start-newline?: #t attributes: (align))
(define-tag center start-newline?: #t)
(define-tag cite start-newline?: #t)
(define-tag code)
(define-tag col end-tag?: #f start-newline?: #t attributes: (align char charoff span valign width))
(define-tag colgroup end-tag?: #f start-newline?: #t attributes: (align char charoff span valign width))
(define-tag dd)
(define-tag del attributes: (cite datetime))
(define-tag dfn)
(define-tag dir single-attributes: (compact))
(define-tag div attributes: (align))
(define-tag dl single-attributes: (compact))
(define-tag em)
(define-tag field-set)
(define-tag font allow-core-attributes?: #f attributes: (class color dir face id lang size style title))
(define-tag form start-newline?: #t end-tag-start-newline?: #t attributes: (accept-charset action enctype method onreset onsubmit target))
(define-tag frame allow-core-attributes?: #f start-newline?: #t attributes: (class frameborder id longdesc marginheight marginwidth name scrolling src style title) single-attributes: (noresize))
(define-tag frameset start-newline?: #t attributes: (cols onload onunload rows))
(define-tag h1 start-newline?: #t attributes: (align))
(define-tag h2 start-newline?: #t attributes: (align))
(define-tag h3 start-newline?: #t attributes: (align))
(define-tag h4 start-newline?: #t attributes: (align))
(define-tag h5 start-newline?: #t attributes: (align))
(define-tag h6 start-newline?: #t attributes: (align))
(define-tag head allow-core-attributes?: #f start-newline?: #t end-tag-start-newline?: #t attributes: (dir lang profile))
(define-tag hr allow-core-attributes?: #f end-tag?: #f start-newline?: #t attributes: (align class id onclick ondblclick onkeydown onkeypress onkeyup onmousedown onmousemove onmouseout onmouseover onmouseup size style title width) single-attributes: (noshade))
(define-tag html allow-core-attributes?: #f end-tag-start-newline?: #t attributes: (dir lang version))
(define-tag i)
(define-tag iframe allow-core-attributes?: #f attributes: (align class frameborder height id longdesc marginheight marginwidth name scrolling src style title width))
(define-tag img end-tag?: #f attributes: (align alt border height hspace longdesc src usemap vspace width) single-attributes: (ismap))
;; we'll define input by hand at end
(define-tag ins attributes: (cite datetime))
(define-tag isindex end-tag?: #f allow-core-attributes?: #f attributes: (class dir id lang prompt style title))
(define-tag kbd)
(define-tag label attributes: (accesskey for onblur onfocus))
(define-tag legend attributes: (accesskey align))
(define-tag li start-newline?: #t attributes: (type value))
(define-tag link end-tag?: #f attributes: (charset href hreflang media rel rev type))
(define-tag map attributes: (name))
(define-tag menu single-attributes: (compact))
(define-tag meta end-tag?: #f allow-core-attributes?: #f attributes: (content dir http-equiv lang name scheme))
(define-tag noframes)
(define-tag noscript)
(define-tag object
end-tag?: #f start-newline?: #t
attributes: (align archive border classid codebase codetype data height hspace name standby tabindex type usemap vspace width)
single-attributes: (declare))
(define-tag ol start-newline?: #t end-tag-start-newline?: #t attributes: (start type) single-attributes: (compact))
(define-tag optgroup attributes: (label) single-attributes: (disabled))
(define-tag option attributes: (label value) single-attributes: (disabled selected))
(define-tag p start-newline?: #t attributes: (align))
(define-tag param allow-core-attributes?: #f attributes: (id name type value valuetype))
(define-tag plaintext start-newline?: #t end-tag?: #f)
(define-tag pre start-newline?: #t attributes: (width))
(define-tag q attributes: (cite))
(define-tag s)
(define-tag samp)
(define-tag script allow-core-attributes?: #f attributes: (charset language source type) single-attributes: (defer))
(define-tag select attributes: (name onblur onchange onfocus size tabindex) single-attributes: (disabled multiple))
(define-tag small)
(define-tag span)
(define-tag strike)
(define-tag strong)
(define-tag style allow-core-attributes?: #f attributes: (dir lang media title type))
(define-tag sub)
(define-tag sup)
(define-tag table start-newline?: #t attributes: (align bgcolor border cellpadding cellspacing frame rules summary width))
(define-tag td start-newline?: #t attributes: (abbr align axis bgcolor char charoff colspan headers height rowspan scope valign width) single-attributes: (nowrap))
(define-tag textarea attributes: (accesskey cols name onblur onchange onfocus onselect rows tabindex) single-attributes: (disabled readonly))
(define-tag tfoot start-newline?: #t attributes: (align char charoff valign))
(define-tag th attributes: (abbr align axis bgcolor char charoff colspan headers height rowspan scope valign width) single-attributes: (nowrap))
(define-tag thead start-newline?: #t attributes: (align char charoff valign))
(define-tag title start-newline?: #t allow-core-attributes?: #f attributes: (dir lang))
(define-tag tr attributes: (align char charolff valign))
(define-tag tt)
(define-tag u)
(define-tag ul start-newline?: #t end-tag-start-newline?: #t attributes: (type) single-attributes: (compact))
(define-tag var)
;;; because the attributes that an input tag accepts depends on its
;;; type attribute, the input tag does not follow the form given
;;; above, so we define it by hand here.
(define-macro (define-input-tag)
(let ((button-attributes '(type:
accesskey:
name:
onblur:
onfocus:
tabindex:
value:
class:
dir:
id:
lang:
onclick:
ondblclick:
onkeydown:
onkeypress:
onkeyup:
onmousedown:
onmousemove:
onmouseout:
onmouseover:
onmouseup:
style:
title:))
(button-single-attributes '(disabled:))
(checkbox-attributes '(type:
accesskey:
name:
tabindex:
value:
class:
dir:
id:
lang:
onclick:
ondblclick:
onkeydown:
onkeypress:
onkeyup:
onmousedown:
onmousemove:
onmouseout:
onmouseover:
onmouseup:
style:
title:))
(checkbox-single-attributes '(checked: disabled: readonly:))
(file-attributes '(type:
accesskey:
maxlength:
name:
onblur:
onchange:
onfocus:
size:
tabindex:
value:
class:
dir:
id:
lang:
onclick:
ondblclick:
onkeydown:
onkeypress:
onkeyup:
onmousedown:
onmousemove:
onmouseout:
onmouseover:
onmouseup:
style:
title:))
(file-single-attributes '(disabled: readonly:))
(hidden-attributes '(type:
name:
value:
class:
dir:
id:
lang:
onclick:
ondblclick:
onkeydown:
onkeypress:
onkeyup:
onmousedown:
onmousemove:
onmouseout:
onmouseover:
onmouseup:
style:
title:))
(hidden-single-attributes '())
(image-attributes '(type:
accesskey:
align:
alt:
border:
name:
src:
tabindex:
usemap:
class:
dir:
id:
lang:
onclick:
ondblclick:
onkeydown:
onkeypress:
onkeyup:
onmousedown:
onmousemove:
onmouseout:
onmouseover:
onmouseup:
style:
title:))
(image-single-attributes '(disabled:))
(password-attributes '(type:
acccesskey:
maxlength:
name:
onblur:
onchange:
onfocus:
onselect:
size:
tabindex:
value:
class:
dir:
id:
lang:
onclick:
ondblclick:
onkeydown:
onkeypress:
onkeyup:
onmousedown:
onmousemove:
onmouseout:
onmouseover:
onmouseup:
style:
title:))
(password-single-attributes '(disabled: readonly:))
(radio-attributes '(type:
accesskey:
name:
tabindex:
value:
class:
dir:
id:
lang:
onclick:
ondblclick:
onkeydown:
onkeypress:
onkeyup:
onmousedown:
onmousemove:
onmouseout:
onmouseover:
onmouseup:
style:
title:))
(radio-single-attributes '(checked: disabled: readonly:))
(reset-attributes '(type:
accesskey:
tabindex:
value:
class:
dir:
id:
lang:
onclick:
ondblclick:
onkeydown:
onkeypress:
onkeyup:
onmousedown:
onmousemove:
onmouseout:
onmouseover:
onmouseup:
style:
title:))
(reset-single-attributes '(disabled:))
(submit-attributes '(type:
accesskey:
name:
tabindex:
value:
class:
dir:
id:
lang:
onclick:
ondblclick:
onkeydown:
onkeypress:
onkeyup:
onmousedown:
onmousemove:
onmouseout:
onmouseover:
onmouseup:
style:
title:))
(submit-single-attributes '(disabled:))
(text-attributes '(type:
accesskey:
maxlength:
name:
onblur:
onchange:
onfocus:
onselect:
size:
tabindex:
value:
class:
dir:
id:
lang:
onclick:
ondblclick:
onkeydown:
onkeypress:
onkeyup:
onmousedown:
onmousemove:
onmouseout:
onmouseover:
onmouseup:
style:
title:))
(text-single-attributes '(disabled: readonly:)))
`(define (<input> . args)
(let ((type-tag (memq type: args)))
(if (or (not type-tag)
(null? (cdr type-tag))
(not (symbol? (cadr type-tag))))
(error "The input type tag must be present and its value must be a symbol" args))
(let* ((input-type (cadr type-tag))
(attribute-alist (map (lambda (x) (cons x #f))
(case input-type
((button) ,(list 'quote button-attributes))
((checkbox) ,(list 'quote checkbox-attributes))
((file) ,(list 'quote file-attributes))
((hidden) ,(list 'quote hidden-attributes))
((image) ,(list 'quote image-attributes))
((password) ,(list 'quote password-attributes))
((radio) ,(list 'quote radio-attributes))
((submit) ,(list 'quote submit-attributes))
((text) ,(list 'quote text-attributes))
(else (error "The input type tag is not valid" args)))))
(attribute-strings (case input-type
((button) ,(list 'quote (map (lambda (x) (string-append " " (keyword->string x) "=")) button-attributes)))
((checkbox) ,(list 'quote (map (lambda (x) (string-append " " (keyword->string x) "=")) checkbox-attributes)))
((file) ,(list 'quote (map (lambda (x) (string-append " " (keyword->string x) "=")) file-attributes)))
((hidden) ,(list 'quote (map (lambda (x) (string-append " " (keyword->string x) "=")) hidden-attributes)))
((image) ,(list 'quote (map (lambda (x) (string-append " " (keyword->string x) "=")) image-attributes)))
((password) ,(list 'quote (map (lambda (x) (string-append " " (keyword->string x) "=")) password-attributes)))
((radio) ,(list 'quote (map (lambda (x) (string-append " " (keyword->string x) "=")) radio-attributes)))
((submit) ,(list 'quote (map (lambda (x) (string-append " " (keyword->string x) "=")) submit-attributes)))
((text) ,(list 'quote (map (lambda (x) (string-append " " (keyword->string x) "=")) text-attributes)))
(else (error "The input type tag is not valid" args))))
(single-attribute-alist (map (lambda (x) (cons x #f))
(case input-type
((button) ,(list 'quote button-single-attributes))
((checkbox) ,(list 'quote checkbox-single-attributes))
((file) ,(list 'quote file-single-attributes))
((hidden) ,(list 'quote hidden-single-attributes))
((image) ,(list 'quote image-single-attributes))
((password) ,(list 'quote password-single-attributes))
((radio),(list 'quote radio-single-attributes))
((submit) ,(list 'quote submit-single-attributes))
((text) ,(list 'quote text-single-attributes))
(else (error "The input type tag is not valid" args)))))
(single-attribute-strings (case input-type
((button) ,(list 'quote (map (lambda (x) (string-append " " (keyword->string x))) button-single-attributes)))
((checkbox) ,(list 'quote (map (lambda (x) (string-append " " (keyword->string x))) checkbox-single-attributes)))
((file) ,(list 'quote (map (lambda (x) (string-append " " (keyword->string x))) file-single-attributes)))
((hidden) ,(list 'quote (map (lambda (x) (string-append " " (keyword->string x))) hidden-single-attributes)))
((image) ,(list 'quote (map (lambda (x) (string-append " " (keyword->string x))) image-single-attributes)))
((password) ,(list 'quote (map (lambda (x) (string-append " " (keyword->string x))) password-single-attributes)))
((radio),(list 'quote (map (lambda (x) (string-append " " (keyword->string x))) radio-single-attributes)))
((submit) ,(list 'quote (map (lambda (x) (string-append " " (keyword->string x))) submit-single-attributes)))
((text) ,(list 'quote (map (lambda (x) (string-append " " (keyword->string x))) text-single-attributes)))
(else (error "The input type tag is not valid" args)))))
(let ((args (html-parse-args '<input> #t attribute-alist single-attribute-alist args)))
(html-build-form "\n<input" "\n</input>"
attribute-alist
attribute-strings
single-attribute-alist
single-attribute-strings
args)))))))
(define-input-tag)
;==============================================================================
Raw
http#.scm
;==============================================================================
; File: "http#.scm", Time-stamp: <2007-04-04 14:42:52 feeley>
; Copyright (c) 2005-2007 by Marc Feeley, All Rights Reserved.
;==============================================================================
(##namespace ("http#"
; procedures
make-http-server
http-server-start!
reply
reply-html
current-request
make-request
request?
request-attributes
request-attributes-set!
request-connection
request-connection-set!
request-method
request-method-set!
request-query
request-query-set!
request-server
request-server-set!
request-uri
request-uri-set!
request-version
request-version-set!
make-server
server?
server-method-table
server-method-table-set!
server-port-number
server-port-number-set!
server-threaded?
server-threaded?-set!
server-timeout
server-timeout-set!
make-uri
uri?
uri-authority
uri-authority-set!
uri-fragment
uri-fragment-set!
uri-path
uri-path-set!
uri-query
uri-query-set!
uri-scheme
uri-scheme-set!
string->uri
string->uri-query
encode-for-uri
encode-x-www-form-urlencoded
decode-x-www-form-urlencoded
get-content
))
;==============================================================================
Raw
http.scm
;==============================================================================
; File: "http.scm", Time-stamp: <2009-03-13 12:05:07 feeley>
; Copyright (c) 2005-2008 by Marc Feeley, All Rights Reserved.
;==============================================================================
(##namespace ("http#"))
(##include "~~lib/gambit#.scm")
(##include "html#.scm")
(##include "http#.scm")
(declare
(standard-bindings)
(extended-bindings)
(block)
(not safe)
)
;==============================================================================
; Token tables.
(define hash-substring
(lambda (str start end)
(define loop
(lambda (h i)
(if (< i end)
(loop (modulo (+ (* h 5063) (char->integer (string-ref str i)))
65536)
(+ i 1))
h)))
(loop 0 start)))
(define-macro make-token-table
(lambda alist
; "alist" is a list of lists of the form "(string expression)"
; The result is a perfect hash-table represented as a vector of
; length 2*N, where N is the hash modulus. If the string S is in
; the hash-table it is at index
;
; X = (* 2 (modulo (hash-substring S 0 (string-length S)) N))
;
; and the associated expression is at index X+1.
(define hash-substring ; repeated from above to be
(lambda (str start end) ; available for macro expansion
(define loop
(lambda (h i)
(if (< i end)
(loop (modulo (+ (* h 5063) (char->integer (string-ref str i)))
65536)
(+ i 1))
h)))
(loop 0 start)))
(define make-perfect-hash-table
(lambda (alist)
(let loop1 ((n (length alist)))
(let ((v (make-vector (* 2 n) #f)))
(let loop2 ((lst alist))
(if (pair? lst)
(let* ((x (car lst))
(str (car x)))
(let ((h
(* 2
(modulo (hash-substring str 0 (string-length str))
n))))
(if (vector-ref v h)
(loop1 (+ n 1))
(begin
(vector-set! v h str)
(vector-set! v (+ h 1) (cadr x))
(loop2 (cdr lst))))))
v))))))
(cons 'vector (vector->list (make-perfect-hash-table alist)))))
(define token-table-lookup-substring
(lambda (table str start end)
(let* ((n (quotient (vector-length table) 2))
(h (* 2 (modulo (hash-substring str start end) n)))
(x (vector-ref table h)))
(define loop
(lambda (i j)
(if (< i end)
(if (char=? (string-ref str i) (string-ref x j))
(loop (+ i 1) (+ j 1))
#f)
h)))
(and x
(= (string-length x) (- end start))
(loop start 0)))))
(define token-table-lookup-string
(lambda (table str)
(token-table-lookup-substring table str 0 (string-length str))))
;==============================================================================
; URI parsing.
(define hex-digit
(lambda (str i)
(let ((n (char->integer (string-ref str i))))
(cond ((and (>= n 48) (<= n 57))
(- n 48))
((and (>= n 65) (<= n 70))
(- n 55))
((and (>= n 97) (<= n 102))
(- n 87))
(else
#f)))))
(define hex-octet
(lambda (str i)
(let ((n1 (hex-digit str i)))
(and n1
(let ((n2 (hex-digit str (+ i 1))))
(and n2
(+ (* n1 16) n2)))))))
(define plausible-hex-escape?
(lambda (str end j)
(and (< (+ j 2) end)
(not (control-or-space-char? (string-ref str (+ j 1))))
(not (control-or-space-char? (string-ref str (+ j 2)))))))
(define control-or-space-char?
(lambda (c)
(or (not (char<? #\space c))
(not (char<? c #\x7f)))))
(define excluded-char?
(lambda (c)
(or (not (char<? #\space c))
(not (char<? c #\x7f))
(char=? c #\<)
(char=? c #\>)
(char=? c #\#)
(char=? c #\%)
(char=? c #\")
(char=? c #\{)
(char=? c #\})
(char=? c #\|)
(char=? c #\\)
(char=? c #\^)
(char=? c #\[)
(char=? c #\])
(char=? c #\`))))
(define extract-escaped
(lambda (str start n)
(let ((result (make-string n)))
(let loop ((i start) (j 0))
(if (< j n)
(let ((c (string-ref str i)))
(if (char=? c #\%)
(let ((n (hex-octet str (+ i 1))))
(and n
(begin
(string-set! result j (integer->char n))
(loop (+ i 3)
(+ j 1)))))
(begin
(string-set! result j (if (char=? c #\+) #\space c))
(loop (+ i 1)
(+ j 1)))))
result)))))
(define-type uri
id: 62788556-c247-11d9-9598-00039301ba52
scheme
authority
path
query
fragment
)
(define parse-uri
(lambda (str start end decode? cont)
(let ((uri (make-uri #f #f "" #f #f)))
(define extract-string
(lambda (i j n)
(if decode?
(extract-escaped str i n)
(substring str i j))))
(define extract-query
(lambda (i j n)
(if decode?
(parse-uri-query
str
i
j
decode?
(lambda (bindings end)
bindings))
(substring str i j))))
(define state0 ; possibly inside the "scheme" part
(lambda (i j n)
(if (< j end)
(let ((c (string-ref str j)))
(cond ((char=? c #\:)
(if (= n 0)
(state2 j (+ j 1) 1) ; the ":" is in the "path" part
(let ((scheme (extract-string i j n)))
(and scheme
(begin
(uri-scheme-set! uri scheme)
(if (and (< (+ j 2) end)
(char=? (string-ref str (+ j 1))
#\/)
(char=? (string-ref str (+ j 2))
#\/))
(state1 (+ j 3) (+ j 3) 0)
(state2 (+ j 1) (+ j 1) 0)))))))
((char=? c #\/)
(if (and (= n 0)
(< (+ j 1) end)
(char=? (string-ref str (+ j 1)) #\/))
(state1 (+ j 2) (+ j 2) 0)
(state2 i (+ j 1) (+ n 1))))
((char=? c #\?)
(let ((path (extract-string i j n)))
(and path
(begin
(uri-path-set! uri path)
(state3 (+ j 1) (+ j 1) 0)))))
((char=? c #\#)
(let ((path (extract-string i j n)))
(and path
(begin
(uri-path-set! uri path)
(state4 (+ j 1) (+ j 1) 0)))))
((char=? c #\%)
(and (plausible-hex-escape? str end j)
(state0 i (+ j 3) (+ n 1))))
((control-or-space-char? c)
(let ((path (extract-string i j n)))
(and path
(begin
(uri-path-set! uri path)
j))))
(else
(state0 i (+ j 1) (+ n 1)))))
(let ((path (extract-string i j n)))
(and path
(begin
(uri-path-set! uri path)
j))))))
(define state1 ; inside the "authority" part
(lambda (i j n)
(if (< j end)
(let ((c (string-ref str j)))
(cond ((char=? c #\/)
(let ((authority (extract-string i j n)))
(and authority
(begin
(uri-authority-set! uri authority)
(state2 j (+ j 1) 1)))))
((char=? c #\?)
(let ((authority (extract-string i j n)))
(and authority
(begin
(uri-authority-set! uri authority)
(state3 (+ j 1) (+ j 1) 0)))))
((char=? c #\#)
(let ((authority (extract-string i j n)))
(and authority
(begin
(uri-authority-set! uri authority)
(state4 (+ j 1) (+ j 1) 0)))))
((char=? c #\%)
(and (plausible-hex-escape? str end j)
(state1 i (+ j 3) (+ n 1))))
((control-or-space-char? c)
(let ((authority (extract-string i j n)))
(and authority
(begin
(uri-authority-set! uri authority)
j))))
(else
(state1 i (+ j 1) (+ n 1)))))
(let ((authority (extract-string i j n)))
(and authority
(begin
(uri-authority-set! uri authority)
j))))))
(define state2 ; inside the "path" part
(lambda (i j n)
(if (< j end)
(let ((c (string-ref str j)))
(cond ((char=? c #\?)
(let ((path (extract-string i j n)))
(and path
(begin
(uri-path-set! uri path)
(state3 (+ j 1) (+ j 1) 0)))))
((char=? c #\#)
(let ((path (extract-string i j n)))
(and path
(begin
(uri-path-set! uri path)
(state4 (+ j 1) (+ j 1) 0)))))
((char=? c #\%)
(and (plausible-hex-escape? str end j)
(state2 i (+ j 3) (+ n 1))))
((control-or-space-char? c)
(let ((path (extract-string i j n)))
(and path
(begin
(uri-path-set! uri path)
j))))
(else
(state2 i (+ j 1) (+ n 1)))))
(let ((path (extract-string i j n)))
(and path
(begin
(uri-path-set! uri path)
j))))))
(define state3 ; inside the "query" part
(lambda (i j n)
(if (< j end)
(let ((c (string-ref str j)))
(cond ((char=? c #\#)
(let ((query (extract-query i j n)))
(and query
(begin
(uri-query-set! uri query)
(state4 (+ j 1) (+ j 1) 0)))))
((char=? c #\%)
(and (plausible-hex-escape? str end j)
(state3 i (+ j 3) (+ n 1))))
((control-or-space-char? c)
(let ((query (extract-query i j n)))
(and query
(begin
(uri-query-set! uri query)
j))))
(else
(state3 i (+ j 1) (+ n 1)))))
(let ((query (extract-query i j n)))
(and query
(begin
(uri-query-set! uri query)
j))))))
(define state4 ; inside the "fragment" part
(lambda (i j n)
(if (< j end)
(let ((c (string-ref str j)))
(cond ((char=? c #\%)
(and (plausible-hex-escape? str end j)
(state4 i (+ j 3) (+ n 1))))
((control-or-space-char? c)
(let ((fragment (extract-string i j n)))
(and fragment
(begin
(uri-fragment-set! uri fragment)
j))))
(else
(state4 i (+ j 1) (+ n 1)))))
(let ((fragment (extract-string i j n)))
(and fragment
(begin
(uri-fragment-set! uri fragment)
j))))))
(let ((i (state0 start start 0)))
(cont (and i uri)
(or i start))))))
(define parse-uri-query
(lambda (str start end decode? cont)
(let ((rev-bindings '()))
(define extract-string
(lambda (i j n)
(if decode?
(extract-escaped str i n)
(substring str i j))))
(define state0
(lambda (i j n)
(if (< j end)
(let ((c (string-ref str j)))
(cond ((char=? c #\%)
(and (plausible-hex-escape? str end j)
(state0 i
(+ j 3)
(+ n 1))))
((char=? c #\=)
(let ((name (extract-string i j n)))
(and name
(let ((j (+ j 1)))
(state1 j
j
0
name)))))
((char=? c #\&)
#f)
((excluded-char? c)
(if (= n 0)
j
#f))
(else
(state0 i
(+ j 1)
(+ n 1)))))
(if (= n 0)
j
#f))))
(define state1
(lambda (i j n name)
(if (< j end)
(let ((c (string-ref str j)))
(cond ((char=? c #\%)
(and (plausible-hex-escape? str end j)
(state1 i
(+ j 3)
(+ n 1)
name)))
((char=? c #\&)
(let ((val (extract-string i j n)))
(and val
(let ((j (+ j 1)))
(set! rev-bindings
(cons (cons name val) rev-bindings))
(and (< j end)
(state0 j
j
0))))))
((char=? c #\=)
#f)
((excluded-char? c)
(let ((val (extract-string i j n)))
(and val
(begin
(set! rev-bindings
(cons (cons name val) rev-bindings))
j))))
(else
(state1 i
(+ j 1)
(+ n 1)
name))))
(let ((val (extract-string i j n)))
(and val
(begin
(set! rev-bindings
(cons (cons name val) rev-bindings))
j))))))
(let ((i (state0 start start 0)))
(cont (and i (reverse rev-bindings))
(or i start))))))
(define string->uri
(lambda (str decode?)
(parse-uri str
0
(string-length str)
decode?
(lambda (uri end)
(and (= end (string-length str))
uri)))))
(define string->uri-query
(lambda (str decode?)
(parse-uri-query str
0
(string-length str)
decode?
(lambda (query end)
(and (= end (string-length str))
query)))))
(define encode-for-uri
(lambda (str)
(let ((end (string-length str)))
(define copy
(lambda (result i j n)
(if (< i j)
(let ((new-j (- j 1))
(new-n (- n 1)))
(string-set! result new-n (string-ref str new-j))
(copy result i new-j new-n))
result)))
(define hex
(lambda (x)
(string-ref "0123456789ABCDEF" (bitwise-and x 15))))
(define encode
(lambda (i j n)
(if (< j end)
(let ((c (string-ref str j)))
(cond ((char=? c #\space)
(let ((result (encode (+ j 1) (+ j 1) (+ n 1))))
(string-set! result n #\+)
(copy result i j n)))
((or (char=? c #\+)
(excluded-char? c))
(let ((result (encode (+ j 1) (+ j 1) (+ n 3))))
(let* ((x (char->integer c))
(hi (hex (arithmetic-shift x -4)))
(lo (hex x)))
(string-set! result n #\%)
(string-set! result (+ n 1) hi)
(string-set! result (+ n 2) lo))
(copy result i j n)))
(else
(encode i (+ j 1) (+ n 1)))))
(let ((result (make-string n)))
(copy result i j n)))))
(encode 0 0 0))))
;==============================================================================
; x-www-form-urlencoded encoding and decoding.
(define encode-x-www-form-urlencoded
(lambda (fields)
(define write-urlencoded
(lambda (str)
(define write-nibble
(lambda (n)
(write-char (string-ref "0123456789ABCDEF" n))))
(let loop ((i 0))
(if (< i (string-length str))
(let ((c (string-ref str i)))
(cond ((or (and (char>=? c #\a) (char<=? c #\z))
(and (char>=? c #\A) (char<=? c #\Z))
(and (char>=? c #\0) (char<=? c #\9)))
(write-char c))
((char=? c #\space)
(write-char #\+))
(else
(let ((n (char->integer c)))
(write-char #\%)
(write-nibble
(bitwise-and (arithmetic-shift n -4) 15))
(write-nibble (bitwise-and n 15)))))
(loop (+ i 1)))))))
(define write-field
(lambda (field)
(write-urlencoded (car field))
(write-char #\=)
(write-urlencoded (cdr field))))
(if (null? fields)
""
(with-output-to-string
""
(lambda ()
(let ((field1 (car fields)))
(write-field field1)
(for-each (lambda (field)
(write-char #\&)
(write-field field))
(cdr fields))))))))
(define decode-x-www-form-urlencoded
(lambda (str)
(let ((n (string-length str)))
(define extract
(lambda (start len)
(let ((s (make-string len)))
(let loop ((i start) (j 0))
(if (< j len)
(let ((c (string-ref str i)))
(cond ((char=? c #\%)
(cond ((hex (+ i 1))
=>
(lambda (x)
(string-set! s j (integer->char x))
(loop (+ i 3) (+ j 1))))
(else
#f)))
((char=? c #\+)
(string-set! s j #\space)
(loop (+ i 1) (+ j 1)))
(else
(string-set! s j c)
(loop (+ i 1) (+ j 1)))))
s)))))
(define hex
(lambda (i)
(if (< (+ i 1) n)
(let ((h1 (nibble i))
(h2 (nibble (+ i 1))))
(and h1 h2 (+ (* h1 16) h2)))
#f)))
(define nibble
(lambda (i)
(let ((c (string-ref str i)))
(cond ((and (char>=? c #\0) (char<=? c #\9))
(- (char->integer c) (char->integer #\0)))
((and (char>=? c #\a) (char<=? c #\f))
(+ 10 (- (char->integer c) (char->integer #\a))))
((and (char>=? c #\A) (char<=? c #\F))
(+ 10 (- (char->integer c) (char->integer #\A))))
(else
#f)))))
(define state0 ; at beginning of string
(lambda (i rev-fields)
(if (< i n)
(state1 i
i
0
rev-fields)
(reverse rev-fields))))
(define state1 ; in field name
(lambda (i start len rev-fields)
(if (< i n)
(let ((c (string-ref str i)))
(cond ((char=? c #\=)
(state2 (+ i 1)
(+ i 1)
0
(extract start len)
rev-fields))
((char=? c #\%)
(and (hex (+ i 1))
(state1 (+ i 3)
start
(+ len 1)
rev-fields)))
(else
(state1 (+ i 1)
start
(+ len 1)
rev-fields))))
#f)))
(define state2 ; in field value
(lambda (i start len name rev-fields)
(define end-of-field
(lambda ()
(cons (cons name (extract start len))
rev-fields)))
(if (< i n)
(let ((c (string-ref str i)))
(cond ((char=? c #\&)
(state1 (+ i 1)
(+ i 1)
0
(end-of-field)))
((char=? c #\%)
(and (hex (+ i 1))
(state2 (+ i 3)
start
(+ len 1)
name
rev-fields)))
(else
(state2 (+ i 1)
start
(+ len 1)
name
rev-fields))))
(reverse (end-of-field)))))
(state0 0 '()))))
;==============================================================================
; HTTP server.
(define-type server
id: c69165bd-c13f-11d9-830f-00039301ba52
port-number
timeout
threaded?
method-table
)
(define-type request
id: 8e66862f-c143-11d9-9f4e-00039301ba52
(server unprintable:)
connection
method
uri
version
attributes
query
)
(define make-http-server
(lambda (#!key
(port-number 80)
(timeout 300)
(threaded? #f)
(OPTIONS unimplemented-method)
(GET unimplemented-method)
(HEAD unimplemented-method)
(POST unimplemented-method)
(PUT unimplemented-method)
(DELETE unimplemented-method)
(TRACE unimplemented-method)
(CONNECT unimplemented-method))
(make-server
port-number
timeout
threaded?
(make-token-table
("OPTIONS" OPTIONS)
("GET" GET)
("HEAD" HEAD)
("POST" POST)
("PUT" PUT)
("DELETE" DELETE)
("TRACE" TRACE)
("CONNECT" CONNECT)))))
(define http-server-start!
(lambda (hs)
(let ((server-port
(open-tcp-server
(list server-address: '#u8(127 0 0 1) ; on localhost interface only
port-number: (server-port-number hs)
backlog: 128
reuse-address: #t
char-encoding: 'ISO-8859-1))))
(accept-connections hs server-port))))
(define accept-connections
(lambda (hs server-port)
(let loop ()
(let ((connection
(read server-port)))
(if (server-threaded? hs)
(let ((dummy-port (open-dummy)))
(parameterize ((current-input-port dummy-port)
(current-output-port dummy-port))
(thread-start!
(make-thread
(lambda ()
(serve-connection hs connection))))))
(serve-connection hs connection)))
(loop))))
(define send-error
(lambda (connection html)
(write-html html connection)
(close-port connection)))
(define method-not-implemented-error
(lambda (connection)
(send-error
connection
(<html> (<head> (<title> "501 Method Not Implemented"))
(<body>
(<h1> "Method Not Implemented"))))))
(define unimplemented-method
(lambda ()
(let* ((request (current-request))
(connection (request-connection request)))
(method-not-implemented-error connection))))
(define bad-request-error
(lambda (connection)
(send-error
connection
(<html> (<head> (<title> "400 Bad Request"))
(<body>
(<h1> "Bad Request")
(<p> "Your browser sent a request that this server could "
"not understand."
(<br>)))))))
(define reply
(lambda (thunk)
(let* ((request
(current-request))
(connection
(request-connection request))
(version
(request-version request)))
(define generate-reply
(lambda (port)
(if (or (eq? version 'HTTP/1.0)
(eq? version 'HTTP/1.1))
(let ((message
(with-output-to-u8vector
'(char-encoding: ISO-8859-1
eol-encoding: cr-lf)
thunk))
(eol
"\r\n"))
(print
(list version " 200 OK" eol
"Content-Length: " (u8vector-length message) eol
"Content-Type: text/html; charset=ISO-8859-1" eol
"Connection: close" eol
eol)
port)
(write-subu8vector
message
0
(u8vector-length message)
port))
(with-output-to-port port thunk))))
(define debug? #f)
(if (not debug?)
(generate-reply connection)
(let ((output
(call-with-output-u8vector
'#u8()
(lambda (port) (generate-reply port)))))
(write-subu8vector output 0 (u8vector-length output) ##stdout-port)
(force-output ##stdout-port)
(write-subu8vector output 0 (u8vector-length output) connection)))
(close-port connection))))
(define reply-html
(lambda (html)
(reply (lambda () (write-html html)))))
(define current-request
(lambda ()
(thread-specific (current-thread)))) ; request is stored in thread
;------------------------------------------------------------------------------
(define serve-connection
(lambda (hs connection)
; Configure the connection with the client so that if we can't
; read the request after 300 seconds, the read operation will fail
; (and the thread will terminate).
(input-port-timeout-set! connection 300)
; Configure the connection with the client so that if we can't
; write the response after 300 seconds, the write operation will
; fail (and the thread will terminate).
(output-port-timeout-set! connection 300)
(let ((req (permissive-read-line connection)))
(if (not (string? req))
(bad-request-error connection)
(let* ((end
(let loop ((i 0))
(cond ((= i (string-length req))
#f)
((char=? (string-ref req i) #\space)
i)
(else
(loop (+ i 1))))))
(method-index
(and end
(token-table-lookup-substring
(server-method-table hs)
req
0
end))))
(if method-index
(parse-uri
req
(+ end 1)
(string-length req)
#t
(lambda (uri i)
(define handle-version
(lambda (version)
(case version
((HTTP/1.0 HTTP/1.1)
(let ((attributes (read-header connection)))
(if attributes
(handle-request version attributes)
(bad-request-error connection))))
((#f)
; this is an HTTP/0.9 request
(handle-request 'HTTP/0.9 '()))
(else
(bad-request-error connection)))))
(define handle-request
(lambda (version attributes)
(let* ((method-table
(server-method-table hs))
(method-name
(vector-ref method-table method-index))
(method-action
(vector-ref method-table (+ method-index 1)))
(content
(read-content connection attributes))
(query
(let ((x (assoc "Content-Type" attributes)))
(if (and x
(string=?
(cdr x)
"application/x-www-form-urlencoded"))
(decode-x-www-form-urlencoded content)
(uri-query uri)))))
(let ((request
(make-request
hs
connection
method-name
uri
version
attributes
query)))
(thread-specific-set! (current-thread) request))
(method-action))))
(cond ((not uri)
(bad-request-error connection))
((not (< i (string-length req)))
(handle-version #f))
((not (char=? (string-ref req i) #\space))
(bad-request-error connection))
(else
(let ((version-index
(token-table-lookup-substring
version-table
req
(+ i 1)
(string-length req))))
(if version-index
(handle-version
(vector-ref version-table
(+ version-index 1)))
(bad-request-error connection)))))))
(method-not-implemented-error connection)))))))
(define version-table
(make-token-table
("HTTP/1.0" 'HTTP/1.0)
("HTTP/1.1" 'HTTP/1.1)))
(define read-header
(lambda (connection)
(let loop ((attributes '()))
(let ((line (permissive-read-line connection)))
(cond ((not line)
#f)
((= (string-length line) 0)
attributes)
(else
(let ((attribute (split-attribute-line line)))
(if attribute
(loop (cons attribute attributes))
#f))))))))
(define read-content
(lambda (connection attributes)
(let ((cl
(cond ((assoc "Content-Length" attributes)
=>
(lambda (x)
(let ((n (string->number (cdr x))))
(and n (integer? n) (exact? n) n))))
(else
#f))))
(if cl
(let ((str (make-string cl)))
(let ((n (read-substring str 0 cl connection)))
(if (= n cl)
str
"")))
""))))
(define permissive-read-line
(lambda (port)
(let ((s (read-line port)))
(if (and (string? s)
(> (string-length s) 0)
(char=? (string-ref s (- (string-length s) 1)) #\return))
; efficient version of (substring s 0 (- (string-length s) 1))
(begin (##string-shrink! s (- (string-length s) 1)) s)
s))))
(define find-char-pos
(lambda (str char)
(let loop ((i 0))
(if (< i (string-length str))
(if (char=? char (string-ref str i))
i
(loop (+ i 1)))
#f))))
(define split-attribute-line
(lambda (line)
(let ((pos (find-char-pos line #\:)))
(and pos
(< (+ pos 1) (string-length line))
(char=? #\space (string-ref line (+ pos 1)))
(cons (substring line 0 pos)
(substring line (+ pos 2) (string-length line)))))))
;==============================================================================
Raw
Main.hs
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Snap.Http.Server
import Snap.Types
server :: Snap () -> IO ()
server handler = do
let config = addListen (ListenHttp "0.0.0.0" 9000)
. setCompression False
. setBackend ConfigSimpleBackend
. setVerbose False
. setErrorLog Nothing
. setAccessLog Nothing $ defaultConfig
httpServe config handler
putStrLn "Shutting down"
main :: IO ()
main = server $ (writeBS "<html><body>hello world</body></html>")
Raw
node-server.js
var http = require('http');
http.createServer(function (req, res) {
res.writeHead(200, {'Content-Type': 'text/plain'});
res.end('<html><body>Hello World</body></html>\n');
}).listen(8124, "127.0.0.1");
console.log('Server running at http://127.0.0.1:8124/');
Raw
racket-server.ss
#lang racket
(require web-server/servlet
web-server/servlet-env)
(define (my-app request)
`(html (body "Hello World")))
(serve/servlet my-app
#:port 8080
#:servlet-path "/"
#:stateless? #t
#:command-line? #t)
Raw
Server.hs
{-# LANGUAGE OverloadedStrings #-}
module Server
( ServerConfig(..)
, emptyServerConfig
, commandLineConfig
, server
, quickServer
) where
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Char8 (ByteString)
import Data.Char
import Control.Concurrent
import Control.Exception (SomeException)
import Control.Monad.CatchIO
import qualified Data.Text as T
import Prelude hiding (catch)
import Snap.Http.Server
import Snap.Types
import Snap.Util.GZip
import System hiding (getEnv)
import System.Posix.Env
import qualified Text.XHtmlCombinators.Escape as XH
data ServerConfig = ServerConfig
{ locale :: String
, interface :: ByteString
, port :: Int
, hostname :: ByteString
, accessLog :: Maybe FilePath
, errorLog :: Maybe FilePath
, compression :: Bool
, error500Handler :: SomeException -> Snap ()
}
emptyServerConfig :: ServerConfig
emptyServerConfig = ServerConfig
{ locale = "en_US"
, interface = "0.0.0.0"
, port = 9000
, hostname = "myserver"
, accessLog = Nothing
, errorLog = Nothing
, compression = True
, error500Handler = \e -> do
let t = T.pack $ show e
r = setContentType "text/html; charset=utf-8" $
setResponseStatus 500 "Internal Server Error" emptyResponse
putResponse r
writeBS "<html><head><title>Internal Server Error</title></head>"
writeBS "<body><h1>Internal Server Error</h1>"
writeBS "<p>A web handler threw an exception. Details:</p>"
writeBS "<pre>\n"
writeText $ XH.escape t
writeBS "\n</pre></body></html>"
}
commandLineConfig :: IO ServerConfig
commandLineConfig = do
args <- getArgs
let conf = case args of
[] -> emptyServerConfig
(port':_) -> emptyServerConfig { port = read port' }
locale' <- getEnv "LANG"
return $ case locale' of
Nothing -> conf
Just l -> conf {locale = takeWhile (\c -> isAlpha c || c == '_') l}
server :: ServerConfig -> Snap () -> IO ()
server config handler = do
putStrLn $ "Listening on " ++ (B.unpack $ interface config)
++ ":" ++ show (port config)
setUTF8Locale (locale config)
try $ httpServe
(interface config)
(port config)
(hostname config)
(accessLog config)
(errorLog config)
(catch500 $ compress $ handler)
:: IO (Either SomeException ())
threadDelay 1000000
putStrLn "Shutting down"
where
catch500 = (`catch` (error500Handler config))
compress = if compression config then withCompression else id
quickServer :: Snap () -> IO ()
quickServer = (commandLineConfig >>=) . flip server
setUTF8Locale :: String -> IO ()
setUTF8Locale locale' = do
mapM_ (\k -> setEnv k (locale' ++ ".UTF-8") True)
[ "LANG"
, "LC_CTYPE"
, "LC_NUMERIC"
, "LC_TIME"
, "LC_COLLATE"
, "LC_MONETARY"
, "LC_MESSAGES"
, "LC_PAPER"
, "LC_NAME"
, "LC_ADDRESS"
, "LC_TELEPHONE"
, "LC_MEASUREMENT"
, "LC_IDENTIFICATION"
, "LC_ALL" ]
Raw
setup
#!/bin/sh
(cd ./snap-hello-server && cabal clean && cabal install --bindir=./bin)
(cd ./gambit-server && gsc -exe base64 html http web-server)
Raw
snap-10000-1000.txt
This is ApacheBench, Version 2.3 <$Revision: 655654 $>
Copyright 1996 Adam Twiss, Zeus Technology Ltd, http://www.zeustech.net/
Licensed to The Apache Software Foundation, http://www.apache.org/
Benchmarking localhost (be patient)
Server Software: Snap/0.2.16.2
Server Hostname: localhost
Server Port: 9000
Document Path: /
Document Length: 37 bytes
Concurrency Level: 1000
Time taken for tests: 2.105 seconds
Complete requests: 10000
Failed requests: 0
Write errors: 0
Total transferred: 1350000 bytes
HTML transferred: 370000 bytes
Requests per second: 4749.86 [#/sec] (mean)
Time per request: 210.533 [ms] (mean)
Time per request: 0.211 [ms] (mean, across all concurrent requests)
Transfer rate: 626.20 [Kbytes/sec] received
Connection Times (ms)
min mean[+/-sd] median max
Connect: 0 2 4.6 0 28
Processing: 9 199 45.9 207 241
Waiting: 9 199 46.0 207 241
Total: 29 201 42.0 207 241
Percentage of the requests served within a certain time (ms)
50% 207
66% 230
75% 232
80% 233
90% 236
95% 237
98% 237
99% 238
100% 241 (longest request)
Raw
snap-10000-32.txt
This is ApacheBench, Version 2.3 <$Revision: 655654 $>
Copyright 1996 Adam Twiss, Zeus Technology Ltd, http://www.zeustech.net/
Licensed to The Apache Software Foundation, http://www.apache.org/
Benchmarking localhost (be patient)
Server Software: Snap/0.2.16.2
Server Hostname: localhost
Server Port: 9000
Document Path: /
Document Length: 37 bytes
Concurrency Level: 32
Time taken for tests: 1.974 seconds
Complete requests: 10000
Failed requests: 0
Write errors: 0
Total transferred: 1350000 bytes
HTML transferred: 370000 bytes
Requests per second: 5066.33 [#/sec] (mean)
Time per request: 6.316 [ms] (mean)
Time per request: 0.197 [ms] (mean, across all concurrent requests)
Transfer rate: 667.92 [Kbytes/sec] received
Connection Times (ms)
min mean[+/-sd] median max
Connect: 0 0 0.1 0 3
Processing: 0 6 1.3 6 13
Waiting: 0 6 1.3 6 13
Total: 1 6 1.3 6 13
Percentage of the requests served within a certain time (ms)
50% 6
66% 7
75% 7
80% 7
90% 8
95% 9
98% 9
99% 10
100% 13 (longest request)
Raw
snap-hello-server.cabal
Name: snap-hello-server
Version: 0.1
Synopsis: Project Synopsis Here
Description: Project Description Here
License: AllRightsReserved
Author: Author
Maintainer: maintainer@example.com
Stability: Experimental
Category: Web
Build-type: Simple
Cabal-version: >=1.2
Executable snap-hello-server
hs-source-dirs: src
main-is: Main.hs
Build-depends:
base >= 4,
haskell98,
bytestring >= 0.9.1 && <0.10,
snap-core >= 0.3,
snap-server >= 0.3
if impl(ghc >= 6.12.0)
ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
-fno-warn-unused-do-bind
else
ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
Raw
start
#!/usr/bin/env node
var Sys = require('sys'),
Child = require('child_process'),
kids = {};
function spawn(cmd, args, opt) {
var proc = Child.spawn(cmd, args, opt);
(kids[proc.pid] = proc)
.on('exit', terminate);
proc.stdout.on('data', function(chunk) { Sys.print(chunk); });
proc.stderr.on('data', function(chunk) { Sys.print(chunk); });
}
function terminate() {
if (this.pid in kids) {
delete kids[this.pid];
killall();
}
}
function killall() {
for (var pid in kids) {
var proc = kids[pid];
delete kids[pid];
proc.kill();
}
process.exit(0);
}
process.on('exit', killall);
console.log('Interpreted Gambit-C (gsi): 8000');
spawn('gsi', ['base64.scm', 'html.scm', 'http.scm', 'web-server.scm', '8000'], { cwd: './gambit-server' });
console.log('Snap: 9000');
spawn('./snap-hello-server/bin/snap-hello-server', ['9000', "+RTS", "-N2"]);
console.log('Compiled Gambit-C (gsc): 8001');
spawn('./gambit-server/web-server', ['8001']);
console.log('Racket: 8080');
spawn('racket', ['racket-server.ss']);
console.log('Node: 8124');
spawn('node', ['node-server.js']);
console.log('Tornado: 8888');
spawn('python', ['tornado_server.py']);
console.log('Eventlet: 8090');
spawn('python', ['eventlet_server.py']);
console.log('Thin: 3000');
spawn('thin', ['start', '-R', 'thin_server.ru']);
Raw
test
#!/bin/sh
set -x
ab -n $1 -c $2 http://localhost:$3/
Raw
thin_server.ru
app = proc do |env|
[
200,
{
'Content-Type' => 'text/html',
'Content-Length' => '37'
},
['<html><body>Hello World</body></html>']
]
end
run app
Raw
tornado_server.py
import tornado.httpserver
import tornado.ioloop
import tornado.web
class MainHandler(tornado.web.RequestHandler):
def get(self):
self.write("<html><body>Hello World</body></html>")
application = tornado.web.Application([
(r"/", MainHandler),
])
if __name__ == "__main__":
http_server = tornado.httpserver.HTTPServer(application)
http_server.listen(8888)
tornado.ioloop.IOLoop.instance().start()
Raw
web-server.scm
#!/usr/bin/env gsi-script
; File: "web-server.scm", Time-stamp: <2008-12-17 13:41:03 feeley>
; Copyright (c) 2004-2008 by Marc Feeley, All Rights Reserved.
; A minimal web server which implements a web-site with a few
; interesting examples.
;==============================================================================
(##include "~~lib/gambit#.scm") ;; import Gambit procedures and variables
(##include "http#.scm") ;; import HTTP procedures and variables
(##include "html#.scm") ;; import HTML procedures and variables
(##include "base64#.scm") ;; import BASE64 procedures and variables
;==============================================================================
(define main
(lambda (arg)
(let ((port-number
(string->number arg)))
(http-server-start!
(make-http-server
port-number: port-number
threaded?: #t
GET: page-main)))))
(define hello "<html><body>Hello World</body></html>")
(define page-main
(lambda ()
(reply
(lambda ()
(write-substring
hello
0
(string-length hello)
(current-output-port))))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment