Prevent TIdTcpServer Stuck Connections

问题:

how are you? I come here ask for a solution, how prevent TIdTcpServer stuck connections?

Version of indy 10.6.2.5341 and Rad Studio 10.1 Berlin

On both images show the number of connections on TIdTcpServer, these numbers are retrieved from this function:

var
  NumClients: Integer;
begin
  with Form1.IdTCPServer1.Contexts.LockList do
  try
    NumClients := Count;
  finally
    Form1.IdTCPServer1.Contexts.UnlockList;
  end;

  Result := NumClients;

What happen is, in almost cases this numbers only increase and not decrease. so i believe connections are being stucked on TIdTcpServer.

I use a IdSchedulerOfThreadDefault1 on Scheduler, i don't know if that change something or no but i added.

For manage connections i use ContextClass:

IdTCPServer1.ContextClass := TClientContext;

Who definition is:

    type
  TCommand = (
    cmdConnect,
    cmdDisconnect,
    cmdHWID,
    cmdScreenShotData,
    cmdMensagem);

type
  TClient = record
    HWID  : String[40];
    Tempo : TDateTime;
    Msg   : String[100];
end;

const
  szClient = SizeOf(TClient);

type
  TProtocol = record
    Command: TCommand;
    Sender: TClient;
    DataSize: Integer;
end;

const
  szProtocol = SizeOf(TProtocol);

type
  TClientContext = class(TIdServerContext)
  private
    FCriticalSection  : TCriticalSection;
    FClient           : TClient;
  public
    constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil); override;
    destructor Destroy; override;
  public
    procedure Lock;
    procedure Unlock;
  public
    property Client: TClient read FClient write FClient;
end;

Others functions who are used:

procedure InitProtocol(var AProtocol: TProtocol);
begin
  FillChar(AProtocol, szProtocol, 0);
end;

function ProtocolToBytes(const AProtocol: TProtocol): TBytes;
begin
  SetLength(Result, szProtocol);
  Move(AProtocol, Result[0], szProtocol);
end;

constructor TClientContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
begin
  inherited Create(AConnection, AYarn, AList);
  FCriticalSection := TCriticalSection.Create;
end;

destructor TClientContext.Destroy;
begin
  FreeAndNil(FCriticalSection);
  inherited;
end;

procedure TClientContext.Lock;
begin
  FCriticalSection.Enter;
end;

procedure TClientContext.Unlock;
begin
  FCriticalSection.Leave;
end;

function BytesToProtocol(const ABytes: TBytes): TProtocol;
begin
  Move(ABytes[0], Result, szProtocol);
end;

procedure ClearBuffer(var ABuffer: TBytes);
begin
  SetLength(ABuffer, 0);
end;

procedure ClearBufferId(var ABuffer: TIdBytes);
begin
  SetLength(ABuffer, 0);
end;

All events (connect/disconnect) i manage on IdTCPServer1Execute like this example above:

    type
  PTBytes   = ^TBytes;
  PTIdBytes = ^TIdBytes;
var
  LBuffer     : TIdBytes;
  LProtocol   : TProtocol;
  FTempBuffer : TIdBytes;

  Enviar    : TBytes;
  Protocolo : TProtocol;

  Conexao   : TClientContext;

  //

  Queue: TStringList;
  List: TStringList;
  x : Integer;

  //

  procedure AddToMemo(const AStr: string);
  begin
    TThread.Synchronize(nil,
      procedure
      begin
        Memo1.Lines.Add(AStr);
        Form1.StatusBar1.Panels[0].Text := Format('Connections [%d]', [RetornaOn]);
      end
    );
  end;
begin
  Conexao := TClientContext(AContext);

  // QUEUE

  List := nil;
  try
    Queue := Conexao.Queue.Lock;
    try
      if Queue.Count > 0 then
      begin
        List := TStringList.Create;
        List.Assign(Queue);
        Queue.Clear;
      end;
    finally
      Conexao.Queue.Unlock;
    end;

    if List <> nil then
    begin
      for x := 0 to List.Count-1 do
      begin
        InitProtocol(Protocolo);

        Protocolo.Command     := cmdMensagem;
        Protocolo.Sender.Msg  := Edit2.Text;
        Enviar                := ProtocolToBytes(Protocolo);

        Conexao.Connection.IOHandler.Write(PTIdBytes(@Enviar)^);

        ClearBuffer(Enviar);
      end;

      // Delete Queue

      for x := 0 to List.Count-1 do
      begin
        List.Delete(x);
      end;
    end;
  finally
    List.Free;
  end;

  // QUEUE

  if AContext.Connection.IOHandler.InputBufferIsEmpty then
  begin
    //AddToMemo(Format('[%s] Running 1 ...', [TimeToStr(Now)]));

    AContext.Connection.IOHandler.CheckForDataOnSource(100);
    AContext.Connection.IOHandler.CheckForDisconnect;
    if AContext.Connection.IOHandler.InputBufferIsEmpty then
    begin
      {AddToMemo(Format('[%s] Running 2 ...', [TimeToStr(Now)]));

      if GetTickDiff(Conexao.Client.Tick, Ticks) >= 10000 then
      begin
        AddToMemo(Format('[%s] Running 3 [%d] ...', [TimeToStr(Now), Conexao.Client.Tick]));

        AContext.Connection.Disconnect;
        Exit;
      end;}

      Exit;
    end;
  end;

  AContext.Connection.IOHandler.ReadBytes(LBuffer, szProtocol, False);

  LProtocol := BytesToProtocol(PTBytes(@LBuffer)^);

  case LProtocol.Command of
    cmdConnect: begin
      Conexao.Client := LProtocol.Sender;
      Conexao.FClient.Tick := Ticks;


        AddToMemo(Format('[%s] : [%s][%s]', ['Connect', AContext.Connection.Socket.Binding.PeerIP, Protocolo.Sender.HWID]));
    end;

    cmdMensagem: begin
      AddToMemo(Format('[%s] : [%s][%s][%s]', ['Msg', AContext.Connection.Socket.Binding.PeerIP, Conexao.Client.HWID, LProtocol.Sender.Msg]));
    end;

    cmdDisconnect: begin
      AddToMemo(Format('[%s] : [%s][%s]', ['Disconnect', AContext.Connection.Socket.Binding.PeerIP, Conexao.Client.HWID]));
    end;
  end;

In next code i show how client side connect to TIdTcpServer:

type
  PTIdBytes = ^TIdBytes;
var
  LBuffer   : TBytes;
  LProtocol : TProtocol;
begin
  ClientThread := TClientThread.Create(False);

  InitProtocol(LProtocol);
  LProtocol.Command       := cmdConnect;
  LProtocol.Sender.HWID   := Edit1.Text;
  LProtocol.Sender.Tempo  := Now;
  LBuffer                 := ProtocolToBytes(LProtocol);
  IdTCPClient1.IOHandler.Write(PTIdBytes(@LBuffer)^);
  ClearBuffer(LBuffer);

  AddToMemo('IdTCPClient1 connected to server');

ClientThread on client:

procedure TClientThread.Execute;
type
  PTBytes   = ^TBytes;
  PTIdBytes = ^TIdBytes;
var
  LBuffer     : TIdBytes;
  LDataSize   : Integer;
  LProtocol   : TProtocol;

  procedure AddToMemo(const AStr: string);
  begin
    TThread.Synchronize(nil,
      procedure
      begin
        Form1.Memo1.Lines.Add('Received From Server: ' + AStr);
      end
    );
  end;
begin
  inherited;
  while NOT Terminated and Form1.IdTCPClient1.Connected do begin
    //LDataSize := Form1.IdTCPClient1.IOHandler.InputBuffer.Size;

    //if LDataSize >= szProtocol then begin
      try
        Form1.IdTCPClient1.IOHandler.ReadBytes(LBuffer, szProtocol);

        LProtocol := BytesToProtocol(PTBytes(@LBuffer)^);

        case LProtocol.Command of
          cmdHWID:
          begin
            HWID := LProtocol.Sender.HWID;
            AddToMemo('HWID > ' + LProtocol.Sender.HWID);
          end;

          cmdDisconnect:
          begin
            AddToMemo('DC > ' + LProtocol.Sender.HWID);
          end;

          cmdMensagem:
          begin
            AddToMemo('MSG > ' + LProtocol.Sender.Msg);
          end;
        end;
      finally
        ClearBufferId(LBuffer);
      end;
    //end;

    Sleep(50);
  end;
end;

Anybody know why these connections are being stucked on TIdTcpServer? Maybe if i loop all conenctions and try send a single text will disconnect they if don't are really connected to IdTcpServer no ?

Thanks.