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

* Changes as suggested in bug ID #24810, so a threaded web application can be stopped correctly, even from a request

Browse Source 
git-svn-id: trunk@25571 -
This commit is contained in:
michael 2013-09-25 19:06:16 +00:00
parent 83cad92b11
commit 973c0687fc
3 changed files with 69 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
packages/fcl-web/src/base/custhttpapp.pp
View File

@ -33,8 +33,8 @@ Type
Private
FWebHandler: TFPHTTPServerHandler;
protected
Procedure InitRequest(ARequest : TFPHTTPConnectionRequest); virtual;
Procedure InitResponse(AResponse : TFPHTTPConnectionResponse); virtual;
Procedure InitRequest(ARequest : TFPHTTPConnectionRequest); override;
Procedure InitResponse(AResponse : TFPHTTPConnectionResponse); override;
Property WebHandler : TFPHTTPServerHandler Read FWebHandler;
Property Active;
end;
@ -44,9 +44,6 @@ Type
{ TFPHTTPServerHandler }
TFPHTTPServerHandler = class(TWebHandler)
procedure HTTPHandleRequest(Sender: TObject;
var ARequest: TFPHTTPConnectionRequest;
var AResponse: TFPHTTPConnectionResponse);
Private
FOnRequestError: TRequestErrorHandler;
FServer: TEmbeddedHTTPServer;
@ -61,6 +58,7 @@ Type
function GetLookupHostNames : Boolean;
Procedure SetLookupHostnames(Avalue : Boolean);
protected
procedure HTTPHandleRequest(Sender: TObject; var ARequest: TFPHTTPConnectionRequest; var AResponse: TFPHTTPConnectionResponse); virtual;
procedure HandleRequestError(Sender: TObject; E: Exception); virtual;
Procedure InitRequest(ARequest : TRequest); override;
Procedure InitResponse(AResponse : TResponse); override;
@ -69,6 +67,7 @@ Type
Property HTTPServer : TEmbeddedHttpServer Read FServer;
Public
Procedure Run; override;
Procedure Terminate; override;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
// Port to listen on.
@ -225,8 +224,6 @@ begin
ARequest:=Nil;
AResponse:=Nil;
end;
If Terminated And Assigned(FServer) then
FServer.Active:=False;
if Assigned(OnIdle) then
OnIdle(Self);
end;
@ -311,6 +308,13 @@ begin
Fserver.Active:=True;
end;
procedure TFPHTTPServerHandler.Terminate;
begin
Inherited;
if Assigned(FServer) then
Fserver.Active:=False;
end;
constructor TFPHTTPServerHandler.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
@ -322,8 +326,11 @@ end;
destructor TFPHTTPServerHandler.Destroy;
begin
FServer.Active:=False;
FreeAndNil(FServer);
if Assigned(FServer) then
begin
FServer.Active:=False;
FreeAndNil(FServer);
end;
inherited Destroy;
end;

2
packages/fcl-web/src/base/custweb.pp
View File

@ -106,7 +106,7 @@ Type
FOnLog : TLogEvent;
FPreferModuleName : Boolean;
protected
procedure Terminate;
procedure Terminate; virtual;
Function GetModuleName(Arequest : TRequest) : string;
function WaitForRequest(out ARequest : TRequest; out AResponse : TResponse) : boolean; virtual; abstract;
procedure EndRequest(ARequest : TRequest;AResponse : TResponse); virtual;

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

@ -119,6 +119,7 @@ Type
FServerBanner: string;
FLookupHostNames,
FThreaded: Boolean;
FConnectionCount : Integer;
function GetActive: Boolean;
procedure SetActive(const AValue: Boolean);
procedure SetOnAllowConnect(const AValue: TConnectQuery);
@ -126,13 +127,15 @@ Type
procedure SetQueueSize(const AValue: Word);
procedure SetThreaded(const AValue: Boolean);
procedure SetupSocket;
procedure StartServerSocket;
procedure WaitForRequests;
Protected
// Override these to create descendents of the request/response instead.
Function CreateRequest : TFPHTTPConnectionRequest; virtual;
Function CreateResponse(ARequest : TFPHTTPConnectionRequest) : TFPHTTPConnectionResponse; virtual;
Procedure InitRequest(ARequest : TFPHTTPConnectionRequest); virtual;
Procedure InitResponse(AResponse : TFPHTTPConnectionResponse); virtual;
// Called on accept errors
procedure DoAcceptError(Sender: TObject; ASocket: Longint; E: Exception; var ErrorAction: TAcceptErrorAction);
// Create a connection handling object.
function CreateConnection(Data : TSocketStream) : TFPHTTPConnection; virtual;
// Create a connection handling thread.
@ -143,13 +146,19 @@ Type
Procedure DoConnect(Sender : TObject; Data : TSocketStream); virtual;
// Create and configure TInetServer
Procedure CreateServerSocket; virtual;
// Stop and free TInetServer
// Start server socket
procedure StartServerSocket; virtual;
// Stop server stocket
procedure StopServerSocket; virtual;
// free server socket instance
Procedure FreeServerSocket; virtual;
// Handle request. This calls OnRequest. It can be overridden by descendants to provide standard handling.
procedure HandleRequest(Var ARequest: TFPHTTPConnectionRequest;
Var AResponse : TFPHTTPConnectionResponse); virtual;
// Called when a connection encounters an unexpected error. Will call OnRequestError when set.
procedure HandleRequestError(Sender: TObject; E: Exception); virtual;
// Connection count
Property ConnectionCount : Integer Read FConnectionCount;
public
Constructor Create(AOwner : TComponent); override;
Destructor Destroy; override;
@ -542,10 +551,14 @@ constructor TFPHTTPConnection.Create(AServer: TFPCustomHttpServer; ASocket: TSoc
begin
FSocket:=ASocket;
FServer:=AServer;
If Assigned(FServer) then
InterLockedIncrement(FServer.FConnectionCount)
end;
destructor TFPHTTPConnection.Destroy;
begin
If Assigned(FServer) then
InterLockedDecrement(FServer.FConnectionCount);
FreeAndNil(FSocket);
Inherited;
end;
@ -634,6 +647,15 @@ begin
end
end;
procedure TFPCustomHttpServer.DoAcceptError(Sender: TObject; ASocket: Longint;
E: Exception; var ErrorAction: TAcceptErrorAction);
begin
If Not Active then
ErrorAction:=AEAStop
else
ErrorAction:=AEARaise
end;
function TFPCustomHttpServer.GetActive: Boolean;
begin
if (csDesigning in ComponentState) then
@ -642,6 +664,11 @@ begin
Result:=Assigned(FServer);
end;
procedure TFPCustomHttpServer.StopServerSocket;
begin
FServer.StopAccepting(True);
end;
procedure TFPCustomHttpServer.SetActive(const AValue: Boolean);
begin
If AValue=GetActive then exit;
@ -652,9 +679,10 @@ begin
CreateServerSocket;
SetupSocket;
StartServerSocket;
FreeServerSocket;
end
else
FreeServerSocket;
StopServerSocket;
end;
procedure TFPCustomHttpServer.SetOnAllowConnect(const AValue: TConnectQuery);
@ -758,6 +786,7 @@ begin
FServer.MaxConnections:=-1;
FServer.OnConnectQuery:=OnAllowConnect;
FServer.OnConnect:=@DOConnect;
FServer.OnAcceptError:=@DoAcceptError;
end;
procedure TFPCustomHttpServer.StartServerSocket;
@ -769,7 +798,6 @@ end;
procedure TFPCustomHttpServer.FreeServerSocket;
begin
FServer.StopAccepting;
FreeAndNil(FServer);
end;
@ -788,9 +816,29 @@ begin
FServerBanner := 'Freepascal';
end;
Procedure TFPCustomHttpServer.WaitForRequests;
Var
FLastCount,ACount : Integer;
begin
ACount:=0;
FLastCount:=FConnectionCount;
While (FConnectionCount>0) and (ACount<10) do
begin
Sleep(100);
if (FConnectionCount=FLastCount) then
Dec(ACount)
else
FLastCount:=FConnectionCount;
end;
end;
destructor TFPCustomHttpServer.Destroy;
begin
Active:=False;
if Threaded and (FConnectionCount>0) then
WaitForRequests;
inherited Destroy;
end;