Horse.Provider.FPC.Daemon doesn't stop properly

[sf-spb]

Hi. THorse freezes when closing the application. Here is full solution.

unit Horse.Provider.FPC.Daemon;

{$IF DEFINED(FPC)}
{$MODE DELPHI}{$H+}
{$ENDIF}

interface

{$IF DEFINED(HORSE_DAEMON) AND DEFINED(FPC)}
uses
  SysUtils,
  Classes,
  httpdefs,
  fpHTTP,
  fphttpserver,
  Horse.Request,
  Horse.Response,
  Horse.Core,
  Horse.Provider.Abstract,
  Horse.Constants,
  Horse.Proc,
  Horse.Commons;

type

  { THTTPServerThread }

  THTTPServerThread = class(TThread)
  private
    FServer: TFPHTTPServer;
    FHorse: THorseCore;
    procedure OnIdle(Sender: TObject);
  public
    constructor Create(const AHost: string; const APort, AListenQueue: Integer);
    destructor Destroy; override;
    procedure Execute; override;
    procedure OnRequest(Sender: TObject; var ARequest: TFPHTTPConnectionRequest; var AResponse: TFPHTTPConnectionResponse);
  end;

  THorseProvider = class(THorseProviderAbstract)
  private
    class var FPort: Integer;
    class var FHost: string;
    class var FRunning: Boolean;
    class var FListenQueue: Integer;
    class var FHTTPServerThread: THTTPServerThread;
    class procedure SetListenQueue(const AValue: Integer); static;
    class procedure SetPort(const AValue: Integer); static;
    class procedure SetHost(const AValue: string); static;
    class function GetListenQueue: Integer; static;
    class function GetPort: Integer; static;
    class function GetDefaultPort: Integer; static;
    class function GetDefaultHost: string; static;
    class function GetHost: string; static;
    class procedure InternalListen; virtual;
    class procedure InternalStopListen; virtual;
  public
    class property Host: string read GetHost write SetHost;
    class property Port: Integer read GetPort write SetPort;
    class property ListenQueue: Integer read GetListenQueue write SetListenQueue;
    class procedure StopListen; override;
    class procedure Listen; overload; override;
    class procedure Listen(const APort: Integer; const AHost: string = '0.0.0.0'; const ACallbackListen: TProc = nil; const ACallbackStopListen: TProc = nil); reintroduce; overload; static;
    class procedure Listen(const APort: Integer; const ACallbackListen: TProc; const ACallbackStopListen: TProc = nil); reintroduce; overload; static;
    class procedure Listen(const AHost: string; const ACallbackListen: TProc = nil; const ACallbackStopListen: TProc = nil); reintroduce; overload; static;
    class procedure Listen(const ACallbackListen: TProc; const ACallbackStopListen: TProc = nil); reintroduce; overload; static;
    class destructor UnInitialize;
    class function IsRunning: Boolean;
  end;
{$ENDIF}

implementation

{$IF DEFINED(HORSE_DAEMON) AND DEFINED(FPC)}
uses
  Horse.WebModule,
  Horse.Exception.Interrupted;

{ THTTPServerThread }

procedure THTTPServerThread.OnRequest(Sender: TObject; var ARequest: TFPHTTPConnectionRequest; var AResponse: TFPHTTPConnectionResponse);
var
  LRequest: THorseRequest;
  LResponse: THorseResponse;
begin
  LRequest := THorseRequest.Create(ARequest);
  try
    LResponse := THorseResponse.Create(AResponse);
    try
      try
        if not FHorse.Routes.Execute(LRequest, LResponse) then
        begin
          AResponse.Content := 'Not Found';
          AResponse.Code := THTTPStatus.NotFound.ToInteger;
        end;
      except
        on E: Exception do
          if not E.InheritsFrom(EHorseCallbackInterrupted) then
            raise;
      end;
    finally
      if LRequest.Body<TObject> = LResponse.Content then
        LResponse.Content(nil);
      LRequest.Free;
    end;
  finally
    LResponse.Free;
  end;
end;

procedure THTTPServerThread.OnIdle(Sender: TObject);
begin
  if Terminated then
    FServer.Active := False;
end;

constructor THTTPServerThread.Create(const AHost: string; const APort, AListenQueue: Integer);
begin
  inherited Create(True);
  FreeOnTerminate := False;

  FServer := TFPHTTPServer.Create(nil);
  FServer.AcceptIdleTimeout := 1000;
  FServer.HostName := AHost;
  FServer.Port := APort;
  FServer.ThreadMode := tmThread;
  FServer.QueueSize := AListenQueue;
  FServer.OnAcceptIdle := OnIdle;
  FServer.OnRequest := OnRequest;

  FHorse := THorseCore.GetInstance;
end;

destructor THTTPServerThread.Destroy;
begin
  FServer.Free;
  inherited Destroy;
end;

procedure THTTPServerThread.Execute;
begin
  FServer.Active := True;
end;

{ THorseProvider }

class function THorseProvider.IsRunning: Boolean;
begin
  Result := FRunning;
end;

class procedure THorseProvider.StopListen;
begin
  InternalStopListen;
end;

class function THorseProvider.GetDefaultHost: string;
begin
  Result := DEFAULT_HOST;
end;

class function THorseProvider.GetDefaultPort: Integer;
begin
  Result := DEFAULT_PORT;
end;

class function THorseProvider.GetHost: string;
begin
  Result := FHost;
end;

class function THorseProvider.GetListenQueue: Integer;
begin
  Result := FListenQueue;
end;

class function THorseProvider.GetPort: Integer;
begin
  Result := FPort;
end;

class procedure THorseProvider.InternalListen;
begin
  if not IsRunning then
  begin
    if FPort <= 0 then
      FPort := GetDefaultPort;
    if FHost.IsEmpty then
      FHost := GetDefaultHost;
    if FListenQueue = 0 then
      FListenQueue := 15;

    FHTTPServerThread := THTTPServerThread.Create(FHost, FPort, FListenQueue);
    FHTTPServerThread.Start;

    FRunning := True;
    DoOnListen;
  end;
end;

class procedure THorseProvider.Listen;
begin
  InternalListen;
end;

class procedure THorseProvider.Listen(const APort: Integer; const AHost: string; const ACallbackListen, ACallbackStopListen: TProc);
begin
  SetPort(APort);
  SetHost(AHost);
  SetOnListen(ACallbackListen);
  SetOnStopListen(ACallbackStopListen);
  InternalListen;
end;

class procedure THorseProvider.Listen(const AHost: string; const ACallbackListen, ACallbackStopListen: TProc);
begin
  Listen(FPort, AHost, ACallbackListen, ACallbackStopListen);
end;

class procedure THorseProvider.Listen(const ACallbackListen, ACallbackStopListen: TProc);
begin
  Listen(FPort, FHost, ACallbackListen, ACallbackStopListen);
end;

class procedure THorseProvider.Listen(const APort: Integer; const ACallbackListen, ACallbackStopListen: TProc);
begin
  Listen(APort, FHost, ACallbackListen, ACallbackStopListen);
end;

class procedure THorseProvider.SetHost(const AValue: string);
begin
  FHost := AValue;
end;

class procedure THorseProvider.SetListenQueue(const AValue: Integer);
begin
  FListenQueue := AValue;
end;

class procedure THorseProvider.SetPort(const AValue: Integer);
begin
  FPort := AValue;
end;

class destructor THorseProvider.UnInitialize;
begin
  InternalStopListen;
end;

class procedure THorseProvider.InternalStopListen;
begin
  if IsRunning then
  begin
    FHTTPServerThread.Terminate;
    FHTTPServerThread.WaitFor;
    FHTTPServerThread.Free;
    DoOnStopListen;
    FRunning := False;
  end;
end;

{$ENDIF}

end.

[viniciussanchez]

Hello, would you like to submit a pull request with the tweak?

[sf-spb]

Yes, please.

[viniciussanchez]

@sf-spb , Will you send us a pull request?