unit HttpRequestThread;

interface

uses
  System.Generics.Collections,
  System.SyncObjs,
  System.Classes;

type
  TResponseNotify = procedure( const Request, Response : string ) of object;

  THttpRequestThread = class( TThread )
  private
    FCS : TCriticalSection;
    FEvent : TEvent;
    FQueue : TQueue<string>;
    FOnResponse : TResponseNotify;
    procedure SetOnResponse( const Value : TResponseNotify );
    function GetOnResponse : TResponseNotify;
    function GetQueueItem : string;
    procedure ProcessQueueItem;
    procedure DoResponseNotify( const ARequest, AResponse : string );
  protected
    procedure Execute; override;
    procedure TerminatedSet; override;
  public
    constructor Create;
    destructor Destroy; override;

    procedure Add( const ARequest : string );

    property OnResponse : TResponseNotify read GetOnResponse write SetOnResponse;
  end;

implementation

uses
  System.SysUtils,
  IdException,
  IdHTTP;

{ THttpRequestThread }

procedure THttpRequestThread.Add( const ARequest : string );
begin
  FCS.Enter;
  try
    FQueue.Enqueue( ARequest );
    FEvent.SetEvent;
  finally
    FCS.Leave;
  end;
end;

constructor THttpRequestThread.Create;
begin
  FCS := TCriticalSection.Create;
  FEvent := TEvent.Create( nil, False, False, '' );
  FQueue := TQueue<string>.Create;
  inherited Create( False );

end;

destructor THttpRequestThread.Destroy;
begin

  inherited;
  FreeAndNil( FQueue );
  FreeAndNil( FEvent );
  FreeAndNil( FCS );
end;

procedure THttpRequestThread.DoResponseNotify( const ARequest, AResponse : string );
begin
  if MainThreadID = CurrentThread.ThreadID
  then
    begin
      if Assigned( OnResponse )
      then
        OnResponse( ARequest, AResponse );
    end
  else
    Queue(
        procedure
      begin
        DoResponseNotify( ARequest, AResponse );
      end );
end;

procedure THttpRequestThread.Execute;
begin
  inherited;
  while not Terminated do
    begin
      FEvent.WaitFor;
      if not Terminated
      then
        ProcessQueueItem;
    end;
end;

function THttpRequestThread.GetOnResponse : TResponseNotify;
begin
  FCS.Enter;
  try
    Result := FOnResponse;
  finally
    FCS.Leave;
  end;
end;

function THttpRequestThread.GetQueueItem : string;
begin
  FCS.Enter;
  try
    Result := FQueue.Dequeue;
    if FQueue.Count > 0
    then
      FEvent.SetEvent;
  finally
    FCS.Leave;
  end;
end;

procedure THttpRequestThread.ProcessQueueItem;
var
  LRequest : string;
  LResponse : string;
  LHttp : TIdHTTP;
begin
  LHttp := TIdHTTP.Create( nil );
  LHttp.HandleRedirects := True;
  try
    LRequest := GetQueueItem;
    try
      LResponse := LHttp.Get( LRequest );
    except
      on E : EIdException do
        begin
          LResponse := E.ClassName + ': ' + E.Message;
        end;
    end;
    DoResponseNotify( LRequest, LResponse );
  finally
    LHttp.Free;
  end;
end;

procedure THttpRequestThread.SetOnResponse( const Value : TResponseNotify );
begin
  FCS.Enter;
  try
    FOnResponse := Value;
  finally
    FCS.Leave;
  end;
end;

procedure THttpRequestThread.TerminatedSet;
begin
  inherited;
  FEvent.SetEvent;
end;

end.

unit FormMain;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls,
  HttpRequestThread;

type
  TForm1 = class( TForm )
    Button1 : TButton;
    ListBox1 : TListBox;
    procedure Button1Click( Sender : TObject );
  private
    FHttpRequest : THttpRequestThread;
    procedure HttpRequestResponse( const Request, Response : string );
    procedure LogMsg( const AMsgStr : string );
  public
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
  end;

var
  Form1 : TForm1;

implementation

{$R *.dfm}

procedure TForm1.AfterConstruction;
begin
  inherited;
  FHttpRequest := THttpRequestThread.Create;
  FHttpRequest.OnResponse := HttpRequestResponse;
end;

procedure TForm1.BeforeDestruction;
begin
  inherited;
  FreeAndNil( FHttpRequest );
end;

procedure TForm1.Button1Click( Sender : TObject );
var
  LUrl : string;
  LIdx : Integer;
begin
  LUrl := 'http://google.de';
  for LIdx := 1 to 10 do
    begin
      LogMsg( 'Request ' + LUrl );
      FHttpRequest.Add( LUrl );
    end;
end;

procedure TForm1.HttpRequestResponse( const Request, Response : string );
begin
  LogMsg( Request + ' => ' + Response );
end;

procedure TForm1.LogMsg( const AMsgStr : string );
begin
  ListBox1.Items.Add( DateTimeToStr( Now ) + ': ' + AMsgStr );
end;

end.