- Detect empty request
[mmondor.git] / mmsoftware / cl / server / test-httpd.lisp
1 ;;; $Id: test-httpd.lisp,v 1.5 2011/08/13 21:00:39 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) 0)) :no-request)
90 ((and (= nlines 0)
91 (= (length words) 2)
92 (string= "GET" (aref words 0)))
93 (push line lines)
94 :deprecated-protocol)
95 ((> chars request-max-size) :request-size-exceeded)
96 ((>= (server-time) max-time) :request-timeout)
97 (t :success))
98 lines)))
99
100 (write-string *response* client-stream)
101
102 (let ((client-info (format nil "[~A:~A] #~A"
103 (address-string address) port
104 (stream-fd client-stream))))
105 (log-line "= Status : ~A: ~A" client-info status)
106 (log-line "= Request : ~A: ~A" client-info (first lines)))
107
108 (format client-stream "Status: ~A~%~%" status)
109 (format client-stream
110 "IP address: ~A~%IP Port : ~A~%~%"
111 (address-string address) port)
112
113 (unless (eq :no-request status)
114 (format client-stream "Request:~%~%")
115 (loop
116 for line in lines
117 do (format client-stream "~A~%" line)))
118
119 (finish-output client-stream)))
120
121 (defparameter *response-overflow*
122 (format nil
123 "HTTP/1.1 403.9 Too many connections~C
124 Server: ecl-server2.lisp 0.1~C
125 Connection: close~C
126 Content-Type: text/plain; charset=utf-8~C
127 ~C
128 Connection limit exceeded for your address. Try again later.
129 " #\Return #\Return #\Return #\Return #\Return))
130
131 ;;; Function called to serve exceeded connections.
132 (defun http-overflow (client-stream address port reason)
133 (declare (ignore address port reason))
134 (write-string *response-overflow* client-stream)
135 (finish-output client-stream))
136
137
138 (defvar *init*
139 (server-init (make-server-config :listen-address "0.0.0.0"
140 :listen-port 7777
141 :serve-function 'http-serve
142 :overflow-function 'http-overflow)))