unit UWebServer;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, blcksock, synsock;
type
{ TTCPRequest }
TTCPRequest = class
private
FRequest: TStringList;
FSocket: TTCPBlockSocket;
FStream: TStream;
FContentType: string;
FSent: Boolean;
FMethod: string;
FProtocol: string;
FURI: string;
public
constructor Create;
destructor Destroy; override;
procedure Send;
property Method: string read FMethod;
property Protocol: string read FProtocol;
property URI: string read FURI;
property Stream: TStream read FStream write FStream;
property ContentType: string read FContentType write FContentType;
property Request: TStringList read FRequest;
end;
TOnRequestNotify = procedure(Sender: TObject; const ARequest: TTCPRequest) of object;
TOnErrorNotify = procedure(Sender: TObject; const AError: string) of object;
{ TTCPThread }
TTCPThread = class(TThread)
private
FSocket: TTCPBlockSocket;
FOnRequest: TOnRequestNotify;
protected
procedure Execute; override;
public
constructor Create(const ASock: TSocket; const AOnRequest: TOnRequestNotify);
destructor Destroy; override;
end;
{ TServerThread }
TServerThread = class(TThread)
private
FOnError: TOnErrorNotify;
FOnRequest: TOnRequestNotify;
FPort: integer;
protected
procedure Execute; override;
public
constructor Create(const APort: integer);
destructor Destroy; override;
property OnError: TOnErrorNotify read FOnError write FOnError;
property OnRequest: TOnRequestNotify read FOnRequest write FOnRequest;
end;
implementation
uses Synautil;
{ TTCPRequest }
constructor TTCPRequest.Create;
begin
FContentType := 'application/octet-stream';
FStream := nil;
FRequest := TStringList.Create;
end;
destructor TTCPRequest.Destroy;
begin
Send;
FRequest.Free;
inherited;
end;
procedure TTCPRequest.Send;
begin
if FSent then exit;
FSent := true;
if not assigned(FSocket) then
exit;
if assigned(FStream) then
begin
FSocket.SendString('HTTP/1.0 200' + CRLF);
FSocket.SendString('Content-type: '+ FContentType + CRLF);
FSocket.SendString('Content-length: ' + IntToStr(FStream.Size) + CRLF);
FSocket.SendString('Connection: close' + CRLF);
FSocket.SendString('Date: ' + Rfc822DateTime(now) + CRLF);
FSocket.SendString('Server: Synapse TCP' + CRLF);
FSocket.SendString('' + CRLF);
FSocket.SendStreamRaw(FStream);
end
else
FSocket.SendString('HTTP/1.0 404' + CRLF);
end;
{ TServerThread }
procedure TServerThread.Execute;
var
ListenerSocket: TTCPBlockSocket;
begin
ListenerSocket := TTCPBlockSocket.Create;
if (ListenerSocket.LastError <> 0) and assigned(FOnError) then
FOnError(self, ListenerSocket.GetErrorDescEx);
with ListenerSocket do
begin
CreateSocket;
if (LastError <> 0) and assigned(FOnError) then
FOnError(self, GetErrorDescEx);
Family := SF_IP4;
setLinger(True, 10000);
bind('0.0.0.0', IntToStr(FPort));
listen;
while not terminated do
begin
if (CanRead(100)) and (LastError = 0) then
TTCPThread.Create(Accept, FOnRequest);
sleep(10);
end;
end;
ListenerSocket.Free;
end;
constructor TServerThread.Create(const APort: integer);
begin
inherited Create(False);
FPort := APort;
end;
destructor TServerThread.Destroy;
begin
Terminate;
WaitFor;
inherited;
end;
{ TTCPThread }
procedure TTCPThread.Execute;
var
str: string;
timeout: integer;
Request: TTCPRequest;
begin
while (FSocket.WaitingData = 0) and (not Terminated) do
Sleep(10);
if Terminated then
exit;
timeout := 120000;
Request := TTCPRequest.Create;
try
str := FSocket.RecvString(timeout);
Request.FRequest.Add(str);
Request.FSocket := FSocket;
Request.FMethod := fetch(str, ' ');
Request.FUri := fetch(str, ' ');
Request.FProtocol := fetch(str, ' ');
repeat
str := FSocket.RecvString(Timeout);
Request.FRequest.Add(str);
until str = '';
if assigned(FOnRequest) then
FOnRequest(self, Request);
finally
Request.Free;
end;
end;
constructor TTCPThread.Create(const ASock: TSocket; const AOnRequest: TOnRequestNotify);
begin
FreeOnTerminate := True;
FSocket := TTCPBlockSocket.Create;
FSocket.Socket := aSock;
FSocket.GetSins;
FOnRequest := AOnRequest;
inherited Create(False);
end;
destructor TTCPThread.Destroy;
begin
Terminate;
FSocket.Free;
inherited;
end;
end.
Recent
