Light Web Server/fr

From Free Pascal wiki
Jump to navigationJump to search
The 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 serveur Web léger qui supporte HTTPS actuellement écrit avec Synapse et 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.