Difference between revisions of "Light Web Server"

From Lazarus wiki
Jump to navigationJump to search
(New page: A light web server that supports HTTPS currently written with synapse/fpc. https://opensvn.csie.org/WebApplication/lightwebserver/)
 
(Add page template and remove categories (defined in the template))
 
(6 intermediate revisions by 4 users not shown)
Line 1: Line 1:
A light web server that supports HTTPS currently written with synapse/fpc.
+
{{Light_Web_Server}}
  
https://opensvn.csie.org/WebApplication/lightwebserver/
+
A light web server that supports HTTPS currently written with [[Synapse]] and Free Pascal:
 +
 
 +
<syntaxhighlight lang=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.</syntaxhighlight>

Latest revision as of 18: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.