Light Web Server/es
From Lazarus wiki
Jump to navigationJump to search
│
English (en) │
español (es) │
français (fr) │
Un servidor web ligero con soporte para HTTPS, escrito con Synapse y 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('Atendiendo conexiones. Código de error (0=Éxito): ', 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('Recibidas las cabeceras y el documento desde el navegador:');
s := ASocket.RecvString(timeout);
WriteLn(s);
//Leer las cabeceras de la petición
repeat
s := ASocket.RecvString(Timeout);
WriteLn(s);
TriggerMessage(s);
until s = '';
// Escibir el documento de salida mediante un flujo de datos
OutputDataString := '<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"' + ' "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">' +
CRLF + '<html><h1>Esto es una prueba</h1></html>' + CRLF;
// Enviar las cabeceras al cliente
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); //es una cabecera normalizada, ver https://developer.mozilla.org/es/docs/Web/HTTP/Headers
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.
