Synapse multithread server question
lazarus / 38-Networking and Web Programming

----------------------------------------------------------------------
xinyiman · 2014-01-03 13:47

Hello, I found this code here, which allows you to create a
multithreaded server with synapse. And it's really interesting, I've
modified it slightly to be able to exit the loop when it receives the
string 'ESC'. Only logging onto telnet (ubuntu 13:04) what I write to
the server I read it, that the server writes to the telnet client do
not read it, and also if I send 'ESC' not out of the loop. Who tells
me why?!

Code: [Select]program project1;

{$mode objfpc}

uses
 {$IFDEF UNIX}
cthreads,
{$ENDIF}
 Classes, Sysutils,  syncobjs, blcksock, synsock;

type

TThreadManager = class;

{ TManagedThread }

TManagedThread = class(TThread)
public
  constructor Create(waiting : Boolean);
  function    isDone()     : Boolean;
  function    isErroneus() : Boolean;

protected
  done_,
  erroneous_ : Boolean;
end;

 { TTCPThread }

TTCPThread = class(TManagedThread)
   private
    fSock: TTCPBlockSocket;
    fIP: string;
    FPort: integer;
    FNumber: integer;
    procedure SetSocket(aSock: TSocket);
   protected
    procedure Execute; override;
   public
    constructor Create();
    destructor Destroy; override;
    procedure ProcessingData(procSock: TSocket;Data: string);
    Property Number: integer read Fnumber Write FNumber;
end;

{ TListenerThread }

TListenerThread = class(TThread)
 private
   ListenerSocket: TTCPBlockSocket;
   FThreadManager: TThreadManager;
 protected
   procedure Execute; override;
 public
   constructor Create;
   destructor Destroy; override;
end;

{ TThreadManager }

TThreadManager = class(TObject)
       private
        FItemList: TThreadList;
        FAbort: Boolean;
        FThreadList: TList;
        FMaxThreadCount: Integer;
        procedure SetMaxThreadCount(Count: Integer);
       public
        constructor Create(MaxThreads: integer);
        destructor Destroy; override;
        procedure AddItem(Item: TTCPThread);
        function GetSuspendThread(aSock: TSocket): TTCPThread;
               procedure clearFinishedThreads;
        function GetActiveThreadCount: Integer;
        property MaxThreadCount: Integer read FMaxThreadCount write
SetMaxThreadCount;
       end;

{ TThreadManager }

procedure TThreadManager.SetMaxThreadCount(Count: Integer);
begin
 FMaxThreadCount := Count;
end;

constructor TThreadManager.Create(MaxThreads: integer);
begin
 inherited Create;
       FItemList := TThreadList.Create;
       FThreadList := TList.Create;
       FMaxThreadCount := MaxThreads;
end;

destructor TThreadManager.Destroy;
var
       i: Integer;
begin
   FThreadList.Pack;
       for i := FThreadList.Count - 1 downto 0 do begin
        TTCPThread(FThreadList[i]).Free;
       end;
   FThreadList.Capacity := FThreadList.Count;
       FThreadList.Free;
   FItemList.Clear;
       FItemList.Free;
       inherited;
end;

procedure TThreadManager.AddItem(Item: TTCPThread);
begin
 FItemList.Add(Pointer(Item));
end;

function TThreadManager.GetSuspendThread(aSock: TSocket): TTCPThread;
var
       i: Integer;
       TCPThread: TTCPThread;
begin
       Result := nil;
       if GetActiveThreadCount >= FMaxThreadCount then Exit;
       for i := 0 to FThreadList.Count - 1 do begin
        if TTCPThread(FThreadList[i]).Suspended then
                begin
                TCPThread := TTCPThread(FThreadList[i]);
                       TCPThread.SetSocket(aSock);
                       TCPThread.Resume;
                Break;
        end;
       end;
       if (Result = nil) and (FMaxThreadCount > FThreadList.Count)
then begin
        TCPThread := TTCPThread.Create;
        TCPThread.FreeOnTerminate := False;
               TCPThread.SetSocket(aSock);
        TCPThread.Number := FThreadList.Count;
        FThreadList.Add(TCPThread);
        Result := TCPThread;
       end;
end;

procedure TThreadManager.clearFinishedThreads;
var
       i: Integer;
begin
       for i := 0 to FThreadList.Count - 1 do
        begin
          if (TTCPThread(FThreadList[i]) <> nil) and
TTCPThread(FThreadList[i]).isDone() then
              begin
                TTCPThread(FThreadList[i]).WaitFor;
                TTCPThread(FThreadList[i]).Free;
        end;

end;
end;

function TThreadManager.GetActiveThreadCount: Integer;
var
       i: Integer;
begin
       Result := 0;
       for i := 0 to FThreadList.Count - 1 do begin
        if not TTCPThread(FThreadList[i]).Suspended then
                Inc(Result);
       end;
end;

{ TManagedThread }

constructor TManagedThread.Create(waiting : Boolean);
begin
inherited Create(waiting);
done_ := false;
erroneous_ := false;
end;

function  TManagedThread.isDone()     : Boolean;
begin
Result := done_;
end;


function  TManagedThread.isErroneus() : Boolean;
begin
Result := erroneous_;
end;

{ TListenerThread }

procedure TListenerThread.Execute;
var
ClientSock: TSocket;
ClientThread: TTCPThread;
buffer: string;
begin
  with ListenerSocket do
    begin
      CreateSocket;
       if LastError = 0 then
          WriteLn('Socket inizializzati con successo!')
         else
          WriteLn('Errore durante l''inizializzazione del socket: ' +
GetErrorDescEx);
  Family := SF_IP4;
  setLinger(true,10000);
  bind('0.0.0.0', '5058');
   if LastError = 0 then
     WriteLn('Bind on 5058')
    else
     WriteLn('Bind error: '+GetErrorDescEx);
     listen;
     repeat
       if CanRead(100) then
        begin
          ClientSock := Accept;
           if LastError = 0
            then
             begin

                 
ClientThread:=FThreadManager.GetSuspendThread(ClientSock);
                  WriteLn('We have '+
IntToStr(FThreadManager.GetActiveThreadCount)+#32+'client threads!');

                      buffer := ListenerSocket.RecvPacket(2000);
                      write(buffer);
             end
            else
             WriteLn('TCP thread creation error: '+GetErrorDescEx);
        end;
       FThreadManager.clearFinishedThreads;
     sleep(10);
     until UpperCase(buffer) = 'ESC';
   end;
end;

constructor TListenerThread.Create;
begin
FreeOnTerminate := True;
ListenerSocket := TTCPBlockSocket.Create;
FThreadManager:=TThreadManager.Create(20000);
if ListenerSocket.LastError = 0
 then
    WriteLn('Listener has been created')
 else
     WriteLn('Listener creation error:
'+ListenerSocket.GetErrorDescEx);
inherited Create(False);
end;

destructor TListenerThread.Destroy;
begin
ListenerSocket.Free;
  if
    ListenerSocket.LastError = 0
      then
          WriteLn('Listener has been deleted')
         else
           WriteLn('Listener deleting error:
'+ListenerSocket.GetErrorDescEx);
 inherited;
end;

{ TTCPThread }

procedure TTCPThread.SetSocket(aSock: TSocket);
begin
  fSock.Socket := aSock;
  fSock.GetSins;
end;

procedure TTCPThread.Execute;
var
 s: ansistring;
begin
 fIp:=fSock.GetRemoteSinIP;
 fPort:=fSock.GetRemoteSinPort;
 WriteLn(format('Connessione accettata da %s:%d',[fIp,fPort]));
 while not isDone  do
  begin
   if fSock.WaitingData > 0 then
    begin
     s:=fSock.RecvPacket(2000);
     if fSock.LastError <> 0 then
      WriteLn(fSock.GetErrorDescEx);
      ProcessingData(fSock.Socket,S);
     end;
   sleep(10);
  end;
end;

constructor TTCPThread.Create();
begin
FreeOnTerminate := True;
fSock := TTCPBlockSocket.Create;
inherited Create(false);
end;

destructor TTCPThread.Destroy;
begin
 WriteLn(format('Disconnessione da %s:%d',[fIp,fPort]));
 fSock.Free;
 inherited;
end;

procedure TTCPThread.ProcessingData(procSock: TSocket; Data: string);
begin
 if data <> '' then
  WriteLn(data+#32+'we get it from '+IntToStr(number)+' thread');
end;
var
  Server: TListenerThread;
begin
  //Application.Title:='My Application';
  writeln('Applicazione avviata');
  Server:=TListenerThread.Create;
  ReadLn;
end.

----------------------------------------------------------------------
User137 · 2014-01-07 02:39

I would think it is a program flow error here:
Code: [Select]        ...
        if CanRead(100) then
        begin
          ClientSock := Accept;
           if LastError = 0
            then
             begin

                 
ClientThread:=FThreadManager.GetSuspendThread(ClientSock);
                  WriteLn('We have '+
IntToStr(FThreadManager.GetActiveThreadCount)+#32+'client threads!');

                      buffer := ListenerSocket.RecvPacket(2000);
                      write(buffer);
...Accept function will wait as long time as necessary for new client
to join. First time you come there it will set your first joining
Telnet client to ClientSock. Then you create a ClientThread, which is
supposed to deal with all communications with the client within its
own Execute procedure. Instead you remain waiting for 1 packet in
listener thread for 2000 milliseconds (2 seconds), and start loop
over. Coming back to Accept function again, and this thread stops
waiting for second client to join in.

In short, if you type the 'ESC' in less than 2 seconds, it might work?
But it should be thought through regardless.

Also for what i checked, there is also a function RecvString, in
addition to RecvPacket. Both return AnsiString though, so it might not
make a difference. I just care about types.