Indy TCP Server无法通过服务工作？

Question

I want to run the Indy Server from a service and I used the following code but nothing happens. When I run the service I don't receive any exceptions on starting the server but I don't receive "Connected" message either when I try to connect. Am I doing it wrong or this thing it's not possible ? The server code was tested in a normal application and it's ok, it receives connections.

I just started to learn services and I read some tutorials and they say that a very common use of a service is to check for updates for your application so I think my server should work...

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs,
  IdBaseComponent, IdComponent, IdCustomTCPServer, IdTCPServer, IdContext;

type
  TMarusTestService = class(TService)
    IdTCPServer1: TIdTCPServer;
    procedure ServiceExecute(Sender: TService);
    procedure ServiceStart(Sender: TService; var Started: Boolean);
    procedure ServiceStop(Sender: TService; var Stopped: Boolean);
    procedure IdTCPServer1Execute(AContext: TIdContext);
  public
    function GetServiceController: TServiceController; override;
  end;

var
  MarusTestService: TMarusTestService;

implementation

{$R *.DFM}

procedure ServiceController(CtrlCode: DWord); stdcall;
begin
  MarusTestService.Controller(CtrlCode);
end;

function TMarusTestService.GetServiceController: TServiceController;
begin
  Result := ServiceController;
end;

procedure TMarusTestService.IdTCPServer1Execute(AContext: TIdContext);
var f:textfile;
begin
 AssignFile(f,'f:\service.txt');
 Rewrite(f);
 Writeln(f,'Connected');
 CloseFile(f);
 repeat
  AContext.Connection.Socket.ReadLongWord;
  AContext.Connection.Socket.Write($93667B01);
 until false;
end;

procedure TMarusTestService.ServiceExecute(Sender: TService);
var f:textfile;
begin
  IdTCPServer1.Bindings.Clear;
  IdTCPServer1.Bindings.Add.SetBinding('192.168.1.2', 1280);
  try
   IdTCPServer1.Active:=True;
  except
    on E: Exception do
     begin
      AssignFile(f,'f:\service.txt');
      Rewrite(f);
      Writeln(f,'Exception: '+E.ClassName+#13+E.Message);
      CloseFile(f);
     end;
  end;

  while not Terminated do
   ServiceThread.ProcessRequests(true);
end;

procedure TMarusTestService.ServiceStart(Sender: TService;
  var Started: Boolean);
begin
  IdTCPServer1.Bindings.Clear;
  IdTCPServer1.Bindings.Add.SetBinding('192.168.1.2', 280);
  IdTCPServer1.Active:=True;
end;

procedure TMarusTestService.ServiceStop(Sender: TService; var Stopped: Boolean);
begin
  IdTCPServer1.Active:=false;
end;

end.

Answer 1

Your service's OnExecute handler is wiping out the TIdTCPServer.Binding collection after the server is already activated. Just get rid of the OnExecute handler completely, let TService handle SCM requests on its own for you. Your OnStart handler is already activating the TCP server, that is good enough (just be sure to set Started := True , and Stopped := True in the OnStop event).

As for your TIdTCPServer events, you should move your 'Connected' log message to the OnConnect event, and get rid of the loop inside the OnExecute event (since the event is already looped by TIdTCPServer for you).

Try something more like this:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs,
  IdBaseComponent, IdComponent, IdCustomTCPServer, IdTCPServer, IdContext,
  SyncObjs;

type
  TMarusTestService = class(TService)
    IdTCPServer1: TIdTCPServer;
    procedure ServiceCreate(Sender: TObject);
    procedure ServiceDestroy(Sender: TObject);
    procedure ServiceStart(Sender: TService; var Started: Boolean);
    procedure ServiceStop(Sender: TService; var Stopped: Boolean);
    procedure IdTCPServer1Connect(AContext: TIdContext);
    procedure IdTCPServer1Disconnect(AContext: TIdContext);
    procedure IdTCPServer1Execute(AContext: TIdContext);
  private
    CS: TCriticalSection;
    procedure Log(const Msg: String);
  public
    function GetServiceController: TServiceController; override;
  end;

var
  MarusTestService: TMarusTestService;

implementation

{$R *.DFM}

procedure ServiceController(CtrlCode: DWord); stdcall;
begin
  MarusTestService.Controller(CtrlCode);
end;

function TMarusTestService.GetServiceController: TServiceController;
begin
  Result := ServiceController;
end;

procedure TMarusTestService.ServiceCreate(Sender: TObject);
begin
  CS := TCriticalSection.Create;
end;

procedure TMarusTestService.ServiceDestroy(Sender: TObject);
begin
  CS.Free;
end;

procedure TMarusTestService.Log(const Msg: String);
const
  LogFileName = 'f:\service.txt';
var
  f: TextFile;
begin
  CS.Enter;
  try
    AssignFile(f, LogFileName);
    if FileExists(LogFileName) then 
      Append(f)
    else
      Rewrite(f);
    try
      WriteLn(f, '[', DateTimeToStr(Now), '] ', Msg);
    finally
      CloseFile(f);
    end;
  finally
    CS.Leave;
  end;
end;

procedure TMarusTestService.IdTCPServer1Connect(AContext: TIdContext);
begin
  Log('Connected');
end;

procedure TMarusTestService.IdTCPServer1Disconnect(AContext: TIdContext);
begin
  Log('Disconnected');
end;

procedure TMarusTestService.IdTCPServer1Execute(AContext: TIdContext);
begin
  AContext.Connection.Socket.ReadLongWord;
  AContext.Connection.Socket.Write($93667B01);
end;

procedure TMarusTestService.ServiceStart(Sender: TService; var Started: Boolean);
begin
  IdTCPServer1.Bindings.Clear;
  IdTCPServer1.Bindings.Add.SetBinding('192.168.1.2', 280, Id_IPv4);

  try
    IdTCPServer1.Active := True;
  except
    on E: Exception do
    begin
      Log('Exception: (' + E.ClassName + ') ' + E.Message);
      Win32ErrCode := 0;
      ErrCode := 1;
      Started := False;
      Exit;
    end;
  end;

  Log('Service Started');
  Started := True;
end;

procedure TMarusTestService.ServiceStop(Sender: TService; var Stopped: Boolean);
begin
  IdTCPServer1.Active := False;
  Log('Service Stopped');
  Stopped := True;
end;

end.