Difference between revisions of "Light Web Server"
From Lazarus wiki
Jump to navigationJump to search (Add page template and remove categories (defined in the template)) |
|||
| (One intermediate revision by one other user not shown) | |||
| Line 1: | Line 1: | ||
| − | + | {{Light_Web_Server}} | |
| − | < | + | A light web server that supports HTTPS currently written with [[Synapse]] and Free Pascal: |
| + | |||
| + | <syntaxhighlight lang=pascal> | ||
| + | unit http_listen; | ||
{$mode objfpc}{$H+} | {$mode objfpc}{$H+} | ||
| Line 126: | Line 129: | ||
end; | end; | ||
| − | end.</ | + | end.</syntaxhighlight> |
Latest revision as of 19:07, 1 May 2020
│
English (en) │
español (es) │
français (fr) │
A light web server that supports HTTPS currently written with Synapse and Free Pascal:
unit http_listen;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, blcksock, sockets,
Synautil; //needs synapse
type
TPassMessage = procedure(AMsg: string) of object;
TLightWeb = class(TThread)
private
_Port: word;
_PassMessage: TPassMessage;
procedure AttendConnection(ASocket: TTCPBlockSocket);
procedure TriggerMessage(AMsg: string);
protected
procedure Execute; override;
public
constructor Create(APort: word);
destructor Destroy; override;
property OnPassMessage: TPassMessage read _PassMessage write _PassMessage;
end;
implementation
constructor TLightWeb.Create(APort: word);
begin
inherited Create(False);
_Port := Aport;
end;
procedure TLightWeb.Execute;
var
ListenerSocket, ConnectionSocket: TTCPBlockSocket;
begin
try
ListenerSocket := TTCPBlockSocket.Create;
ConnectionSocket := TTCPBlockSocket.Create;
ListenerSocket.CreateSocket;
ListenerSocket.setLinger(True, 10);
ListenerSocket.bind('0.0.0.0', IntToStr(_Port));
ListenerSocket.listen;
repeat
if ListenerSocket.canread(1000) then
begin
ConnectionSocket.Socket := ListenerSocket.accept;
WriteLn('Attending Connection. Error code (0=Success): ', ConnectionSocket.lasterror);
AttendConnection(ConnectionSocket);
ConnectionSocket.CloseSocket;
end;
until Terminated;
finally
FreeAndNil(ListenerSocket);
FreeAndNil(ConnectionSocket);
end;
end;
procedure TLightWeb.AttendConnection(ASocket: TTCPBlockSocket);
var
timeout: integer;
s: string;
OutputDataString: string;
begin
timeout := 120000;
try
try
WriteLn('Received headers+document from browser:');
s := ASocket.RecvString(timeout);
WriteLn(s);
//read request headers
repeat
s := ASocket.RecvString(Timeout);
WriteLn(s);
TriggerMessage(s);
until s = '';
// Write the output document to the stream
OutputDataString := '<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"' + ' "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">' +
CRLF + '<html><h1>Teste</h1></html>' + CRLF;
// Write the headers back to the client
ASocket.SendString('HTTP/1.0 200' + CRLF);
ASocket.SendString('Content-type: Text/Html' + CRLF);
ASocket.SendString('Content-length: ' + IntToStr(Length(OutputDataString)) + CRLF);
ASocket.SendString('Connection: close' + CRLF);
ASocket.SendString('Date: ' + Rfc822DateTime(now) + CRLF);
ASocket.SendString('Server: Lazarus Synapse' + CRLF);
ASocket.SendString('' + CRLF);
//if ASocket.lasterror <> 0 then HandleError;
ASocket.SendString(OutputDataString);
except
on E: Exception do
begin
end;
end;
finally
end;
end;
procedure TLightWeb.TriggerMessage(AMsg: string);
begin
if Assigned(_PassMessage) then
_PassMessage(AMsg);
end;
destructor TLightWeb.Destroy();
begin
inherited Destroy;
end;
end.
