fphttpserver: gracefully close open connections at server destroy

git-svn-id: https://svn.freepascal.org/svn/fpc/trunk@45723 3ad0048d-3df7-0310-abae-a5850022a9f2

1 files changed, 36 insertions, 4 deletions

diff --git a/packages/fcl-web/src/base/fphttpserver.pp b/packages/fcl-web/src/base/fphttpserver.pp
index d18b5a92a9..d664a5c559 100644
--- a/packages/fcl-web/src/base/fphttpserver.pp
+++ b/packages/fcl-web/src/base/fphttpserver.pp
@@ -88,8 +88,10 @@ Type
   TFPHTTPConnectionThread = Class(TThread)
   private
     FConnection: TFPHTTPConnection;
+    FThreadList: TThreadList;
   Public
     Constructor CreateConnection(AConnection : TFPHTTPConnection); virtual;
+    Constructor CreateConnection(AConnection : TFPHTTPConnection; AThreadList: TThreadList);
     Procedure Execute; override;
     Property Connection : TFPHTTPConnection Read FConnection;
   end;
@@ -121,6 +123,7 @@ Type
     FServerBanner: string;
     FLookupHostNames,
     FThreaded: Boolean;
+    FConnectionThreadList: TThreadList;
     FConnectionCount : Integer;
     FUseSSL: Boolean;
     procedure DoCreateClientHandler(Sender: TObject; out AHandler: TSocketHandler);
@@ -137,7 +140,7 @@ Type
     procedure SetQueueSize(const AValue: Word);
     procedure SetThreaded(const AValue: Boolean);
     procedure SetupSocket;
-    procedure WaitForRequests;
+    procedure WaitForRequests(MaxAttempts: Integer = 10);
   Protected
     // Override this to create descendent
     function CreateSSLSocketHandler: TSocketHandler;
@@ -648,6 +651,14 @@ begin
   Inherited Create(False);
 end;
 
+constructor TFPHTTPConnectionThread.CreateConnection(AConnection: TFPHTTPConnection; AThreadList: TThreadList);
+begin
+  FThreadList := AThreadList;
+  if Assigned(FThreadList) then
+    FThreadList.Add(Self);
+  CreateConnection(AConnection);
+end;
+
 procedure TFPHTTPConnectionThread.Execute;
 begin
   try
@@ -655,6 +666,8 @@ begin
       FConnection.HandleRequest;
     finally
       FreeAndNil(FConnection);
+      if Assigned(FThreadList) then
+        FThreadList.Remove(Self);
     end;
   except
     // Silently ignore errors.
@@ -780,6 +793,8 @@ begin
   if FThreaded=AValue then exit;
   CheckInactive;
   FThreaded:=AValue;
+  if FThreaded and not Assigned(FConnectionThreadList) then
+    FConnectionThreadList:=TThreadList.Create;
 end;
 
 function TFPCustomHttpServer.CreateRequest: TFPHTTPConnectionRequest;
@@ -811,7 +826,7 @@ end;
 function TFPCustomHttpServer.CreateConnectionThread(Conn: TFPHTTPConnection
   ): TFPHTTPConnectionThread;
 begin
-   Result:=TFPHTTPConnectionThread.CreateConnection(Conn);
+   Result:=TFPHTTPConnectionThread.CreateConnection(Conn, FConnectionThreadList);
 end;
 
 procedure TFPCustomHttpServer.CheckInactive;
@@ -893,7 +908,7 @@ begin
   FCertificateData:=CreateCertificateData;
 end;
 
-procedure TFPCustomHttpServer.WaitForRequests;
+procedure TFPCustomHttpServer.WaitForRequests(MaxAttempts: Integer);
 
 Var
   FLastCount,ACount : Integer;
@@ -901,7 +916,7 @@ Var
 begin
   ACount:=0;
   FLastCount:=FConnectionCount;
-  While (FConnectionCount>0) and (ACount<10) do
+  While (FConnectionCount>0) and (ACount<MaxAttempts) do
     begin
     Sleep(100);
     if (FConnectionCount=FLastCount) then
@@ -957,10 +972,27 @@ begin
 end;
 
 destructor TFPCustomHttpServer.Destroy;
+var
+  ThreadList: TList;
+  I: Integer;
 begin
   Active:=False;
   if Threaded and (FConnectionCount>0) then
+  begin
+    // first wait for open requests to finish and get closed automatically
     WaitForRequests;
+    // force close open sockets
+    ThreadList:=FConnectionThreadList.LockList;
+    try
+      for I:= ThreadList.Count-1 downto 0 do
+        CloseSocket(TFPHTTPConnectionThread(ThreadList[I]).Connection.Socket.Handle);
+    finally
+      FConnectionThreadList.UnlockList;
+    end;
+    // all requests must be destroyed - wait infinitely
+    WaitForRequests(High(Integer));
+  end;
+  FreeAndNil(FConnectionThreadList);
   FreeAndNil(FCertificateData);
   inherited Destroy;
 end;