units/indy/IdTCPServer.pas

   1 // 27-nov-2002
   2 unit IdTCPServer;
   3
   4 interface
   5
   6 uses KOL ,KOLClasses{ ,
   7   Classes } , sysutils,
   8   IdComponent{, IdException}, IdSocketHandle, IdTCPConnection, IdThread,
   9     IdThreadMgr, IdThreadMgrDefault,
  10   IdIntercept;
  11
  12 type
  13   TOperation = (opInsert, opRemove);
  14
  15 {  TIdTCPServer = object(TObj)
  16   end;
  17
  18 PIdTCPServer=^TIdTCPServer;
  19 type}
  20
  21   TIdListenerThread = object(TIdThread)
  22   protected
  23     FAcceptWait: Integer;
  24     FBindingList: PList;//TList;
  25     FServer,FAServer: PObj;//TIdTCPServer;
  26   public
  27     procedure Init; virtual;
  28     procedure AfterRun; virtual;// override;
  29      { constructor Create(axServer: TIdTCPServer);  }// reintroduce;
  30     destructor Destroy;
  31      virtual; procedure Run; virtual;// override;
  32
  33     property AcceptWait: integer read FAcceptWait write FAcceptWait;
  34     property Server: {TIdTCPServer}PObj read FServer;
  35   end;
  36 PIdListenerThread=^TIdListenerThread;
  37 //function NewIdListenerThread(axServer: PIdTCPServer):PIdListenerThread;
  38 //type
  39
  40   TIdTCPServerConnection = object(TIdTCPConnection)
  41   protected
  42     function GetServer: PObj;//TIdTCPServer;
  43   public
  44    { published }
  45    procedure Init; virtual;
  46     property Server: {TIdTCPServer}PObj read GetServer;
  47   end;
  48
  49 PIdTCPServerConnection=^TIdTCPServerConnection;
  50 function NewIdTCPServerConnection(AOwner: PObj):PIdTCPServerConnection;
  51  type
  52
  53   TIdPeerThread = object(TIdThread)
  54   protected
  55     FConnection: PIdTCPServerConnection;//TIdTCPServerConnection;
  56
  57     procedure AfterRun; virtual;// override;
  58     procedure BeforeRun; virtual;// override;
  59   public
  60     procedure Run; virtual;//override;
  61     property Connection: PIdTCPServerConnection{TIdTCPServerConnection} read FConnection;
  62   end;
  63 PIdPeerThread=^TIdPeerThread; type
  64
  65   TIdServerThreadEvent = procedure(AThread: PIdPeerThread{TIdPeerThread}) of object;
  66
  67   TIdTCPServer = object(TIdComponent)
  68   protected
  69     FAcceptWait: integer;
  70     FActive, FImplicitThreadMgrCreated: Boolean;
  71     FThreadMgr: PIdThreadMgr;//TIdThreadMgr;
  72     FBindings: PIdSocketHandles;//TIdSocketHandles;
  73     FListenerThread: PIdListenerThread;//TIdListenerThread;
  74     FTerminateWaitTime: Integer;
  75 //    FThreadClass: TIdThreadClass;
  76     FThreads: PThreadList;//TThreadList;
  77     FOnExecute, FOnConnect, FOnDisconnect: TIdServerThreadEvent;
  78
  79     FIntercept: PIdServerIntercept;//TIdServerIntercept;
  80     procedure DoConnect(axThread: PIdPeerThread{TIdPeerThread}); virtual;
  81     procedure DoDisconnect(axThread: PIdPeerThread{TIdPeerThread}); virtual;
  82     function DoExecute(AThread:PIdPeerThread {TIdPeerThread}): boolean; virtual;
  83     function GetDefaultPort: integer;
  84     procedure Notification(AComponent: PObj{TComponent}; Operation: TOperation); virtual;//     override;
  85     procedure SetAcceptWait(AValue: integer);
  86     procedure SetActive(AValue: Boolean); virtual;
  87     procedure SetBindings(const abValue: PIdSocketHandles{TIdSocketHandles});
  88     procedure SetDefaultPort(const AValue: integer);
  89     procedure SetIntercept(const Value: PIdServerIntercept{TIdServerIntercept});
  90     procedure SetThreadMgr(const Value: PIdThreadMgr{TIdThreadMgr});
  91     procedure TerminateAllThreads;
  92   public
  93     procedure Init; virtual;
  94      { constructor Create(AOwner: TComponent); override;
  95      } destructor Destroy;
  96      virtual; procedure Loaded; virtual;//override;
  97     property AcceptWait: integer read FAcceptWait write SetAcceptWait;
  98     property ImplicitThreadMgrCreated: Boolean read FImplicitThreadMgrCreated;
  99 //    property ThreadClass: TIdThreadClass read FThreadClass write FThreadClass;
 100     property Threads: PThreadList{TThreadList} read FThreads;
 101    { published }
 102     property Active: boolean read FActive write SetActive default False;
 103     property Bindings: PIdSocketHandles{TIdSocketHandles }read FBindings write SetBindings;
 104     property DefaultPort: integer read GetDefaultPort write SetDefaultPort;
 105     property Intercept: PIdServerIntercept{TIdServerIntercept} read FIntercept write SetIntercept;
 106     property OnConnect: TIdServerThreadEvent read FOnConnect write FOnConnect;
 107     property OnExecute: TIdServerThreadEvent read FOnExecute write FOnExecute;
 108     property OnDisconnect: TIdServerThreadEvent read FOnDisconnect write
 109       FOnDisconnect;
 110     property TerminateWaitTime: Integer read FTerminateWaitTime write
 111       FTerminateWaitTime
 112     default 5000;
 113     property ThreadMgr: PIdThreadMgr{TIdThreadMgr} read FThreadMgr write SetThreadMgr;
 114   end;
 115
 116   PIdTCPServer=^TIdTCPServer;
 117
 118 function NewIdListenerThread(axServer: PIdTCPServer):PIdListenerThread;
 119 function NewIdTCPServer(AOwner: PControl):PIdTCPServer;
 120 { type  MyStupid27292=DWord;
 121   EIdTCPServerError = object(EIdException);
 122 PdTCPServer=^IdTCPServer; type  MyStupid67165=DWord;
 123   EIdAcceptWaitCannotBeModifiedWhileServerIsActive = object(EIdTCPServerError);
 124 PTCPServer=^dTCPServer; type  MyStupid31869=DWord;
 125   EIdNoExecuteSpecified = object(EIdTCPServerError);
 126 PCPServer=^TCPServer; type  MyStupid16179=DWord;
 127  }
 128 implementation
 129
 130 uses
 131   IdGlobal, IdResourceStrings, IdStack, IdStackConsts;
 132
 133 //constructor TIdTCPServer.Create(AOwner: TComponent);
 134 function NewIdTCPServer(AOwner: PControl):PIdTCPServer;
 135 begin
 136 //  inherited;
 137   New( Result, Create );
 138   Result.Init;
 139 {with Result^ do
 140 begin
 141   FAcceptWait := 1000;
 142   FTerminateWaitTime := 5000;
 143 //  FThreads := TThreadList.Create;
 144 //  FBindings := TIdSocketHandles.Create(Self);
 145 //  FThreadClass := TIdPeerThread;
 146 end;}
 147 end;
 148
 149 destructor TIdTCPServer.Destroy;
 150 begin
 151   Active := False;
 152   TerminateAllThreads;
 153   FreeAndNil(FBindings);
 154   FreeAndNil(FThreads);
 155   inherited;
 156 end;
 157
 158 procedure TIdTCPServer.DoConnect(axThread: PIdPeerThread{TIdPeerThread});
 159 begin
 160   if assigned(OnConnect) then
 161   begin
 162     OnConnect(axThread);
 163   end;
 164 end;
 165
 166 procedure TIdTCPServer.DoDisconnect(axThread: PIdPeerThread{TIdPeerThread});
 167 begin
 168   if assigned(OnDisconnect) then
 169   begin
 170     OnDisconnect(axThread);
 171   end;
 172 end;
 173
 174 function TIdTCPServer.DoExecute(AThread: PIdPeerThread{TIdPeerThread}): boolean;
 175 begin
 176   result := assigned(OnExecute);
 177   if result then
 178   begin
 179     OnExecute(AThread);
 180   end;
 181 end;
 182
 183 function TIdTCPServer.GetDefaultPort: integer;
 184 begin
 185   result := FBindings.DefaultPort;
 186 end;
 187
 188 procedure TIdTCPServer.Init;
 189 begin
 190   inherited;
 191 //  with Result^ do
 192 begin
 193   FAcceptWait := 1000;
 194   FTerminateWaitTime := 5000;
 195   FThreads := NewThreadList();//TThreadList.Create;
 196   FBindings := NewIdSocketHandles(@Self);//TIdSocketHandles.Create(Self);
 197 //  FThreadClass := TIdPeerThread;
 198 end;
 199 end;
 200
 201 procedure TIdTCPServer.Loaded;
 202 begin
 203   inherited;
 204   if Active then
 205   begin
 206     FActive := False;
 207     Active := True;
 208   end;
 209 end;
 210
 211 procedure TIdTCPServer.Notification(AComponent: PObj{TComponent}; Operation:
 212   TOperation);
 213 begin
 214   inherited;
 215   if (Operation = opRemove) then
 216   begin
 217     if (AComponent = FThreadMgr) then
 218     begin
 219       FThreadMgr := nil;
 220     end
 221     else
 222       if (AComponent = FIntercept) then
 223     begin
 224       FIntercept := nil;
 225     end;
 226   end;
 227 end;
 228
 229 procedure TIdTCPServer.SetAcceptWait(AValue: integer);
 230 begin
 231   if Active then
 232   begin
 233 //    raise
 234 //      EIdAcceptWaitCannotBeModifiedWhileServerIsActive.Create(RSAcceptWaitCannotBeModifiedWhileServerIsActive);
 235   end;
 236   FAcceptWait := AValue;
 237 end;
 238
 239 procedure TIdTCPServer.SetActive(AValue: Boolean);
 240 var
 241   i: Integer;
 242 begin
 243 {  if (not (csDesigning in ComponentState)) and (FActive <> AValue)
 244     and (not (csLoading in ComponentState)) then}
 245   begin
 246     if AValue then
 247     begin
 248       if Bindings.Count = 0 then
 249       begin
 250         Bindings.Add;
 251       end;
 252
 253       for i := 0 to Bindings.Count - 1 do
 254       begin
 255         with Bindings.Items[i]^ do
 256         begin
 257           AllocateSocket;
 258           SetSockOpt(Id_SOL_SOCKET, Id_SO_REUSEADDR, PChar(@Id_SO_True),
 259             SizeOf(Id_SO_True));
 260           Bind;
 261           Listen;
 262         end;
 263       end;
 264
 265       FImplicitThreadMgrCreated := not assigned(ThreadMgr);
 266       if ImplicitThreadMgrCreated then
 267       begin
 268         ThreadMgr := NewIdThreadMgrDefault(@Self);//TIdThreadMgrDefault.Create(Self);
 269       end;
 270 //      ThreadMgr.ThreadClass := ThreadClass;
 271       FListenerThread := NewIdListenerThread(@Self);//TIdListenerThread.Create(Self);
 272       FListenerThread.AcceptWait := AcceptWait;
 273       FListenerThread.Start;
 274     end
 275     else
 276     begin
 277       FListenerThread.Stop;
 278       for i := 0 to Bindings.Count - 1 do
 279       begin
 280         Bindings.Items[i].CloseSocket(False);
 281       end;
 282       TerminateAllThreads;
 283       if ImplicitThreadMgrCreated then
 284       begin
 285         FreeAndNil(FThreadMgr);
 286       end;
 287       FImplicitThreadMgrCreated := false;
 288
 289       FListenerThread.WaitFor;
 290       FListenerThread.Free;
 291     end;
 292   end;
 293   FActive := AValue;
 294 end;
 295
 296 procedure TIdTCPServer.SetBindings(const abValue: PIdSocketHandles{TIdSocketHandles});
 297 begin
 298   FBindings.Assign(abValue);
 299 end;
 300
 301 procedure TIdTCPServer.SetDefaultPort(const AValue: integer);
 302 begin
 303   FBindings.DefaultPort := AValue;
 304 end;
 305
 306 procedure TIdTCPServer.SetIntercept(const Value: PIdServerIntercept{TIdServerIntercept});
 307 begin
 308   FIntercept := Value;
 309   if assigned(FIntercept) then
 310   begin
 311 //    FIntercept.FreeNotification(@Self);
 312   end;
 313 end;
 314
 315 procedure TIdTCPServer.SetThreadMgr(const Value: PIdThreadMgr{TIdThreadMgr});
 316 begin
 317   FThreadMgr := Value;
 318   if Value <> nil then
 319   begin
 320 //    Value.FreeNotification(@self);
 321   end;
 322 end;
 323
 324 procedure TIdTCPServer.TerminateAllThreads;
 325 var
 326   i: integer;
 327   list: PList;//TList;
 328   Thread: PIdPeerThread;//TIdPeerThread;
 329 const
 330   LSleepTime: integer = 250;
 331 begin
 332   list := Threads.LockList;
 333   try
 334     for i := 0 to list.Count - 1 do
 335     begin
 336       Thread := PIdPeerThread{TIdPeerThread}(list.items[i]);
 337       Thread.Connection.DisconnectSocket;
 338     end;
 339   finally{ Threads.UnlockList};
 340   end;
 341   for i := 1 to (TerminateWaitTime div LSleepTime) do
 342   begin
 343     Sleep(LSleepTime);
 344     list := Threads.LockList;
 345     try
 346       if list.Count = 0 then
 347       begin
 348         break;
 349       end;
 350     finally {Threads.UnlockList};
 351     end;
 352   end;
 353 end;
 354
 355 procedure TIdListenerThread.AfterRun;
 356 var
 357   i: Integer;
 358 begin
 359   inherited;
 360   for i := PIdTCPServer(Server).Bindings.Count - 1 downto 0 do
 361   begin
 362     PIdTCPServer(Server).Bindings.Items[i].CloseSocket;
 363   end;
 364 end;
 365
 366 //constructor TIdListenerThread.Create(axServer: TIdTCPServer);
 367 function NewIdListenerThread(axServer: PIdTCPServer):PIdListenerThread;
 368 begin
 369 //  inherited Create;
 370 New( Result, Create );
 371 Result.FAServer:=axServer;
 372 Result.Init;
 373 {with Result^ do
 374 begin
 375   FBindingList := NewList();//TList.Create;
 376   FServer := axServer;
 377 end;   }
 378 end;
 379
 380 destructor TIdListenerThread.Destroy;
 381 begin
 382   FBindinglist.Free;
 383   inherited;
 384 end;
 385
 386 procedure TIdListenerThread.Init;
 387 begin
 388   inherited;
 389 //with Result^ do
 390 //begin
 391   FBindingList := NewList();//TList.Create;
 392   FServer := FAServer;//axServer;
 393 //end;
 394 end;
 395
 396 procedure TIdListenerThread.Run;
 397 var
 398   Peer: PIdTCPServerConnection;//TIdTCPServerConnection;
 399   Thread: PIdPeerThread;//TIdPeerThread;
 400   i: Integer;
 401 begin
 402   FBindingList.Clear;
 403   for i := 0 to PIdTCPServer(Server).Bindings.Count - 1 do
 404   begin
 405     FBindingList.Add({TObject}PObj(PIdTCPServer(Server).Bindings.Items[i].Handle));
 406   end;
 407   if GStack.WSSelect(FBindingList, nil, nil, AcceptWait) > 0 then
 408   begin
 409     if not Terminated then
 410     begin
 411       for i := 0 to FBindingList.Count - 1 do
 412       begin
 413         Peer := NewIdTCPServerConnection(@Self);//TIdTCPServerConnection.Create(Server);
 414         with Peer^ do
 415         begin
 416           Binding.Accept(TIdStackSocketHandle(FBindingList.Items[i]));
 417           if Assigned(PIdTCPServer(Server).Intercept) then
 418           begin
 419             try
 420               Peer.Intercept := PIdTCPServer(Server).Intercept.Accept(Binding);
 421               Peer.InterceptEnabled := True;
 422             except
 423               FreeAndNil(Peer);
 424             end;
 425           end;
 426         end;
 427         if Peer <> nil then
 428         begin
 429           Thread :=PIdPeerThread(PIdTCPServer(Server).ThreadMgr.GetThread);// TIdPeerThread(Server.ThreadMgr.GetThread);
 430           Thread.FConnection := Peer;
 431           PIdTCPServer(Server).Threads.Add(Thread);
 432           Thread.Start;
 433         end;
 434       end;
 435     end;
 436   end;
 437 end;
 438
 439 function TIdTCPServerConnection.GetServer: PObj;//TIdTCPServer;
 440 begin
 441   result := PIdTCPServer(FOwner);// as TIdTCPServer;
 442 end;
 443
 444 procedure TIdPeerThread.AfterRun;
 445 begin
 446   with PIdTCPServer(Connection.Server)^ do
 447   begin
 448     DoDisconnect(@Self);
 449     ThreadMgr.ReleaseThread(@Self);
 450     Threads.Remove(@Self);
 451   end;
 452   FreeAndNil(FConnection);
 453 end;
 454
 455 procedure TIdPeerThread.BeforeRun;
 456 begin
 457   PIdTCPServer(Connection.Server).DoConnect(@Self);
 458 end;
 459
 460 procedure TIdPeerThread.Run;
 461 begin
 462  // try
 463     if not PIdTCPServer(Connection.Server).DoExecute(@Self) then
 464     begin
 465 //      raise EIdNoExecuteSpecified.Create(RSNoExecuteSpecified);
 466     end;
 467   {except
 468     on E: EIdSocketError do
 469     begin
 470       case E.LastError of
 471         Id_WSAECONNABORTED,
 472           Id_WSAECONNRESET:
 473           Connection.Disconnect;
 474       end;
 475     end;
 476     on EIdClosedSocket do ;
 477   else
 478     raise;
 479   end;  }
 480   if not Connection.Connected then
 481   begin
 482     Stop;
 483   end;
 484 end;
 485
 486 function NewIdTCPServerConnection(AOwner: PObj):PIdTCPServerConnection;
 487 begin
 488   New( Result, Create );
 489   Result.Init;
 490 end;
 491
 492 procedure TIdTCPServerConnection.Init;
 493 begin
 494   inherited;
 495 end;
 496
 497 end.