Search code examples
multithreadingdelphiindy

tIdHttp Inside thread and IdTCPServer in GUI

I have a TTimer on a TForm, where the timer is set to 5 seconds and creates 100 threads to fetch XML from a remote server.

Each time a thread is executed, I add the XML to a variable (FullXML_STR:String).

When all threads have finished, I am sending the FullXML_STR to all Clients connected to a TIdTCPServer.

unit Unit1;

interface

uses
  IdGlobal,IdContext, system.win.Comobj, system.syncObjs, MSXML2_TLB, activex,
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, IdBaseComponent, IdComponent,
  IdTCPConnection, IdTCPClient, IdHTTP, IdCustomTCPServer, IdCustomHTTPServer,
  IdHTTPServer, Vcl.ExtCtrls;

Type
  TxClientThread = class(TThread)
  private
    fHttpClient: TIdHTTP;
    furl: String;
    ftag:Integer;
    fResponseXML:String;
    fXML: IXMLDOMDocument;
    fNode: IXMLDomNode;
  protected
    procedure Execute; override;
    procedure DoTerminate; override; **//Added**

  public
    constructor Create(atag:Integer;AURL:string);reintroduce;
    destructor Destroy; override;
  end;

type
  TForm1 = class(TForm)
    IdTCPServer1: TIdHTTPServer;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure StartTimerAgain;
  end;

const
  maximumThreads=200;

var
  Form1: TForm1;
  Threads_downloaded:Integer;
  Total_threads:Integer;
  FullXML_STR:String;
  Clients:TList;
  CriticalSection:TCriticalSection;
  ClientThread:Array[0..maximumThreads] of TxClientThread;

implementation

{$R *.dfm}

{TxClientThread}

constructor TxClientThread.Create(atag:Integer;AURL:string);
begin
  inherited Create(false);
  furl:=Aurl;
  ftag:=Atag;
  fResponseXML:='';
  fHttpClient := TIdHTTP.Create(nil);
  fHttpClient.Tag:=ftag;
  fHttpClient.ConnectTimeout:=60000;
  fHttpClient.ReadTimeout:=60000;
  fHttpClient.Request.Accept:='*/*';
  fHttpClient.Request.UserAgent:='Mozilla/5.0 (Windows NT 6.1; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/73.0.3683.86 Safari/537.36';

  FreeOnTerminate := True;
end;

destructor TxClientThread.Destroy;
begin
  fHttpClient.Free;
  inherited Destroy;
end;

procedure TxClientThread.Execute;
begin
  try
    fResponseXML:= fHttpClient.Get(furl);
  except
  end;
end;

procedure TxClientThread.DoTerminate;
begin
  inc(Threads_downloaded);

  ///******     parsing The XML
  try
    CoInitialize(nil);
    fXML := CreateOleObject('Microsoft.XMLDOM') as IXMLDOMDocument;
    fXML.async := false;
    try
      fXML.loadXML(fResponseXML); 
      fNode := fXML.selectSingleNode('/games');
      if fNode<>nil then
      begin
        FullXML_STR:=FullXML_STR + fNode.attributes.getNamedItem('id').text+'^';
      end;
    finally
      fxml:=nil; //---> do i need this?
    end;
  finally
    CoUninitialize;
  end;

  if Threads_downloaded=Total_threads then
  begin
    TThread.Synchronize(nil,procedure/////////Sould i USe This or Synchronize
      var
        i:Integer;
      begin
        CriticalSection.enter;
        if not Assigned(Form1.IdTCPServer1.Contexts) then exit;
        try
          Clients:=Form1.IdTCPServer1.Contexts.LockList;
          try
            for i:=pred(Clients.Count)  downto 0 do
              try
                TIdContext(Clients[i]).Connection.IOHandler.Writeln(FullXML_STR,IndyTextEncoding_UTF8);
              except
              end;
            finally
              Form1.IdTCPServer1.Contexts.UnlockList;
            end;
        finally
          CriticalSection.leave;
        end;
        form1.StartTimerAgain; ///Startinmg againe Then timer
      end
    );
  end;
  /////////// End \ All threads downloaded

  inherited;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  CriticalSection:=TCriticalSection.create;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  CriticalSection.Free;
end;

procedure tform1.StartTimerAgain;
begin
  Form1.Timer1.Enabled:=true
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  x:Integer;
  aUrl:String;
begin
  FullXML_STR:='';
  Timer1.Enabled:=false;
  Threads_downloaded:=0;
  Total_threads=100;
  for x:=0 to Pred(Total_threads) do
  begin
    aUrl:='http://example.com/myxml'+Formatfloat('0',x)+'.xml';
    ClientThread[Threads_downloaded]:=TxClientThread.Create(x,aUrl);
  end;
end;

end.

main problem is that after 1-2 Hours programm is not responding.

  1. in each thread's Execute(), I check if all Threads have finished downloading. Is there a better way to know that all my threads are finished?

  2. is it better to call Contexts.LockList() on the TIdTCPServer before the timer starts creating the threads, and unlock it after the threads are finished?

  3. What can I do to optimize my code so I can be sure that the timer will be alive all the time? I am restarting the timer after all threads are finished. Is this the correct way to do it?

Request:

How is it possible to accept a string like hi from a client connected on the TIdTCPServer and send back a string.

I try to add the following code:

var
  RxBuf: TIdBytes;

Data := TxClientContext(AContext).ExtractQueuedStrings;
if Data <> nil then
try
  for i := 0 to Pred(Data.Count) do
    AContext.Connection.IOHandler.WriteLn(Data[i]);
finally
  Data.Free;
end;

RxBuf := nil;
with AContext.Connection do
begin
  IOHandler.CheckForDataOnSource(100);
  if not IOHandler.InputBufferIsEmpty then
  begin
    InputBuffer.ExtractToBytes(RxBuf); //for TIdBytes
    AContext.Connection.IOHandler.WriteLn('hello');
  end;
end;

After sending hello the app never sends data from the queue.

How can I add the hello to Data extract from queue?

Something like this:

Data := TxClientContext(AContext).ExtractQueuedStrings;

and then

data.text:=data.text +'hello data';

or how can I add the 'hello data' in the queue?

Solution

  • I see a lot of mistakes in your code. Rather than pointing them out individually, I would suggest just rewritting the entire code, especially since you are also asking for optimizations.

    Try something more like this instead:

    unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls,
  IdGlobal, IdContext, IdBaseComponent, IdComponent, IdTCPConnection, IdCustomTCPServer,
  IdTCPServer, IdThreadSafe;

type
  TIdTCPServer = class(IdTCPServer.TIdTCPServer)
  protected
    procedure DoTerminateContext(AContext: TIdContext); override;
  end;

  TForm1 = class(TForm)
    IdTCPServer1: TIdTCPServer;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure IdTCPServer1Connect(AContext: TIdContext);
    procedure IdTCPServer1Execute(AContext: TIdContext);
  private
    { Private declarations }
    IDs: TIdThreadSafeString;
    Threads: TList;
    procedure ThreadTerminated(Sender: TObject);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses
  System.Win.Comobj, MSXML2_TLB, ActiveX, System.SyncObjs, IdHTTP, IdYarn;

{$R *.dfm}

const
  maximumThreads = 100;//200;

{TxClientContext}

type 
  TxClientContext = class(TIdServerContext)
  private
    fQueue: TIdThreadSafeStringList;
    fInQueue: TEvent;
  public
    constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil); override;
    destructor Destroy; override;
    procedure AddStringToQueue(const S: string);
    function ExtractQueuedStrings: TStrings;
  end;

constructor TxClientContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
begin
  inherited;
  fQueue := TIdThreadSafeStringList.Create;
  fInQueue := TEvent.Create(nil, True, False, '');
end;

destructor TxClientContext.Destroy; override;
begin
  fQueue.Free;
  fInQueue.Free;
  inherited;
end;

procedure TxClientContext.AddStringToQueue(const S: string);
var
  List: TStringList;
begin
  List := fQueue.Lock;
  try
    List.Add(S);
    fInQueue.SetEvent;
  finally
    fQueue.Unlock;
  end;
end;

function TxClientContext.ExtractQueuedStrings: TStrings;
var
  List: TStringList;
begin
  Result := nil;
  if fInQueue.WaitFor(INFINITE) <> wrSignaled then Exit;
  List := FQueue.Lock;
  try
    if List.Count > 0 then
    begin
      Result := TStringList.Create;
      try
        Result.Assign(List);
        List.Clear;
      except
        Result.Free;
        raise;
      end;
    end;
    fInQueue.ResetEvent;
  finally
    fQueue.Unlock;
  end;
end;

{TxClientThread}

type
  TxClientThread = class(TThread)
  private
    fURL: String;
  protected
    procedure Execute; override;
  public
    GameID: string;
    constructor Create(AURL: string; AOnTerminate: TNotifyEvent); reintroduce;
  end;

constructor TxClientThread.Create(AURL: string; AOnTerminate: TNotifyEvent);
begin
  inherited Create(False);
  fURL := AURL;
  OnTerminate := AOnTerminate;
  FreeOnTerminate := True;
end;

procedure TxClientThread.Execute;
var
  HttpClient: TIdHTTP;
  ResponseXML: String;
  XML: IXMLDOMDocument;
  Node: IXMLDomNode;
begin
  HttpClient := TIdHTTP.Create(nil);
  try
    HttpClient.ConnectTimeout := 60000;
    HttpClient.ReadTimeout := 60000;
    HttpClient.Request.Accept := '*/*';
    HttpClient.Request.UserAgent := 'Mozilla/5.0 (Windows NT 6.1; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/73.0.3683.86 Safari/537.36';

    ResponseXML := HttpClient.Get(fURL);
  finally
    HttpClient.Free;
  end;

  CoInitialize(nil);
  try
    XML := CreateOleObject('Microsoft.XMLDOM') as IXMLDOMDocument;
    try
      XML.async := False;
      XML.loadXML(ResponseXML); 
      Node := XML.selectSingleNode('/games');
      if Node <> nil then
      try
        GameID := Node.attributes.getNamedItem('id').text;
      finally
        Node := nil;
      end;
    finally
      XML := nil;
    end;
  finally
    CoUninitialize;
  end;
end;

{TIdTCPServer}

procedure TIdTCPServer.DoTerminateContext(AContext: TIdContext);
begin
  inherited; // <-- closes the socket
  TxClientContext(AContext).FInQueue.SetEvent; // unblock OnExecute if it is waiting for data...
end;

{TForm1}

procedure TForm1.FormCreate(Sender: TObject);
begin
  IdTCPServer1.ContextClass := TxClientContext;
  IDs := TIdThreadSafeString.Create;
  Threads := TList.Create;
  Threads.Capacity := maximumThreads;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  IDs.Free;
  Threads.Free;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  x: Integer;
  Thread: TxClientThread;
begin
  Timer1.Enabled := False;
  IDs.Value := '';
  for x := 0 to Pred(maximumThreads) do
  begin
    Thread := TxClientThread.Create('http://example.com/myxml' + IntToStr(x) + '.xml', ThreadTerminated);
    try
      Threads.Add(TObject(Thread));
    except
      Thread.Free;
      raise;
    end;
  end;
end;

proccedure TForm1.ThreadTerminated(Sender: TObject);
var
  Clients: TList;
  s: string;
  i: Integer;
begin
  try
    s := TxClientThread(Sender).GameID;
    if s <> '' then IDs.Append(s + '^');
  finally
    Threads.Remove(Sender);
  end;

  if (Threads.Count > 0) or (not Assigned(IdTCPServer1.Contexts)) then Exit;

  s := IDs.Value;
  if s = '' then Exit;

  Clients := IdTCPServer1.Contexts.LockList;
  try
    for i := Pred(Clients.Count) downto 0 do
    try
      TxClientContext(TIdContext(Clients[i])).AddStringToQueue(s);
    except
    end;
  finally
    IdTCPServer1.Contexts.UnlockList;
  end;

  Timer1.Enabled := True;
end;

procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
begin
  AContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8;
end;

procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
var
  Data: TStrings;
  i: Integer;
begin
  Data := TxClientContext(AContext).ExtractQueuedStrings;
  if Data <> nil then
  try
    for i := 0 to Pred(Data.Count) do
      AContext.Connection.IOHandler.WriteLn(Data[i]);
  finally
    Data.Free;
  end;
end;

end.