Sign in Join
Wiki copytemporary

Light Web Server/fr: what changed

Revision 0 to 1. Removed lines have a minus sign; added lines have a plus sign.

Title: Light Web Server/fr

OldNewLine
1+A serveur Web léger qui supporte HTTPS actuellement écrit avec [[Synapse]] et Free Pascal :
2+
3+``` pascal
4+unit http_listen;
5+
6+{$mode objfpc}{$H+}
7+
8+interface
9+
10+uses
11+ Classes, SysUtils, blcksock, sockets,
12+ Synautil; //needs synapse
13+
14+type
15+ TPassMessage = procedure(AMsg: string) of object;
16+
17+ TLightWeb = class(TThread)
18+ private
19+ _Port: word;
20+ _PassMessage: TPassMessage;
21+ procedure AttendConnection(ASocket: TTCPBlockSocket);
22+ procedure TriggerMessage(AMsg: string);
23+ protected
24+ procedure Execute; override;
25+ public
26+ constructor Create(APort: word);
27+ destructor Destroy; override;
28+ property OnPassMessage: TPassMessage read _PassMessage write _PassMessage;
29+ end;
30+
31+implementation
32+
33+constructor TLightWeb.Create(APort: word);
34+begin
35+ inherited Create(False);
36+
37+ _Port := Aport;
38+end;
39+
40+procedure TLightWeb.Execute;
41+var
42+ ListenerSocket, ConnectionSocket: TTCPBlockSocket;
43+
44+begin
45+ try
46+ ListenerSocket := TTCPBlockSocket.Create;
47+ ConnectionSocket := TTCPBlockSocket.Create;
48+
49+ ListenerSocket.CreateSocket;
50+ ListenerSocket.setLinger(True, 10);
51+ ListenerSocket.bind('0.0.0.0', IntToStr(_Port));
52+ ListenerSocket.listen;
53+
54+ repeat
55+ if ListenerSocket.canread(1000) then
56+ begin
57+ ConnectionSocket.Socket := ListenerSocket.accept;
58+ WriteLn('Attending Connection. Error code (0=Success): ', ConnectionSocket.lasterror);
59+ AttendConnection(ConnectionSocket);
60+ ConnectionSocket.CloseSocket;
61+ end;
62+ until Terminated;
63+
64+ finally
65+ FreeAndNil(ListenerSocket);
66+ FreeAndNil(ConnectionSocket);
67+ end;
68+end;
69+
70+procedure TLightWeb.AttendConnection(ASocket: TTCPBlockSocket);
71+var
72+ timeout: integer;
73+ s: string;
74+ OutputDataString: string;
75+
76+begin
77+ timeout := 120000;
78+
79+ try
80+ try
81+ WriteLn('Received headers+document from browser:');
82+ s := ASocket.RecvString(timeout);
83+ WriteLn(s);
84+
85+ //read request headers
86+ repeat
87+ s := ASocket.RecvString(Timeout);
88+ WriteLn(s);
89+ TriggerMessage(s);
90+ until s = '';
91+
92+ // Write the output document to the stream
93+ OutputDataString := '<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"' + ' "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">' +
94+ CRLF + '<html><h1>Teste</h1></html>' + CRLF;
95+
96+ // Write the headers back to the client
97+ ASocket.SendString('HTTP/1.0 200' + CRLF);
98+ ASocket.SendString('Content-type: Text/Html' + CRLF);
99+ ASocket.SendString('Content-length: ' + IntToStr(Length(OutputDataString)) + CRLF);
100+ ASocket.SendString('Connection: close' + CRLF);
101+ ASocket.SendString('Date: ' + Rfc822DateTime(now) + CRLF);
102+ ASocket.SendString('Server: Lazarus Synapse' + CRLF);
103+ ASocket.SendString('' + CRLF);
104+
105+ //if ASocket.lasterror <> 0 then HandleError;
106+ ASocket.SendString(OutputDataString);
107+ except
108+ on E: Exception do
109+ begin
110+
111+ end;
112+ end;
113+ finally
114+ end;
115+end;
116+
117+procedure TLightWeb.TriggerMessage(AMsg: string);
118+begin
119+ if Assigned(_PassMessage) then
120+ _PassMessage(AMsg);
121+end;
122+
123+destructor TLightWeb.Destroy();
124+begin
125+ inherited Destroy;
126+end;
127+
128+end.
129+```
130+
131+---
132+*From the Free Pascal wiki, page "Light Web Server/fr", as it stood on 2020-05-01 after a change by E-ric, out of the wiki's dump of 2024-05-26. Copyright stays with the author who wrote it, according to the old wiki's [[Licensing]] page. If you have concerns about this material, [message the admin](/wiki-contact).*

Back to history