tIdHttp Внутренний поток и IdTCPServer в графическом интерфейсе

Question

У меня есть TTimer на TForm, где таймер установлен на 5 секунд и создает 100 потоков для извлечения XML с удаленного сервера.

Каждый раз, когда выполняется поток, я добавляю XML в переменную (FullXML_STR:String).

Когда все потоки завершены, я отправляю FullXML_STR всем Клиентам, подключенным к 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.

Основная проблема в том, что через 1-2 часа программа не отвечает.

1. в каждом потоке Execute(), я проверяю, все ли потоки закончили загрузку. Есть ли лучший способ узнать, что все мои темы закончены?

2. лучше ли вызвать Contexts.LockList() на TIdTCPServer до того, как таймер начнет создавать потоки, и разблокировать его после завершения потоков?

3. Что я могу сделать, чтобы оптимизировать мой код, чтобы быть уверенным, что таймер будет работать постоянно? Я перезапускаю таймер после завершения всех потоков. Это правильный способ сделать это?

Запрос:

Как можно принять строку типа hi от клиента, подключенного к TIdTCPServer, и отправить обратно строку.

Я пытаюсь добавить следующий код:

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;

После отправки hello приложение никогда не отправляет данные из очереди.

Как добавить hello к извлечению данных из очереди?

Примерно так:

Data := TxClientContext(AContext).ExtractQueuedStrings;

, а затем

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

или как мне добавить 'hello data' в очередь?

Answer 1

Я вижу много ошибок в вашем коде. Вместо того чтобы указывать их по отдельности, я бы предложил переписать весь код, тем более что вы также просите об оптимизации.

Попробуйте вместо этого что-нибудь еще:

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.

Answer 2

В каждом потоке вы добавляете полученную строку в глобальную переменную. Это не безопасная операция. Вместо этого добавьте обработчик OnTerminate в свои потоки, где вы добавите результат, а также сможете отслеживать потоки.

Это безопасно, поскольку обработчик OnTerminate выполняется в главном потоке. Я предлагаю передать метод обратного вызова, чтобы передать результат. Объявлено как:

type
  TSyncMethod = procedure(const ReturnValue: String) of object;

Измените тему соответственно:

Type 
  TxClientThread = class(TThread)
    private
      furl : String;
      ftag : Integer;
      fCallbackMethod : TSyncMethod;
      fXMLResult : String;
      procedure AfterWork(Sender : TObject);
      ...
    public
      constructor Create(atag: Integer; AURL: string; CallbackMethod : TSyncMethod); reintroduce;
    ...
  end;

Добавьте метод обратного вызова в вашу форму:

Type
  TForm1 = Class(TForm1)
  private
    // Put your "global" variables here
    Threads_downloaded : Integer;
    Total_threads      : Integer;
    FullXML_STR        : String;
    procedure ManageThreadReturnValue(const ReturnValue : String); // Callback from threads
  ...
  end; 

Часть реализации:

constructor TxClientThread.Create(atag: Integer; AURL: string; CallbackMethod : TSyncMethod);
begin
  inherited Create(false);
  furl := Aurl;
  ftag := Atag;
  fCallbackMethod := CallbackMethod;
  fXMLResult := '';
  OnTerminate := AfterWork;  // Execute AfterWork when thread terminates (in main thread)
  FreeOnTerminate := True;
end;

procedure TxClientThread.Execute;
var
  lHttpClient : TIdHTTP;
  lResponseXML :String;
  lXML : IXMLDOMDocument;
  lNode : IXMLDomNode;
begin
  lHttpClient := TIdHTTP.Create(nil);
  try
    lHttpClient.Tag := ftag;
    lHttpClient.ConnectTimeout := 60000;
    lHttpClient.ReadTimeout := 60000;
    lHttpClient.Request.Accept := '*/*';
    lHttpClient.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';

    try 
      lResponseXML:= lHttpClient.Get(fUrl);
    except 
    end;
  finally
    lHttpClient.Free;
  end;

  ///******     parsing The XML
  CoInitialize(nil);
  try        
    lXML := CreateOleObject('Microsoft.XMLDOM') as IXMLDOMDocument;
    lXML.async := false;
    try
      lXML.loadXML(lResponseXML); 
      lNode := lXML.selectSingleNode('/games');
      if lNode<>nil then
      begin
        fXMLResult := lNode.attributes.getNamedItem('id').text+'^';
      end;
    finally
      lnode := nil;
      lxml := nil; //---> Q: do i need this? 
                   //---> A: Yes, it must be finalized before CoUnitialize
    end;
  finally
    CoUninitialize;
  end;
end;

procedure TxClientThread.AfterWork;
begin
  if Assigned(fCallbackMethod) then
     fCallbackMethod(fXMLResult);  // Pass data
end;

procedure TForm1.ManageThreadReturnValue(const ReturnValue : String);
var
 i : Integer;
 Clients : TList;
begin
  // Take care of the return value and other things related to 
  // what happens when a thread ends.
  FullXML_STR := FullXML_STR + ReturnValue;
  Inc(threads_downloaded);
  if Threads_downloaded = Total_threads then
  begin
    if Assigned(IdTCPServer1.Contexts) then 
    begin
      Clients:= IdTCPServer1.Contexts.LockList;
      try
        for i:= Pred(Clients.Count) downto 0 do
        begin
          try
            TIdContext(Clients[i]).Connection.IOHandler.Writeln( 
              FullXML_STR,IndyTextEncoding_UTF8);
          except
          end;
        end;
      finally
        IdTCPServer1.Contexts.UnlockList;
      end;
    end;
    StartTimerAgain; ///Starting again The timer
  end;      
end;    

// Initiate threads 
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';
  TxClientThread.Create(x,aUrl,ManageThreadReturnValue);  // !! Never keep a reference to a thread with FreeOnTerminate = true
end;

---

Некоторые другие советы:

Поместите ваши глобальные переменные в приватный раздел TForm1. Это место, где они принадлежат.

Удалите массив ClientThread, поскольку ссылка на поток с FreeOnTerminate = true никогда не должна использоваться.

Не глотать исключения, т. Е. Пустые except end предложения не являются хорошей практикой.

Используя метод обратного вызова, вы отделяете поток от кода / данных, которые не принадлежат потоку. Это один из самых важных уроков, которые нужно усвоить при программировании (т.е. избегать создания кода для спагетти).