Minor optimizations
[mmondor.git] / mmsoftware / cl / server / test-httpd.lisp
1 ;;; $Id: test-httpd.lisp,v 1.3 2011/08/13 09:53:34 mmondor Exp $
2 ;;;
3 ;;; Test/exemple minimal HTTP server
4
5 (declaim (optimize (speed 3) (safety 1) (debug 3)))
6
7 (eval-when (:compile-toplevel :load-toplevel)
8 (load "ecl-mp-server"))
9
10 (defpackage :httpd
11 (:use :cl :server))
12
13 (in-package :httpd)
14
15
16 (defparameter *request-timeout* 60)
17 (defparameter *request-max-size* 4096)
18
19
20 (defparameter *response*
21 (format nil
22 "HTTP/1.1 200 OK~C
23 Server: ecl-server2.lisp 0.1~C
24 Connection: close~C
25 Content-Type: text/plain; charset=utf-8~C
26 ~C
27 You sent the following information:
28
29 "
30 #\Return #\Return #\Return #\Return #\Return))
31
32 ;;; Although the goal isn't necessarily an HTTP server, this is useful
33 ;;; for testing the general performance with ab(8).
34 ;;; We only support 1.0/1.1 requests.
35 (defun http-serve (client-stream address port)
36 (multiple-value-bind (lines status)
37 (loop
38 with max-time of-type integer = (+ (server-time) *request-timeout*)
39 with request-max-size of-type fixnum = *request-max-size*
40 for line = (line-read client-stream)
41 while (< chars request-max-size)
42 while (< (server-time) max-time)
43 until (string= "" line)
44 sum (length line) into chars of-type fixnum
45 collect line into lines
46 finally
47 (return
48 (values lines
49 (cond
50 ((> chars request-max-size) :request-size-exceeded)
51 ((>= (server-time) max-time) :request-timeout)
52 (t :success)))))
53
54 (write-string *response* client-stream)
55
56 (format client-stream "Status: ~A~%~%" status)
57 (format client-stream
58 "IP address: ~A~%IP Port : ~A~%~%Headers:~%~%"
59 (address-string address) port)
60 (loop
61 for line in lines
62 do (format client-stream "~A~%" line))
63
64 (finish-output client-stream)))
65
66 (defparameter *response-overflow*
67 (format nil
68 "HTTP/1.1 403.9 Too many connections~C
69 Server: ecl-server2.lisp 0.1~C
70 Connection: close~C
71 Content-Type: text/plain; charset=utf-8~C
72 ~C
73 Connection limit exceeded for your address. Try again later.
74 " #\Return #\Return #\Return #\Return #\Return))
75
76 ;;; Function called to serve exceeded connections.
77 (defun http-overflow (client-stream address port reason)
78 (declare (ignore address port reason))
79 (write-string *response-overflow* client-stream)
80 (finish-output client-stream))
81
82
83 (defvar *init*
84 (server-init (make-server-config :listen-address "0.0.0.0"
85 :listen-port 7777
86 :serve-function 'http-serve
87 :overflow-function 'http-overflow)))