8f7767305e61993bae665911a4bcb70d0168c758
[mmondor.git] / mmsoftware / cl / server / test-httpd.lisp
1 ;;; $Id: test-httpd.lisp,v 1.2 2011/08/13 09:15:19 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 = (+ (server-time) *request-timeout*)
39 for line = (line-read client-stream)
40 while (< chars *request-max-size*)
41 while (< (server-time) max-time)
42 until (string= "" line)
43 sum (length line) into chars of-type fixnum
44 collect line into lines
45 finally
46 (return
47 (values lines
48 (cond
49 ((> chars *request-max-size*) :request-size-exceeded)
50 ((>= (server-time) max-time) :request-timeout)
51 (t :success)))))
52
53 (write-string *response* client-stream)
54
55 (format client-stream "Status: ~A~%~%" status)
56 (format client-stream
57 "IP address: ~A~%IP Port : ~A~%~%Headers:~%~%"
58 (address-string address) port)
59 (loop
60 for line in lines
61 do (format client-stream "~A~%" line))
62
63 (finish-output client-stream)))
64
65 (defparameter *response-overflow*
66 (format nil
67 "HTTP/1.1 403.9 Too many connections~C
68 Server: ecl-server2.lisp 0.1~C
69 Connection: close~C
70 Content-Type: text/plain; charset=utf-8~C
71 ~C
72 Connection limit exceeded for your address. Try again later.
73 " #\Return #\Return #\Return #\Return #\Return))
74
75 ;;; Function called to serve exceeded connections.
76 (defun http-overflow (client-stream address port reason)
77 (declare (ignore address port reason))
78 (write-string *response-overflow* client-stream)
79 (finish-output client-stream))
80
81
82 (defvar *init*
83 (server-init (make-server-config :listen-address "0.0.0.0"
84 :listen-port 7777
85 :serve-function 'http-serve
86 :overflow-function 'http-overflow)))