TFPHTTPServer in ThreadMode=tmThreadPool hangs when KeepConnections=True

Summary

If the TFPHTTPServer is set with ThreadMode=tmThreadPool and KeepConnections=True then it hangs with 100% load and no OnIdle callbacks if there are open connections.

System Information

  • Operating system: Windows
  • Processor architecture: x86
  • Compiler version: trunk
  • Device: Computer

Steps to reproduce

Run the example project (it is basically the server+client demo projects from FPC sources in one unit).

Example Project

program TestHttpServerThreadPool;

{$mode objfpc}{$H+}

uses
  {$IFDEF UNIX}
  cthreads,
  {$ENDIF}
  Classes, SysUtils, fphttpserver, fphttpclient
  { you can add units after this };

type
  THTTPServerThread = class(TThread)
  private
    fServ: TFPHttpServer;

    procedure ServOnIdle(Sender: TObject);
    procedure ServRequest(Sender: TObject; var ARequest: TFPHTTPConnectionRequest;
      var AResponse: TFPHTTPConnectionResponse);
  public
    procedure Execute; override;
  end;

{ THTTPServerThread }

procedure THTTPServerThread.Execute;
begin
  fServ := TFPHttpServer.Create(Nil);
  fServ.KeepConnections := True;
  fServ.KeepConnectionTimeout := 60*1000;
  fServ.ThreadMode := tmThreadPool; // set to tmThread to fix the issue
  fServ.Port := 1234;
  fServ.AcceptIdleTimeout := 1000;
  fServ.OnAcceptIdle := @ServOnIdle;
  fServ.OnRequest := @ServRequest;
  fServ.Active := True;
  fServ.Free;
  fServ := nil;
end;

procedure THTTPServerThread.ServOnIdle(Sender: TObject);
begin
  Write('i');
  if Terminated then
    fServ.Active := False;
end;

procedure THTTPServerThread.ServRequest(Sender: TObject; var ARequest: TFPHTTPConnectionRequest;
  var AResponse: TFPHTTPConnectionResponse);
begin
  AResponse.Code := 200;
  AResponse.Content := '';
  AResponse.ContentLength := Length(AResponse.Content);
end;

var
  Server: THTTPServerThread;
  Client: TFPHTTPClient;
begin
  Server := THTTPServerThread.Create(False);
  while not (Assigned(Server.fServ) and Server.fServ.Active) do
    Sleep(10);

  Client := TFPHTTPClient.Create(nil);
  Client.KeepConnection := True;
  Client.Get('http://localhost:1234');

  Writeln('press enter to exit');
  ReadLn;

  Server.Free;
  Client.Free;
end.

What is the current bug behavior?

The server hangs with 100% processor load and no OnIdle callbacks.

What is the expected (correct) behavior?

0% processor load and OnIdle callbacks like it is for the tmThread ThreadMode.

Edited by Sven/Sarah Barth