Приложение для замораживания сервера Delphi XE2 Indy 10 TIdCmdTCPServer

Причина зависания вашего сервера заключается в том, что вы блокируете код своего сервера.

Для каждого клиента, который подключается к TIdCmdTCPServer, создается рабочий поток, который непрерывно считывает входящие команды из этого подключения, поэтому он может запускать TIdCommandHandler.OnCommand события в коллекции TIdCmdTCPServer.CommandHandlers. TCli.DoTest() вызывает TIdTCPConnection.SendCmd(), чтобы отправить команду клиенту и прочитать его ответ. Вы вызываете TCli.DoTest() (и, следовательно, SendCmd()) в контексте основного потока, поэтому у вас есть два отдельных контекста потока, которые пытаются одновременно читать из одного и того же соединения, что вызывает состояние гонки. Рабочий поток, работающий внутри TIdCmdTCPServer, вероятно, читает части (если не все) данных, которые SendCmd() ожидает и никогда не увидит, поэтому SendCmd() не завершает работу должным образом, блокируя основной цикл сообщений от возможности обрабатывать новые сообщения когда-либо снова. А ну заморозить.

Размещение TIdAntiFreeze в серверном приложении может помочь избежать зависания, позволяя контексту основного потока продолжать обработку сообщений, пока SendCmd() находится в тупике. Но это не верное решение. Чтобы это исправить, вам нужно изменить дизайн серверного приложения. Во-первых, не используйте TIdCmdTCPServer с TIdCmdTCPClient, поскольку они не предназначены для совместного использования. Если ваш сервер собирается отправлять команды клиенту, а клиент никогда не отправляет команды серверу, используйте простой TIdTCPServer вместо TIdCmdTCPServer. Но даже если вы не сделаете это изменение, у вас останутся другие проблемы с текущим серверным кодом. Обработчики событий вашего сервера не выполняют поточно-ориентированные операции, и вам необходимо переместить вызов в TCli.DoTest() из контекста основного потока.

Попробуйте этот код:

uServer.pas:

unit uServer; 

interface 

uses 
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, System.SyncObjs,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, IdContext, IdBaseComponent, IdComponent,
  IdTCPConnection, IdCustomTCPServer, IdTCPServer, IdThreadSafe, IdYarn, Vcl.StdCtrls, Vcl.Buttons,
  Vcl.ComCtrls; 

type 
  TCli = class(TIdServerContext) 
  private 
    fCmdQueue: TIdThreadSafeStringList;
    fCmdEvent: TEvent;
    function GetIP: String;
  public 
    constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TThreadList = nil); override;
    destructor Destroy; override;
    procedure PostCmd(const S: String); 
    property CmdQueue: TIdThreadSafeStringList read fCmdQueue;
    property CmdEvent: TEvent read fCmdEvent;
    property IP: String read GetIP;
  end; 

  TForm3 = class(TForm) 
    Svr: TIdTCPServer; 
    Lst: TListView; 
    Log: TMemo; 
    cmdDoCmdTest: TBitBtn; 
    procedure cmdDoCmdTestClick(Sender: TObject); 
    procedure FormClose(Sender: TObject; var Action: TCloseAction); 
    procedure FormCreate(Sender: TObject); 
    procedure SvrConnect(AContext: TIdContext); 
    procedure SvrDisconnect(AContext: TIdContext); 
    procedure SvrExecute(AContext: TIdContext);
    procedure SvrException(AContext: TIdContext; AException: Exception); 
  public 
    procedure NewContext(AContext: TCli); 
    procedure DelContext(AContext: TCli); 
  end; 

var 
  Form3: TForm3; 

implementation 

uses
  IdSync;

{$R *.dfm} 

{ TLog } 

type
  TLog = class(TIdNotify)
  protected
    fMsg: String;
    procedure DoNotify; override;
  public
    class procedure PostLog(const S: String);
  end;

procedure TLog.DoNotify;
begin
  Form3.Log.Lines.Append(fMsg); 
end;

class procedure TLog.PostLog(const S: String);
begin
  with Create do begin
    fMsg := S;
    Notify;
  end;
end;

{ TCliList }

type
  TCliList = class(TIdSync)
  protected
    fCtx: TCli;
    fAdding: Boolean;
    procedure DoSynchronize; override;
  public
    class procedure AddContext(AContext: TCli);
    class procedure DeleteContext(AContext: TCli);
  end;

procedure TCliList.DoSynchronize;
begin
  if fAdding then
    Form3.NewContext(fCtx)
  else
    Form3.DelContext(fCtx); 
end;

class procedure TCliList.AddContext(AContext: TCli);
begin
  with Create do try
    fCtx := AContext;
    fAdding := True;
    Synchronize;
  finally
    Free;
  end;
end;

class procedure TCliList.DeleteContext(AContext: TCli);
begin
  with Create do try
    fCtx := AContext;
    fAdding := False;
    Synchronize;
  finally
    Free;
  end;
end;

{ TCli } 

constructor TCli.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TThreadList = nil);
begin
  inherited Create(AConnection, AYarn, AList);
  fCmdQueue := TIdThreadSafeStringList.Create;
  fCmdEvent := TEvent.Create(nil, True, False, '');
end;

destructor TCli.Destroy;
begin
  fCmdQueue.Free;
  fCmdEvent.Free;
  inherited Destroy;
end;

procedure TCli.PostCmd; 
var
  L: TStringList;
begin
  L := fCmdQueue.Lock;
  try
    L.Add('DoCmdTest');
    fCmdEvent.SetEvent;
  finally
    fCmdQueue.Unlock;
  end;
end; 

function TCli.GetIP: String; 
begin 
  Result := Binding.PeerIP; 
end; 

{ TForm3 } 

procedure TForm3.SvrConnect(AContext: TIdContext); 
var 
  C: TCli; 
begin 
  C := TCli(AContext); 
  TCliList.AddContext(C); 
  TLog.PostLog(C.IP + ': Connected');
end; 

procedure TForm3.SvrDisconnect(AContext: TIdContext); 
var 
  C: TCli; 
begin 
  C := TCli(AContext); 
  TCliList.DeleteContext(C); 
  TLog.PostLog(C.IP + ': Disconnected'); 
end; 

procedure TForm3.SvrExecute(AContext: TIdContext);
var
  C: TCli;
  L, Q: TStringList;
  X: Integer;
begin
  C := TCli(AContext);

  if C.CmdEvent.WaitFor(500) <> wrSignaled then Exit;

  Q := TStringList.Create;
  try
    L := C.CmdQueue.Lock;
    try
      Q.Assign(L);
      L.Clear;
      C.CmdEvent.ResetEvent;
    finally
      C.CmdQueue.Unlock;
    end;
    for X := 0 to Q.Count - 1 do begin
      AContext.Connection.SendCmd(Q.Strings[X]);
    end;
  finally
    Q.Free;
  end;
end;

procedure TForm3.SvrException(AContext: TIdContext; AException: Exception); 
var 
  C: TCli; 
begin 
  C := TCli(AContext); 
  TLog.PostLog(C.IP + ': Exception: ' + AException.Message); 
end; 

procedure TForm3.cmdDoCmdTestClick(Sender: TObject); 
var 
  X: Integer;
  L: TList; 
begin 
  L := Svr.Contexts.LockList; 
  try
    for X := 0 to L.Count - 1 do begin 
      TCli(L.Items[X]).PostCmd; 
    end;
  finally
    Svr.Contexts.UnlockList;
  end; 
end; 

procedure TForm3.DelContext(AContext: TCli); 
var 
  I: TListItem; 
begin 
  I := Lst.FindData(0, AContext, true, false); 
  if I <> nil then I.Delete; 
end; 

procedure TForm3.FormClose(Sender: TObject; var Action: TCloseAction); 
begin 
  Svr.Active := False; 
end; 

procedure TForm3.FormCreate(Sender: TObject); 
begin 
  Svr.ContextClass := TCli;
  Svr.Active := True; 
end; 

procedure TForm3.NewContext(AContext: TCli); 
var 
  I: TListItem; 
begin 
  I := Lst.Items.Add; 
  I.Caption := AContext.IP;
  I.Data := AContext; 
end; 

end. 

uServer.dfm:

object Form3: TForm3 
  Left = 315 
  Top = 113 
  Caption = 'Indy 10 Command TCP Server' 
  ClientHeight = 308 
  ClientWidth = 529 
  Color = clBtnFace 
  Font.Charset = DEFAULT_CHARSET 
  Font.Color = clWindowText 
  Font.Height = -11 
  Font.Name = 'Tahoma' 
  Font.Style = [] 
  OldCreateOrder = False 
  OnCreate = FormCreate 
  DesignSize = ( 
    529 
    308) 
  PixelsPerInch = 96 
  TextHeight = 13 
  object Lst: TListView 
    Left = 336 
    Top = 8 
    Width = 185 
    Height = 292 
    Anchors = [akTop, akRight, akBottom] 
    Columns = < 
      item 
        AutoSize = True 
      end> 
    TabOrder = 0 
    ViewStyle = vsReport 
    ExplicitLeft = 333 
    ExplicitHeight = 288 
  end 
  object Log: TMemo 
    Left = 8 
    Top = 56 
    Width = 316 
    Height = 244 
    Anchors = [akLeft, akTop, akRight, akBottom] 
    Font.Charset = DEFAULT_CHARSET 
    Font.Color = clWindowText 
    Font.Height = -11 
    Font.Name = 'Tahoma' 
    Font.Style = [fsBold] 
    ParentFont = False 
    ScrollBars = ssVertical 
    TabOrder = 1 
  end 
  object cmdDoCmdTest: TBitBtn 
    Left = 8 
    Top = 8 
    Width = 217 
    Height = 42 
    Caption = 'Send Test Command' 
    Font.Charset = DEFAULT_CHARSET 
    Font.Color = clWindowText 
    Font.Height = -13 
    Font.Name = 'Tahoma' 
    Font.Style = [fsBold] 
    ParentFont = False 
    TabOrder = 2 
    OnClick = cmdDoCmdTestClick 
  end 
  object Svr: TIdTCPServer 
    Bindings = <> 
    DefaultPort = 8664 
    MaxConnections = 100 
    OnConnect = SvrConnect 
    OnDisconnect = SvrDisconnect 
    OnExecute = SvrExecute
    OnException = SvrException 
    Left = 288 
    Top = 8 
  end 
end 

uClient.pas:

unit uClient; 

interface 

uses 
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, 
  System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, 
  Vcl.ExtCtrls, 
  IdContext, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, 
  IdCmdTCPClient, IdCommandHandlers, Vcl.StdCtrls; 

const                             // --- Change accordingly --- 
  TMR_INT = 10000;                //how often to check for connection 
  SVR_IP =  '192.168.4.100';      //Server IP Address 
  SVR_PORT = 8664;                //Server Port 

type 
  TForm4 = class(TForm) 
    Tmr: TTimer; 
    Cli: TIdCmdTCPClient; 
    Log: TMemo; 
    procedure CliCommandHandlers0Command(ASender: TIdCommand); 
    procedure TmrTimer(Sender: TObject); 
    procedure FormCreate(Sender: TObject); 
    procedure FormClose(Sender: TObject; var Action: TCloseAction); 
    procedure CliConnected(Sender: TObject); 
    procedure CliDisconnected(Sender: TObject); 
  private 
    procedure AppMessage(var Msg: TMsg; var Handled: Boolean);
    procedure PostLog(const S: String); 
    procedure PostReconnect;
  public 
  end; 

var 
  Form4: TForm4; 

implementation 

uses
  IdSync;

{$R *.dfm} 

{ TLog } 

type
  TLog = class(TIdNotify)
  protected
    fMsg: String;
    procedure DoNotify; override;
  public
    class procedure PostLog(const S: String);
  end;

procedure TLog.DoNotify;
begin
  Form4.Log.Lines.Append(fMsg); 
end;

class procedure TLog.PostLog(const S: String);
begin
  with Create do begin
    fMsg := S;
    Notify;
  end;
end;

{ TForm4 }

const
  WM_START_RECONNECT_TIMER = WM_USER + 100;

procedure TForm4.CliCommandHandlers0Command(ASender: TIdCommand); 
begin 
  TLog.PostLog('Received command successfully'); 
end; 

procedure TForm4.CliConnected(Sender: TObject); 
begin 
  TLog.PostLog('Connected to Server'); 
end; 

procedure TForm4.CliDisconnected(Sender: TObject); 
begin 
  TLog.PostLog('Disconnected from Server'); 
  PostReconnect;
end; 

procedure TForm4.FormClose(Sender: TObject; var Action: TCloseAction); 
begin 
  Tmr.Enabled := False;
  Application.OnMessage := nil;
  Cli.Disconnect; 
end; 

procedure TForm4.FormCreate(Sender: TObject); 
begin 
  Application.OnMessage := AppMessage;
  Tmr.Enabled := True; 
end; 

procedure TForm4.AppMessage(var Msg: TMsg; var Handled: Boolean);
begin
  if Msg.message = WM_START_RECONNECT_TIMER then begin
    Handled := True;
    Tmr.Interval := TMR_INT; 
    Tmr.Enabled := True; 
  end;
end;

procedure TForm4.TmrTimer(Sender: TObject); 
begin 
  Tmr.Enabled := False; 

  Cli.Disconnect; 
  try 
    Cli.Host := SVR_IP; 
    Cli.Port := SVR_PORT; 
    Cli.Connect; 
  except 
    PostReconnect;
  end; 
end; 

procedure TForm4.PostReconnect;
begin
  PostMessage(Application.Handle, WM_START_RECONNECT_TIMER, 0, 0);
end;

end. 

uClient.dfm:

object Form4: TForm4 
  Left = 331 
  Top = 570 
  Caption = 'Indy 10 Command TCP Client' 
  ClientHeight = 317 
  ClientWidth = 305 
  Color = clBtnFace 
  Font.Charset = DEFAULT_CHARSET 
  Font.Color = clWindowText 
  Font.Height = -11 
  Font.Name = 'Tahoma' 
  Font.Style = [] 
  OldCreateOrder = False 
  OnClose = FormClose 
  OnCreate = FormCreate 
  DesignSize = ( 
    305 
    317) 
  PixelsPerInch = 96 
  TextHeight = 13 
  object Log: TMemo 
    Left = 8 
    Top = 56 
    Width = 289 
    Height = 253 
    Anchors = [akLeft, akTop, akRight, akBottom] 
    ScrollBars = ssVertical 
    TabOrder = 0 
    ExplicitWidth = 221 
    ExplicitHeight = 245 
  end 
  object Tmr: TTimer 
    Enabled = False 
    OnTimer = TmrTimer 
    Left = 56 
    Top = 8 
  end 
  object Cli: TIdCmdTCPClient 
    OnDisconnected = CliDisconnected 
    OnConnected = CliConnected 
    ConnectTimeout = 0 
    Host = '192.168.4.100' 
    IPVersion = Id_IPv4 
    Port = 8664 
    ReadTimeout = -1 
    CommandHandlers = < 
      item 
        CmdDelimiter = ' ' 
        Command = 'DoCmdTest' 
        Disconnect = False 
        Name = 'cmdDoCmdTest' 
        NormalReply.Code = '200' 
        ParamDelimiter = ' ' 
        ParseParams = True 
        Tag = 0 
        OnCommand = CliCommandHandlers0Command 
      end> 
    ExceptionReply.Code = '500' 
    ExceptionReply.Text.Strings = ( 
      'Unknown Internal Error') 
    Left = 16 
    Top = 8 
  end 
end 

Вы пробовали отлаживать сервер?

Линия

Result:= TCli(AContext);

(жесткое приведение TIdContext) выглядит потенциальной причиной зависания.

Вы читали это, как сделать так, чтобы TIdCustomTCPServer узнал о вашем собственном классе TIdServerContext?

https://stackoverflow.com/a/5514932/80901

Соответствующий код в ответе:

constructor TOurServer.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);

  ...

    ContextClass := TOurContext;

  ...
end;