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

git-svn-id: trunk@25571 -

packages/fcl-web/src/base/custhttpapp.pp

@@ -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;

packages/fcl-web/src/base/custweb.pp

@@ -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;

packages/fcl-web/src/base/fphttpserver.pp

@@ -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;