Light Web Server
From Free Pascal wiki
Jump to navigationJump to searchThe printable version is no longer supported and may have rendering errors. Please update your browser bookmarks and please use the default browser print function instead.
│
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.