paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-12 04:26:13 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Implement Idle timeout for accepting connections

Browse Source 
git-svn-id: trunk@33729 -
This commit is contained in:
michael 2016-05-21 09:43:31 +00:00
parent a03999cb79
commit e39a964239
1 changed files with 28 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
packages/fcl-web/src/base/fphttpserver.pp
View File

@ -101,8 +101,10 @@ Type
TFPCustomHttpServer = Class(TComponent) TFPCustomHttpServer = Class(TComponent)
Private Private
FAcceptIdleTimeout: Cardinal;
FAdminMail: string; FAdminMail: string;
FAdminName: string; FAdminName: string;
FOnAcceptIdle: TNotifyEvent;
FOnAllowConnect: TConnectQuery; FOnAllowConnect: TConnectQuery;
FOnRequest: THTTPServerRequestHandler; FOnRequest: THTTPServerRequestHandler;
FOnRequestError: TRequestErrorHandler; FOnRequestError: TRequestErrorHandler;
@ -116,7 +118,9 @@ Type
FThreaded: Boolean; FThreaded: Boolean;
FConnectionCount : Integer; FConnectionCount : Integer;
function GetActive: Boolean; function GetActive: Boolean;
procedure SetAcceptIdleTimeout(AValue: Cardinal);
procedure SetActive(const AValue: Boolean); procedure SetActive(const AValue: Boolean);
procedure SetIdle(AValue: TNotifyEvent);
procedure SetOnAllowConnect(const AValue: TConnectQuery); procedure SetOnAllowConnect(const AValue: TConnectQuery);
procedure SetAddress(const AValue: string); procedure SetAddress(const AValue: string);
procedure SetPort(const AValue: Word); procedure SetPort(const AValue: Word);
@ -175,6 +179,10 @@ Type
Property OnRequest : THTTPServerRequestHandler Read FOnRequest Write FOnRequest; Property OnRequest : THTTPServerRequestHandler Read FOnRequest Write FOnRequest;
// Called when an unexpected error occurs during handling of the request. Sender is the TFPHTTPConnection. // Called when an unexpected error occurs during handling of the request. Sender is the TFPHTTPConnection.
Property OnRequestError : TRequestErrorHandler Read FOnRequestError Write FOnRequestError; Property OnRequestError : TRequestErrorHandler Read FOnRequestError Write FOnRequestError;
// Called when there are no connections waiting.
Property OnAcceptIdle : TNotifyEvent Read FOnAcceptIdle Write SetIdle;
// If >0, when no new connection appeared after timeout, OnAcceptIdle is called.
Property AcceptIdleTimeout : Cardinal Read FAcceptIdleTimeout Write SetAcceptIdleTimeout;
published published
//aditional server information //aditional server information
property AdminMail: string read FAdminMail write FAdminMail; property AdminMail: string read FAdminMail write FAdminMail;
@ -192,6 +200,8 @@ Type
property Threaded; property Threaded;
Property OnRequest; Property OnRequest;
Property OnRequestError; Property OnRequestError;
Property OnAcceptIdle;
Property AcceptIdleTimeout;
end; end;
EHTTPServer = Class(EHTTP); EHTTPServer = Class(EHTTP);
@ -638,6 +648,14 @@ begin
Result:=Assigned(FServer); Result:=Assigned(FServer);
end; end;
procedure TFPCustomHttpServer.SetAcceptIdleTimeout(AValue: Cardinal);
begin
if FAcceptIdleTimeout=AValue then Exit;
FAcceptIdleTimeout:=AValue;
If Assigned(FServer) then
FServer.AcceptIdleTimeOut:=AValue;
end;
procedure TFPCustomHttpServer.StopServerSocket; procedure TFPCustomHttpServer.StopServerSocket;
begin begin
FServer.StopAccepting(True); FServer.StopAccepting(True);
@ -659,6 +677,13 @@ begin
StopServerSocket; StopServerSocket;
end; end;
procedure TFPCustomHttpServer.SetIdle(AValue: TNotifyEvent);
begin
FOnAcceptIdle:=AValue;
if Assigned(FServer) then
FServer.OnIdle:=AValue;
end;
procedure TFPCustomHttpServer.SetOnAllowConnect(const AValue: TConnectQuery); procedure TFPCustomHttpServer.SetOnAllowConnect(const AValue: TConnectQuery);
begin begin
if FOnAllowConnect=AValue then exit; if FOnAllowConnect=AValue then exit;
@ -771,6 +796,8 @@ begin
FServer.OnConnectQuery:=OnAllowConnect; FServer.OnConnectQuery:=OnAllowConnect;
FServer.OnConnect:=@DOConnect; FServer.OnConnect:=@DOConnect;
FServer.OnAcceptError:=@DoAcceptError; FServer.OnAcceptError:=@DoAcceptError;
FServer.OnIdle:=OnAcceptIdle;
FServer.AcceptIdleTimeOut:=AcceptIdleTimeout;
end; end;
procedure TFPCustomHttpServer.StartServerSocket; procedure TFPCustomHttpServer.StartServerSocket;
@ -800,7 +827,7 @@ begin
FServerBanner := 'Freepascal'; FServerBanner := 'Freepascal';
end; end;
Procedure TFPCustomHttpServer.WaitForRequests; procedure TFPCustomHttpServer.WaitForRequests;
Var Var
FLastCount,ACount : Integer; FLastCount,ACount : Integer;