Chatserver mit TServerSocket

[Capa]

Ich eröffne diesen Thread weniger als fragethread sondern eher als hilfethread für
die vielen Hilfesuchenden zum thema "TServersocket/TClientsocket und Netzwerk/Internet Chat"

Hab mich mal eine weile hingesetzt und mir so ein wenig überlegt wie man am besten nen Server
mit mehreren Extras baut. Das ganze hat nicht lange gedauert und der erste ansatz war fertig.
Zuerst einmal hab ich eine unit geschrieben die ich für die Userliste benutze.
Unteranderem hab ich hier mehrere Funktionen eingebaut womit ich zum bsp eine Nicklist
erstellen und aktuell halten kann. Ändern des Nicknamens, Senden von Text an alle oder auch nur
an bestimmte Personen.
Mag sein das es für einige nicht die beste art ist einige sachen zu lösen aber ich bin auch für vorschläge offen ^^.

Datei: userlist.pas

Delphi-Quellcode:

unit userlist;

interface

uses Windows, Messages, SysUtils, Variants, Classes, ScktComp, StdCtrls, Dialogs;

// *********************************************
// ******** TUserdata **************************
// *********************************************
type
  TUserdata = record
    Username: string[12];                // Name des Users
    Userip: string;                      // Ip des Clienten
    Userport: string;                    // Port des Clienten von dem aus er Connected ist
    Userid: string;                      // id bestehend aus ip:port zur genauen identifizierung des Users (Cloneschutz)
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;
// *********************************************
// ******** TUserlist **************************
// *********************************************
type
  TUserlist = class
    Userdaten: array[1..250] of TUserdata;                                      
    Count: integer;
    procedure Adduser(name,ip, port: string; mylist:TListBox); overload;
    procedure Adduser(name,ip, port: string); overload;
    procedure Deleteuser(ip, port: string; mylist:TListBox); overload;
    procedure Deleteuser(ip, port: string); overload;
    procedure Sendtextto(code, ip, port, text: string; Socket: TServerSocket);
    procedure Broadcast(text: string; Socket: TServerSocket);
    procedure Clear;
    procedure Sendfile(ip, port: string; filename: pchar; Socket: TServerSocket);
    function GetUsernamebyid(id: string): string;                               
    function GetUserIdbyname(name: string): string;                             
    function GetUseripbyid(id: string): string;
    function GetUserportbyid(id: string): string;
    function ChangeNickName(oldname,newname: string; Socket: TServerSocket; mylist: TListbox): string;
    function GetFileSize(const FileName: String): Int64;
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

implementation

// *********************************************
// ******** TUserlist Proceduren ***************
// *********************************************
procedure TUserlist.Clear;
  var a: integer;
begin
  for a := 1 to length(Userdaten) - 1 do
  begin
    Userdaten[a].Username := '';
    Userdaten[a].Userip := '';
    Userdaten[a].Userport := '';
    Userdaten[a].Userid := '';
    Count := 0;
  end;
end;

function TUserlist.ChangeNickName(oldname,newname: string; Socket: TServerSocket; mylist: TListbox): string;
  var a,b,c: integer;
begin
  b := 0;
  for a := 1 to length(Userdaten) - 1 do
  begin
    if (Userdaten[a].Username = oldname) then
      c := a;
    if (Userdaten[a].Username = newname) then
    begin
      Result := '*** Name bereits vergeben! ***';
      b := 1;
      Exit;
    end;
  end;
  if (b = 0) then
  begin
    for a := 0 to mylist.Count - 1 do
    begin
      if (mylist.Items[a] = oldname) then
        mylist.Items[a] := newname;
    end;
    Userdaten[c].Username := newname;
    Broadcast('Namechange: '+oldname+' => '+newname,Socket);
    Result := '';
  end;
end;

function TUserlist.GetFileSize(const FileName: String): Int64;
var  srec: TSearchRec;
begin
  Result := -1;
  if FindFirst(FileName, faAnyFile, srec) = 0 then
  begin
    try
      result := srec.Size;
    finally
      FindClose(srec);
    end;
  end;
end;

procedure TUserlist.Adduser(name,ip, port: string; mylist:TListBox);
  var a: integer;
begin
  for a := 1 to length(Userdaten) - 1 do
  begin
    if (Userdaten[a].Userip = '') then
    begin
      Userdaten[a].Username := name;
      Userdaten[a].Userip := ip;
      Userdaten[a].Userport := port;
      Userdaten[a].Userid := ip+':'+port;
      mylist.Items.Add(name);
      Count := Count+1;
      exit;
    end;
  end;
end;

procedure TUserlist.AddUser(name,ip,port: string);
  var a: integer;
begin
  for a := 1 to length(Userdaten) - 1 do
  begin
    if (Userdaten[a].Userip = '') then
    begin
      Userdaten[a].Username := name;
      Userdaten[a].Userip := ip;
      Userdaten[a].Userport := port;
      Userdaten[a].Userid := ip+':'+port;
      Count := Count+1;
      exit;
    end;
  end;
end;

procedure TUserlist.Deleteuser(ip, port: string; mylist:TListBox);
  var a: integer;
     xu: string;
begin
  try
    xu := GetUsernamebyid(ip+':'+port);
    for a := mylist.Count - 1 downto 0 do
    begin
      if (mylist.Items[a] = xu) then
      begin
        mylist.Items.Move(a,mylist.Count-1);
        mylist.Items.delete(mylist.count-1);
        mylist.Refresh;
      end;
    end;
  finally
    for a := 1 to length(Userdaten) - 1 do
    begin
      if (Userdaten[a].Userid = ip+':'+port) then
      begin
        Userdaten[a].Username := '';
        Userdaten[a].Userip := '';
        Userdaten[a].Userport := '';
        Userdaten[a].Userid := '';
        Count := Count-1;
      end;
    end;
  end;
end;

procedure TUserlist.Deleteuser(ip, port: string);
  var a: integer;
begin
  for a := 1 to length(Userdaten) - 1 do
  begin
    if (Userdaten[a].Userid = ip+':'+port) then
    begin
      Userdaten[a].Username := '';
      Userdaten[a].Userip := '';
      Userdaten[a].Userport := '';
      Userdaten[a].Userid := '';
      Count := Count-1;
      Exit;
    end;
  end;
end;

procedure TUserlist.Sendtextto(code,ip, port, text: string; Socket: TServerSocket);
  var a: integer;
begin
  for a := 0 to socket.Socket.ActiveConnections - 1 do
  begin
    if ((socket.Socket.Connections[a].RemoteAddress = ip) AND (socket.Socket.Connections[a].RemotePort = StrToInt(port))) then
    begin
      socket.Socket.Connections[a].SendText(code+' '+text);
      exit;
    end;
  end;
end;

function TUserlist.GetUsernamebyid(id: string): string;
  var a: integer;
begin
  for a := 1 to length(Userdaten) - 1 do
  begin
    if (Userdaten[a].Userid = id) then
    begin
      result := Userdaten[a].Username;
      exit;
    end;
  end;
end;

function TUserlist.GetUseripbyid(id: string): string;
  var a: integer;
begin
  for a := 1 to length(Userdaten) - 1 do
  begin
    if (Userdaten[a].Userid = id) then
    begin
      result := Userdaten[a].Userip;
      exit;
    end;
  end;
end;

function TUserlist.GetUserportbyid(id: string): string;
  var a: integer;
begin
  for a := 1 to length(Userdaten) - 1 do
  begin
    if (Userdaten[a].Userid = id) then
    begin
      result := Userdaten[a].Userport;
      exit;
    end;
  end;
end;

function TUserlist.GetUserIdbyname(name: string): string;
  var a: integer;
begin
  for a := 1 to length(Userdaten) - 1 do
  begin
    if (Userdaten[a].Username = name) then
    begin
      result := Userdaten[a].Userid;
      exit;
    end;
  end;
end;

procedure TUserlist.Sendfile(ip, port: string; filename: pchar; Socket: TServerSocket);
  var a: integer;
begin
  for a := 0 to socket.Socket.ActiveConnections - 1 do
  begin
    socket.Socket.Connections[a].SendText('FILE '+filename+' SIZE '+IntToStr(GetFileSize(filename)));
    Socket.Socket.Connections[a].SendStream(TFileStream.Create(filename, fmOpenRead or fmShareDenyWrite));
  end;
end;

procedure TUserlist.Broadcast(text: string; Socket: TServerSocket);
  var a: integer;
begin
  for a := 0 to socket.Socket.ActiveConnections - 1 do
  begin
    socket.Socket.Connections[a].SendText(text);
  end;
end;
// *********************************************
// ******** TUserlist Proceduren ***************
// *********************************************

end.

Hier der Code des eigentlichen Programms:

Datei: unit1.pas

Delphi-Quellcode:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, userlist, ScktComp, StdCtrls, ExtCtrls, IdBaseComponent, IdComponent,
  IdTCPConnection, IdTCPClient, IdHTTP, Menus, ComCtrls, ClipBrd;

// *********************************************
// ******** TForm1 *****************************
// *********************************************
type
  TForm1 = class(TForm)
    Server: TServerSocket;
    HTTP: TIdHTTP;
    ListBox1: TListBox;
    Panel1: TPanel;
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    ListBox2: TListBox;
    Splitter1: TSplitter;
    PopupMenu1: TPopupMenu;
    Kick1: TMenuItem;
    Ban1: TMenuItem;
    N1: TMenuItem;
    MSGTOUser1: TMenuItem;
    FILETOUser1: TMenuItem;
    N2: TMenuItem;
    INFOFROMUser1: TMenuItem;
    Button3: TButton;
    speichern: TSaveDialog;
    StatusBar1: TStatusBar;
    PopupMenu2: TPopupMenu;
    CopyText1: TMenuItem;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ServerClientConnect(Sender: TObject; Socket: TCustomWinSocket);
    procedure ServerClientDisconnect(Sender: TObject; Socket: TCustomWinSocket);
    procedure Edit1KeyPress(Sender: TObject; var Key: Char);
    procedure ServerClientRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure ServerClientError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure Button3Click(Sender: TObject);
    procedure PopupMenu1Popup(Sender: TObject);
    procedure PopupMenu2Popup(Sender: TObject);
    procedure CopyText1Click(Sender: TObject);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;
  Userliste: TUserlist;
  uid: integer;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
    HTTP.Get('http://www.*******/adminip.php?action=reactivate');   // Onlineupdate siehe extra hinweis unten
    ListBox1.Items.Add('*** Online-Update wurde durchgeführt! ***');
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  if (Server.Active) then
  begin
    Server.Close;
    ListBox1.Items.Add('*** Server wurde beendet! ***');
    Button2.Caption := 'Start Server';
    ListBox2.Clear;
    Userliste.Clear;
    uid := 1;
  end else begin
    Server.Open;
    ListBox1.Items.Add('*** Server wurde gestartet! ***');
    Button2.Caption := 'Stop Server';
    ListBox2.Clear;
    Userliste.Clear;
    uid := 1;
  end;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  if (speichern.Execute) then   // Abspeichern des Server-Chat-Log's in eine Datei
    ListBox1.Items.SaveToFile(speichern.FileName);
end;

procedure TForm1.CopyText1Click(Sender: TObject);
begin
  Clipboard.AsText := ListBox1.Items[ListBox1.ItemIndex];  // eine kleine Kopierfunktion um zeilen aus dem Server-Chat-Log rauszukopieren
end;

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
  if (key=#13) then  // wenn "Enter" dann mache folgendes
  begin
    Userliste.Broadcast('Server: '+Edit1.Text,Server);  // das was im Servereditfeld eingegeben wird wird hier an alle user geschickt
    ListBox1.Items.Add('*** Server: '+Edit1.Text+' ***'); // und hier wird es dem server selber ausgegeben
    Edit1.Clear;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Userliste := TUserlist.Create;
  Userliste.Clear;
  uid := 1;
end;

procedure TForm1.PopupMenu1Popup(Sender: TObject);
var x: string;
begin
  if (ListBox2.ItemIndex >= 0) then
  begin
    x := ListBox2.Items[ListBox2.ItemIndex];
    Popupmenu1.Items[0].Visible := True;
    Popupmenu1.Items[1].Visible := True;
    Popupmenu1.Items[3].Visible := True;
    Popupmenu1.Items[4].Visible := True;
    Popupmenu1.Items[6].Visible := True;
    Popupmenu1.Items[0].Caption := 'KICK '+x;
    Popupmenu1.Items[1].Caption := 'BAN '+x;
    Popupmenu1.Items[3].Caption := 'MSG TO '+x;
    Popupmenu1.Items[4].Caption := 'FILE TO '+x;
    Popupmenu1.Items[6].Caption := 'INFO FROM '+x;
  end else begin
    Popupmenu1.Items[0].Visible := False;
    Popupmenu1.Items[1].Visible := False;
    Popupmenu1.Items[3].Visible := False;
    Popupmenu1.Items[4].Visible := False;
    Popupmenu1.Items[6].Visible := False;
  end;
end;

procedure TForm1.PopupMenu2Popup(Sender: TObject);
var x: string;
begin
  if (ListBox1.ItemIndex >= 0) then
  begin
    x := ListBox1.Items[ListBox1.ItemIndex];
    Popupmenu2.Items[0].Visible := True;
  end else begin
    Popupmenu2.Items[0].Visible := False;
  end;
end;

procedure TForm1.ServerClientConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
  Userliste.Adduser('User'+inttostr(uid),Socket.RemoteAddress,IntToStr(Socket.RemotePort),ListBox2);
  Userliste.Broadcast('JOIN User'+inttostr(uid)+' ('+Socket.RemoteHost+':'+IntToStr(Socket.RemotePort)+')',Server);
  ListBox1.Items.Add('*** User Connected: User'+inttostr(uid)+' ('+Socket.RemoteHost+':'+IntToStr(Socket.RemotePort)+') ***');
  inc(uid);
  StatusBar1.Panels[1].Text := IntToStr(Userliste.Count);
end;

procedure TForm1.ServerClientDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
  var xname: string;
begin
  try
    xname := Userliste.GetUsernamebyid(Socket.RemoteAddress+':'+IntToStr(Socket.RemotePort));
    Userliste.Broadcast('QUIT '+xname+' ('+Socket.RemoteHost+':'+IntToStr(Socket.RemotePort)+')',Server);
    ListBox1.Items.Add('*** User Disconnected: '+xname+' ('+Socket.RemoteHost+':'+IntToStr(Socket.RemotePort)+') ***');
  finally
    Userliste.Deleteuser(Socket.RemoteAddress, IntToStr(Socket.RemotePort),ListBox2);
    StatusBar1.Panels[1].Text := IntToStr(Userliste.Count);
  end;
end;

procedure TForm1.ServerClientError(Sender: TObject; Socket: TCustomWinSocket;
  ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
    ListBox1.Items.Add('*** ERROR: ('+IntToStr(ErrorCode)+') ***');
end;

procedure TForm1.ServerClientRead(Sender: TObject; Socket: TCustomWinSocket);
var sr,xu, meta: string;
begin
  xu := Userliste.GetUsernamebyid(Socket.RemoteAddress+':'+IntTostr(Socket.RemotePort));
  sr := Socket.ReceiveText;
  if ((sr[1] = '/') AND (sr[2] = 's') AND (sr[3] = 'a') AND (sr[4] = 'y')) then             // der say befehl sendet text an alle user
  begin
    Userliste.BroadCast(xu+': '+Copy(sr,6,length(sr)-5),Server);
    ListBox1.Items.Add('*** '+xu+': '+Copy(sr,6,length(sr)-5)+' ***');
  end;
  if ((sr[1] = '/') AND (sr[2] = 'n') AND (sr[3] = 'a') AND (sr[4] = 'm') AND (sr[5] = 'e')) then   // mit /name ändert man den namen
  begin
    meta := Userliste.ChangeNickName(xu,Copy(sr,7,length(sr)-6),Server,ListBox2);
    if (meta <&amp;gt; '') then
      Userliste.Sendtextto('INFO',Socket.RemoteAddress,IntToStr(Socket.RemotePort),meta,Server)
    else
      ListBox1.Items.Add('*** Namensänderung: '+xu+' =&amp;gt; '+Copy(sr,7,length(sr)-6)+' ***');
  end;

end;

end.

Fehlende Funktionen:
- Senden von Dateien
- Senden von Text an bestimmte User
- Abrufen der Userliste vom Client
- die Popupmenucommands (kick, ban, info, sendmsg, sendfile)

*** Bisher hab ich noch nicht alle funktionen eingebaut, aber das sollte bald folgen.


Onlineupdate:
Diese Funktion ermöglicht es ohne Probleme bei wechselnder IP dem Clienten den Server zu finden
Sobald der Server ein Onlineupdate macht wird mit hilfe einer php datei die ip gespeichert.
Der Client hat ebenfalls einen Updatebutton und holt von der phpdatei die ipaddresse, somit
kann der Client ohne austauschen der IP über telefon/voicechat oder anderer chattools auf den Server connecten.

In der Datenbank hab ich eine Tabelle angelegt mit den werten:
- id: int(11)
- ip: varchar(255)

Leider wird der php code durch das Forum verpfuscht von daher hab ich das ganze als zip angehängt.
Der Server liegt immer auf id=1 die anderen sind wenn wer versucht die seite zu öffnen ohne korrekten $action-wert.
Das mit dem Onlineupdate kann aber jeder handhaben wie er will einfach code anpassen, fertig.



Probleme:
Momentan hab ich ein Problem damit wenn mehrere Clients gleichzeitig disconnecten, da ja sobald einer disconnected
an alle eine nachricht geschickt wird. wenn nun user1 kurz vor user2 rausgeht dann bekommt user2 "normalerweise" noch die
nachricht von user1 das er disconnected ist. und da der Client das nicht mehr empfangen kann da er ja zum selben augenblick
raus ist bekomm ich eine Fehlermeldung bzw stürzt sogar das Programm ab. :/ Mehrere Clients wie zum bsp Clone des angehängten
Client-Programms (welches nicht von mir ist habs in nem Tutorial gefunden) was ich ein wenig umgebaut hab und damit meinen
server teste. Brauchte erstmal nur ein kleines Client-Programm zum testen.

Bis auf die "Fehlenden Funktionen" und das "Problem" ist das ganze system funktionsfähig.
Man kann mit mehreren Clients connecten die clienten können schreiben der server kann schreiben und man kann den namen ändern.
und die nachricht wird mit dem namen angezeigt und nicht mit der "IP", "IPort" oder "Client".
Am Anfang bekommt auch jeder user einen namen zugewiesen "User+uid" also "User1" und steigend.

Ich werde den Sourcecode und die dateien auf dem aktuellsten stand halten wenn ich weitere Funktionen fertig habe.