1 | unit UHTTPServer;
|
---|
2 |
|
---|
3 | {$mode Delphi}{$H+}
|
---|
4 |
|
---|
5 | interface
|
---|
6 |
|
---|
7 | uses
|
---|
8 | Classes, SysUtils, UTCPServer, UCommon, UMemoryStreamEx, UMIMEType,
|
---|
9 | Synautil, UStringListEx;
|
---|
10 |
|
---|
11 | type
|
---|
12 | THTTPServer = class;
|
---|
13 |
|
---|
14 | TQueryParameterList = class(TStringList)
|
---|
15 | procedure Parse(Text: string);
|
---|
16 | function Syntetize: string;
|
---|
17 | end;
|
---|
18 |
|
---|
19 | { TCookieList }
|
---|
20 |
|
---|
21 | TCookieList = class(TStringList)
|
---|
22 | procedure Parse(Text: string);
|
---|
23 | function Syntetize: string;
|
---|
24 | end;
|
---|
25 |
|
---|
26 | { THTTPRequest }
|
---|
27 |
|
---|
28 | THTTPRequest = class
|
---|
29 | Query: TQueryParameterList;
|
---|
30 | Path: string;
|
---|
31 | Method: string;
|
---|
32 | Headers: TStringList;
|
---|
33 | Cookies: TCookieList;
|
---|
34 | constructor Create;
|
---|
35 | destructor Destroy; override;
|
---|
36 | end;
|
---|
37 |
|
---|
38 | { THTTPResponse }
|
---|
39 |
|
---|
40 | THTTPResponse = class
|
---|
41 | ContentType: string;
|
---|
42 | Stream: TMemoryStreamEx;
|
---|
43 | Headers: TStringList;
|
---|
44 | Cookies: TCookieList;
|
---|
45 | constructor Create;
|
---|
46 | destructor Destroy; override;
|
---|
47 | end;
|
---|
48 |
|
---|
49 | { THTTPHandlerData }
|
---|
50 |
|
---|
51 | THTTPHandlerData = class
|
---|
52 | Server: THTTPServer;
|
---|
53 | Request: THTTPRequest;
|
---|
54 | Response: THTTPResponse;
|
---|
55 | SessionId: string;
|
---|
56 | Session: TStringList;
|
---|
57 | constructor Create;
|
---|
58 | destructor Destroy; override;
|
---|
59 | end;
|
---|
60 |
|
---|
61 | TRequestEvent = procedure(HandlerData: THTTPHandlerData) of object;
|
---|
62 |
|
---|
63 | TRequestHandler = class
|
---|
64 | Name: string;
|
---|
65 | Handler: TRequestEvent;
|
---|
66 | end;
|
---|
67 |
|
---|
68 | { TRequestHandlerList }
|
---|
69 |
|
---|
70 | TRequestHandlerList = class(TList)
|
---|
71 | procedure Add(AName: string; AHandler: TRequestEvent);
|
---|
72 | function IndexOfName(AName: string): TRequestHandler;
|
---|
73 | end;
|
---|
74 |
|
---|
75 | { THTTPSession }
|
---|
76 |
|
---|
77 | { THTTPSessionStorage }
|
---|
78 |
|
---|
79 | THTTPSessionStorage = class
|
---|
80 | procedure Load(HandlerData: THTTPHandlerData); virtual;
|
---|
81 | procedure Save(HandlerData: THTTPHandlerData); virtual;
|
---|
82 | constructor Create; virtual;
|
---|
83 | destructor Destroy; override;
|
---|
84 | end;
|
---|
85 |
|
---|
86 | { THTTPServer }
|
---|
87 |
|
---|
88 | THTTPServer = class
|
---|
89 | private
|
---|
90 | procedure HandleClient(Sender: TObject);
|
---|
91 | procedure ErrorResponse(HandlerData: THTTPHandlerData);
|
---|
92 | public
|
---|
93 | Name: string;
|
---|
94 | Socket: TTCPServer;
|
---|
95 | DocumentRoot: string;
|
---|
96 | MaxConnection: Integer;
|
---|
97 | RequestHandlerList: TRequestHandlerList;
|
---|
98 | SessionStorage: THTTPSessionStorage;
|
---|
99 | procedure FileResponse(HandlerData: THTTPHandlerData);
|
---|
100 | constructor Create;
|
---|
101 | destructor Destroy; override;
|
---|
102 | end;
|
---|
103 |
|
---|
104 | implementation
|
---|
105 |
|
---|
106 | { THTTPServer }
|
---|
107 |
|
---|
108 | procedure THTTPServer.HandleClient(Sender: TObject);
|
---|
109 | var
|
---|
110 | RequestHandler: TRequestHandler;
|
---|
111 | Line: string;
|
---|
112 | LineIndex: Integer;
|
---|
113 | LineParts: TStringListEx;
|
---|
114 | HandlerData: THTTPHandlerData;
|
---|
115 | I: Integer;
|
---|
116 | begin
|
---|
117 | with TTCPClientThread(Sender), Socket do begin
|
---|
118 | WriteLn('Used thrads ' + IntToStr(Parent.ThreadPool.UsedCount) + '. Client connected from ' + GetRemoteSinIP);
|
---|
119 |
|
---|
120 | HandlerData := THTTPHandlerData.Create;
|
---|
121 | with HandlerData do begin
|
---|
122 | Server := Self;
|
---|
123 |
|
---|
124 | Response := THTTPResponse.Create;
|
---|
125 | Response.Headers.Values['Server'] := Name;
|
---|
126 | Request := THTTPRequest.Create;
|
---|
127 | LineIndex := 0;
|
---|
128 | LineParts := TStringListEx.Create;
|
---|
129 | repeat
|
---|
130 | Line := RecvString(10000);
|
---|
131 | if (LineIndex = 0) then begin
|
---|
132 | LineParts.Explode(' ', Line);
|
---|
133 | if (LineParts.Count >= 3) then begin
|
---|
134 | Request.Method := LineParts[0];
|
---|
135 | if Pos('?', LineParts[1]) > 0 then begin
|
---|
136 | Request.Path := Copy(LineParts[1], 1, Pos('?', LineParts[1]) - 1);
|
---|
137 | Request.Query.Parse(Copy(LineParts[1], Pos('?', LineParts[1]) + 1, Length(LineParts[1])));
|
---|
138 | end else Request.Path := LineParts[1];
|
---|
139 | end;
|
---|
140 | end else begin
|
---|
141 | LineParts.Explode(' ', Line, 2);
|
---|
142 | if (LineParts.Count = 2) and (LineParts[0][Length(LineParts[0])] = ':') then begin
|
---|
143 | LineParts[0] := Copy(LineParts[0], 1, Length(LineParts[0]) - 1);
|
---|
144 | Request.Headers.Values[LineParts[0]] := LineParts[1];
|
---|
145 | //WriteLn(Line);
|
---|
146 | end;
|
---|
147 | end;
|
---|
148 | Inc(LineIndex);
|
---|
149 | until Line = '';
|
---|
150 | LineParts.Destroy;
|
---|
151 |
|
---|
152 | // Process cookies
|
---|
153 | if Request.Headers.IndexOfName('Cookie') <> -1 then
|
---|
154 | Request.Cookies.Parse(Request.Headers.Values['Cookie']);
|
---|
155 |
|
---|
156 | // Load session variables
|
---|
157 | if Assigned(SessionStorage) then
|
---|
158 | SessionStorage.Load(HandlerData);
|
---|
159 |
|
---|
160 | Response.Stream.Clear;
|
---|
161 | Response.Headers.Values['Content-Type'] := 'text/html';
|
---|
162 |
|
---|
163 | WriteLn('Requested path: ' + Request.Path);
|
---|
164 | RequestHandler := RequestHandlerList.IndexOfName(Request.Path);
|
---|
165 |
|
---|
166 | if Assigned(RequestHandler) then RequestHandler.Handler(HandlerData)
|
---|
167 | else ErrorResponse(HandlerData);
|
---|
168 |
|
---|
169 | // Store session variables
|
---|
170 | if Assigned(SessionStorage) then
|
---|
171 | SessionStorage.Save(HandlerData);
|
---|
172 |
|
---|
173 | with Response do begin
|
---|
174 | SendString('HTTP/1.0 200 OK'#13#10);
|
---|
175 | Headers.Values['Content-Length'] := IntToStr(Stream.Size);
|
---|
176 | Headers.Values['Connection'] := 'close';
|
---|
177 | Headers.Values['Date'] := RFC822DateTime(Now);
|
---|
178 |
|
---|
179 | // Handle cookies
|
---|
180 | for I := 0 to Cookies.Count - 1 do
|
---|
181 | Headers.Add('Set-Cookie' + Headers.NameValueSeparator + Cookies.Names[I] + '=' + Cookies.ValueFromIndex[I]);
|
---|
182 | // + ';path=/;expires=' + RFC822DateTime(Now);
|
---|
183 |
|
---|
184 | // Send headers
|
---|
185 | for I := 0 to Headers.Count - 1 do begin
|
---|
186 | //WriteLn(Headers.Names[I] + ': ' + Headers.ValueFromIndex[I] + #13#10);
|
---|
187 | SendString(Headers.Names[I] + ': ' + Headers.ValueFromIndex[I] + #13#10);
|
---|
188 | end;
|
---|
189 | SendString(#13#10);
|
---|
190 | SendBuffer(Stream.Memory, Stream.Size);
|
---|
191 | SendString(#13#10);
|
---|
192 | end;
|
---|
193 |
|
---|
194 | Destroy;
|
---|
195 | end;
|
---|
196 | end;
|
---|
197 | end;
|
---|
198 |
|
---|
199 | procedure THTTPServer.ErrorResponse(HandlerData: THTTPHandlerData);
|
---|
200 | begin
|
---|
201 | with HandlerData, Response.Stream do begin
|
---|
202 | WriteString('<html><body>Page ' + Request.Path + ' not found.</body></html>');
|
---|
203 | end;
|
---|
204 | end;
|
---|
205 |
|
---|
206 | procedure THTTPServer.FileResponse(HandlerData: THTTPHandlerData);
|
---|
207 | var
|
---|
208 | BinaryFile: TFileStream;
|
---|
209 | FileName: string;
|
---|
210 | begin
|
---|
211 | with HandlerData do begin
|
---|
212 | FileName := DocumentRoot + Request.Path;
|
---|
213 | if FileExists(FileName) then begin
|
---|
214 | Response.Headers.Values['Content-Type'] := GetMIMEType(Copy(ExtractFileExt(FileName), 2, 255));
|
---|
215 | BinaryFile := TFileStream.Create(FileName, fmOpenRead);
|
---|
216 | Response.Stream.WriteStream(BinaryFile);
|
---|
217 | BinaryFile.Destroy;
|
---|
218 | end else
|
---|
219 | with Response.Stream do begin
|
---|
220 | WriteLn('File ' + Request.Path + ' not found.');
|
---|
221 | WriteString('<html><body>File ' + Request.Path + ' not found.</body></html>');
|
---|
222 | end;
|
---|
223 | end;
|
---|
224 | end;
|
---|
225 |
|
---|
226 | constructor THTTPServer.Create;
|
---|
227 | begin
|
---|
228 | Socket := TTCPServer.Create;
|
---|
229 | Socket.OnClientConnect := HandleClient;
|
---|
230 | DocumentRoot := './';
|
---|
231 | RequestHandlerList := TRequestHandlerList.Create;
|
---|
232 | Name := 'THTTPServer';
|
---|
233 | MaxConnection := 10000;
|
---|
234 | end;
|
---|
235 |
|
---|
236 | destructor THTTPServer.Destroy;
|
---|
237 | begin
|
---|
238 | Socket.Destroy;
|
---|
239 | RequestHandlerList.Destroy;
|
---|
240 | inherited Destroy;
|
---|
241 | end;
|
---|
242 |
|
---|
243 | { THTTPResponse }
|
---|
244 |
|
---|
245 | constructor THTTPResponse.Create;
|
---|
246 | begin
|
---|
247 | Stream := TMemoryStreamEx.Create;
|
---|
248 | Cookies := TCookieList.Create;
|
---|
249 | Headers := TStringList.Create;
|
---|
250 | end;
|
---|
251 |
|
---|
252 | destructor THTTPResponse.Destroy;
|
---|
253 | begin
|
---|
254 | Stream.Destroy;
|
---|
255 | Headers.Destroy;
|
---|
256 | inherited Destroy;
|
---|
257 | end;
|
---|
258 |
|
---|
259 | { TRequestHandlerList }
|
---|
260 |
|
---|
261 | procedure TRequestHandlerList.Add(AName: string; AHandler: TRequestEvent);
|
---|
262 | begin
|
---|
263 | with TRequestHandler(Items[inherited Add(TRequestHandler.Create)]) do begin
|
---|
264 | Name := AName;
|
---|
265 | Handler := AHandler;
|
---|
266 | end;
|
---|
267 | end;
|
---|
268 |
|
---|
269 | function TRequestHandlerList.IndexOfName(AName: string): TRequestHandler;
|
---|
270 | var
|
---|
271 | I: Integer;
|
---|
272 | begin
|
---|
273 | I := 0;
|
---|
274 | while (I < Count) and (TRequestHandler(Items[I]).Name <> AName) do Inc(I);
|
---|
275 | if I < Count then Result := TRequestHandler(Items[I]) else Result := nil;
|
---|
276 | end;
|
---|
277 |
|
---|
278 | { THTTPRequest }
|
---|
279 |
|
---|
280 | constructor THTTPRequest.Create;
|
---|
281 | begin
|
---|
282 | Query := TQueryParameterList.Create;
|
---|
283 | Headers := TStringList.Create;
|
---|
284 | Cookies := TCookieList.Create;
|
---|
285 | end;
|
---|
286 |
|
---|
287 | destructor THTTPRequest.Destroy;
|
---|
288 | begin
|
---|
289 | Query.Destroy;
|
---|
290 | Headers.Destroy;
|
---|
291 | inherited Destroy;
|
---|
292 | end;
|
---|
293 |
|
---|
294 | { TQueryParameterList }
|
---|
295 |
|
---|
296 | procedure TQueryParameterList.Parse(Text: string);
|
---|
297 | var
|
---|
298 | I: Integer;
|
---|
299 | Parts: TStringListEx;
|
---|
300 | Pair: TStringListEx;
|
---|
301 | begin
|
---|
302 | Parts := TStringListEx.Create;
|
---|
303 | Pair := TStringListEx.Create;
|
---|
304 | Clear;
|
---|
305 | Parts.Explode('&', Text);
|
---|
306 | for I := 0 to Parts.Count - 1 do begin
|
---|
307 | Pair.Explode('=', Parts[I]);
|
---|
308 | if Pair.Count >= 2 then
|
---|
309 | Values[Pair[0]] := Pair[1];
|
---|
310 | end;
|
---|
311 | Parts.Destroy;
|
---|
312 | Pair.Destroy;
|
---|
313 | end;
|
---|
314 |
|
---|
315 | function TQueryParameterList.Syntetize: string;
|
---|
316 | var
|
---|
317 | I: Integer;
|
---|
318 | begin
|
---|
319 | Result := '';
|
---|
320 | for I := 0 to Count - 1 do
|
---|
321 | Result := Result + '&' + Names[I] + '=' + ValueFromIndex[I];
|
---|
322 | Result := Copy(Result, 6, Length(Result));
|
---|
323 | end;
|
---|
324 |
|
---|
325 | { TCookieList }
|
---|
326 |
|
---|
327 | procedure TCookieList.Parse(Text: string);
|
---|
328 | var
|
---|
329 | I: Integer;
|
---|
330 | Parts: TStringListEx;
|
---|
331 | Pair: TStringListEx;
|
---|
332 | begin
|
---|
333 | Parts := TStringListEx.Create;
|
---|
334 | Pair := TStringListEx.Create;
|
---|
335 | Clear;
|
---|
336 | Parts.Explode(';', Text);
|
---|
337 | for I := 0 to Parts.Count - 1 do begin
|
---|
338 | Pair.Explode('=', Parts[I]);
|
---|
339 | if Pair.Count >= 2 then
|
---|
340 | Values[Trim(Pair[0])] := Trim(Pair[1]);
|
---|
341 | end;
|
---|
342 | Pair.Destroy;
|
---|
343 | Parts.Destroy;
|
---|
344 | end;
|
---|
345 |
|
---|
346 | function TCookieList.Syntetize: string;
|
---|
347 | var
|
---|
348 | I: Integer;
|
---|
349 | begin
|
---|
350 | Result := '';
|
---|
351 | for I := 0 to Count - 1 do
|
---|
352 | Result := Result + '; ' + Names[I] + '=' + ValueFromIndex[I];
|
---|
353 | Result := Copy(Result, 2, Length(Result));
|
---|
354 | end;
|
---|
355 |
|
---|
356 | { THTTPSessionStorage }
|
---|
357 |
|
---|
358 | procedure THTTPSessionStorage.Load(HandlerData: THTTPHandlerData);
|
---|
359 | begin
|
---|
360 |
|
---|
361 | end;
|
---|
362 |
|
---|
363 | procedure THTTPSessionStorage.Save(HandlerData: THTTPHandlerData);
|
---|
364 | begin
|
---|
365 |
|
---|
366 | end;
|
---|
367 |
|
---|
368 | constructor THTTPSessionStorage.Create;
|
---|
369 | begin
|
---|
370 |
|
---|
371 | end;
|
---|
372 |
|
---|
373 | destructor THTTPSessionStorage.Destroy;
|
---|
374 | begin
|
---|
375 | inherited Destroy;
|
---|
376 | end;
|
---|
377 |
|
---|
378 | { THTTPHandlerData }
|
---|
379 |
|
---|
380 | constructor THTTPHandlerData.Create;
|
---|
381 | begin
|
---|
382 | Request := THTTPRequest.Create;
|
---|
383 | Response := THTTPResponse.Create;
|
---|
384 | Session := TStringList.Create;
|
---|
385 | end;
|
---|
386 |
|
---|
387 | destructor THTTPHandlerData.Destroy;
|
---|
388 | begin
|
---|
389 | Request.Destroy;
|
---|
390 | Response.Destroy;
|
---|
391 | Session.Destroy;
|
---|
392 | inherited Destroy;
|
---|
393 | end;
|
---|
394 |
|
---|
395 | end.
|
---|
396 |
|
---|