6d605be8f894744f362a5d732288b57e4173c511
[mmondor.git] / mmsoftware / cl / server / test-httpd.lisp
1 ;;; $Id: test-httpd.lisp,v 1.4 2011/08/13 20:29:08 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 (defun split-string-words (string &key (start 0) (end nil) (max nil))
21 "Returns an array containing the words from STRING."
22 (declare (type fixnum start)
23 (type (or null fixnum) end max))
24 (let ((array (make-array (or max 16)
25 :fill-pointer 0
26 :adjustable t))
27 (array-len 0)
28 (s start))
29 (declare (type fixnum array-len)
30 (type (or null fixnum) s))
31 (unless end
32 (setf end (length string)))
33 (when max
34 (decf max))
35 (loop
36 for i of-type fixnum from s below end
37 until (and max (< max array-len))
38 while (setf s (position-if-not #'(lambda (c)
39 (char= #\Space c))
40 string
41 :start i))
42 do
43 (setf i (or (position #\Space string :start s)
44 end))
45 (let ((w (subseq string s i)))
46 (unless (vector-push w array)
47 (adjust-array array (* 2 (array-dimension array 0))
48 :element-type 'string)
49 (vector-push w array))
50 (incf array-len)))
51 array))
52
53
54 (defparameter *response*
55 (format nil
56 "HTTP/1.1 200 OK~C
57 Server: ecl-server2.lisp 0.1~C
58 Connection: close~C
59 Content-Type: text/plain; charset=utf-8~C
60 ~C
61 You sent the following information:
62
63 "
64 #\Return #\Return #\Return #\Return #\Return))
65
66 ;;; Although the goal isn't necessarily an HTTP server, this is useful
67 ;;; for testing the general performance with ab(8).
68 ;;; We only support 1.0/1.1 requests.
69 (defun http-serve (client-stream address port)
70 (multiple-value-bind (status lines)
71 (loop
72 with max-time of-type integer = (+ (server-time) *request-timeout*)
73 with request-max-size of-type fixnum = *request-max-size*
74 for line = (line-read client-stream)
75 for words = (split-string-words line :max 3)
76 while (< chars request-max-size) ; Request size exceeded
77 while (< (server-time) max-time) ; Request timeout
78 until (string= "" line) ; End of HTTP/1.x request
79 until (and (= nlines 0) ; End of HTTP/0.x request
80 (= (length words) 2)
81 (string= "GET" (aref words 0)))
82 sum (length line) into chars of-type fixnum
83 count line into nlines of-type fixnum
84 collect line into lines
85 finally
86 (return
87 (values (cond
88 ((and (= nlines 0)
89 (= (length words) 2)
90 (string= "GET" (aref words 0)))
91 (push line lines)
92 :deprecated-protocol)
93 ((> chars request-max-size) :request-size-exceeded)
94 ((>= (server-time) max-time) :request-timeout)
95 (t :success))
96 lines)))
97
98 (write-string *response* client-stream)
99
100 (format client-stream "Status: ~A~%~%" status)
101 (format client-stream
102 "IP address: ~A~%IP Port : ~A~%~%Request:~%~%"
103 (address-string address) port)
104 (loop
105 for line in lines
106 do (format client-stream "~A~%" line))
107
108 (finish-output client-stream)))
109
110 (defparameter *response-overflow*
111 (format nil
112 "HTTP/1.1 403.9 Too many connections~C
113 Server: ecl-server2.lisp 0.1~C
114 Connection: close~C
115 Content-Type: text/plain; charset=utf-8~C
116 ~C
117 Connection limit exceeded for your address. Try again later.
118 " #\Return #\Return #\Return #\Return #\Return))
119
120 ;;; Function called to serve exceeded connections.
121 (defun http-overflow (client-stream address port reason)
122 (declare (ignore address port reason))
123 (write-string *response-overflow* client-stream)
124 (finish-output client-stream))
125
126
127 (defvar *init*
128 (server-init (make-server-config :listen-address "0.0.0.0"
129 :listen-port 7777
130 :serve-function 'http-serve
131 :overflow-function 'http-overflow)))