Delphi Pages Forums  

Go Back   Delphi Pages Forums > Delphi Forum > General

Lost Password?

Reply
 
Thread Tools Display Modes
  #1  
Old 03-24-2005, 04:20 AM
tj_lawrence tj_lawrence is offline
Senior Member
 
Join Date: Apr 2002
Posts: 137
Default need help with chat

hey i got this chat+ server

two different apps

but only the server app can send messages to the server and the chatters can not

can anyone see how to do it

here's the codes for both applications

1. chat
2. server

unit Unit_Client_Main;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls, ScktComp, ExtCtrls, IdAntiFreezeBase, IdAntiFreeze,
IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdIOHandler,
IdIOHandlerSocket, IdSocks, IdIntercept, IdLogBase, IdLogEvent, IdException,
XPMan, Menus;

resourcestring
StatusDateTimeFormat = 'mm/dd/yyyy" - "hh:nn:ss:zzz AM/PM';

type

TForm_Client_Main = class(TForm)
pcClientTab: TPageControl;
tsClient: TTabSheet;
gbBasicClientSettings: TGroupBox;
gbConnectionAddressOrHost: TGroupBox;
edConnectionAddress: TEdit;
gbConnectionport: TGroupBox;
edConnectionPort: TEdit;
tsTextChat: TTabSheet;
memSend: TMemo;
memChatText: TMemo;
lbUsers: TListBox;
ChatClientSocket: TIdTCPClient;
IdAntiFreeze1: TIdAntiFreeze;
memLog: TMemo;
IdLogEvent1: TIdLogEvent;
pStatusPanel: TPanel;
Ind01: TShape;
Ind02: TShape;
Ind03: TShape;
Ind04: TShape;
Ind05: TShape;
IndicatorResetTimer: TTimer;
btnConnectDisconnect: TButton;
pnlRefreshList: TPanel;
GroupBox1: TGroupBox;
edScreenName: TEdit;
Label6: TLabel;
cbAutoLogin: TCheckBox;
lblInfo: TLabel;
cbSpaceMessages: TCheckBox;
cbRecordSentMessages: TCheckBox;
cbWordWrap: TCheckBox;
XPManifest1: TXPManifest;
Button1: TButton;
PopupMenu1: TPopupMenu;
procedure btnConnectDisconnectClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormDestroy(Sender: TObject);
procedure ChatClientSocketConnected(Sender: TObject);
procedure ChatClientSocketDisconnected(Sender: TObject);
procedure memSendKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure IdLogEvent1Connect(ASender: TIdConnectionIntercept);
procedure IdLogEvent1Disconnect(ASender: TIdConnectionIntercept);
procedure IdLogEvent1Receive(ASender: TIdConnectionIntercept; AStream: TStream);
procedure IdLogEvent1Received(ASender: TComponent; const AText, AData: String);
procedure IdLogEvent1Send(ASender: TIdConnectionIntercept; AStream: TStream);
procedure IdLogEvent1Sent(ASender: TComponent; const AText, AData: String);
procedure IdLogEvent1Status(ASender: TComponent; const AText: String);
procedure memChatTextKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure ChatClientSocketStatus(ASender: TObject; const AStatus: TIdStatus; const AStatusText: String);
procedure IndicatorResetTimerTimer(Sender: TObject);
procedure pnlRefreshListClick(Sender: TObject);
procedure cbWordWrapClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

TStatusThread = class(TThread)
private
FClientConnected: Boolean;
FClientThreadTerminated: Boolean;
FClientThreadSuspended: Boolean;
procedure UpdateClientThreadStatus;
protected
procedure Execute; override;
end;

TClientThread = class(TThread)
private
Msg: string;
procedure ReceivedLine;
procedure MessageToLog;
protected
procedure Execute; override;
end;

TScrollingTextInfoThread = class(TThread)
private
FReset: Boolean;
FAlert: Boolean;
FAlertMsg: string;
FAlertCount: Integer;
procedure SetCaption;
procedure UpdateInfoAndScroll;
protected
procedure Execute; override;
published
property Reset: Boolean read FReset write FReset;
property Alert: Boolean read FAlert write FAlert;
property AlertMsg: string read FAlertMsg write FAlertMsg;
end;


var
Form_Client_Main: TForm_Client_Main;
ClientThread: TClientThread;
StatusThread: TStatusThread;
ScrollingTextInfoThread: TScrollingTextInfoThread;

implementation

{$R *.DFM}

procedure TForm_Client_Main.FormCreate(Sender: TObject);
begin
ClientThread := TClientThread.Create(True);
StatusThread := TStatusThread.Create(False);
StatusThread.FreeOnTerminate := True;
ScrollingTextInfoThread := TScrollingTextInfoThread.Create(False);
ScrollingTextInfoThread.FreeOnTerminate := True;

pStatusPanel.Color := clBtnFace;
end;

procedure TForm_Client_Main.FormClose(Sender: TObject; var Action: TCloseAction);
begin
ScrollingTextInfoThread.Terminate;
repeat
Application.ProcessMessages;
until ScrollingTextInfoThread.Terminated;

StatusThread.Terminate;
repeat
Application.ProcessMessages;
until StatusThread.Terminated;

ClientThread.FreeOnTerminate := True;
ClientThread.Terminate;
repeat
Application.ProcessMessages;
until ClientThread.Terminated;

if ChatClientSocket.Connected then
begin
ChatClientSocket.Disconnect;
end;
repeat
Application.ProcessMessages;
until not ChatClientSocket.Connected;

Action := caFree;
end;

procedure TForm_Client_Main.FormDestroy(Sender: TObject);
begin
//
end;

procedure TForm_Client_Main.btnConnectDisconnectClick(Sender : TObject);
begin
try
pcClientTab.SelectNextPage(false);
ScrollingTextInfoThread.Suspend;
ScrollingTextInfoThread.Reset := True;
if not ChatClientSocket.Connected then
begin
if (edConnectionAddress.Text <> '') and
(edConnectionPort.Text <> '') then
begin
ChatClientSocket.Host := edConnectionAddress.Text;
ChatClientSocket.Port := StrToInt(edConnectionPort.Text);

ChatClientSocket.Connect;

memChatText.Text := '';
memSend.Text := '';
pcClientTab.ActivePage := tsTextChat;
end
else
begin
ShowMessage('You must enter in a user name and server name or address to connect.');
end;
end
else
begin
ChatClientSocket.WriteLn('-' + edScreenName.Text);
ChatClientSocket.Disconnect;
end;
finally
ScrollingTextInfoThread.Resume;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////

procedure TForm_Client_Main.ChatClientSocketConnected(Sender : TObject);
begin
//Activate the receiving thread
if ClientThread.Suspended then
begin
ClientThread.Resume;
end;

if cbAutoLogin.Checked then
begin
memLog.Lines.Add('Login (' + FormatDateTime(StatusDateTimeFormat, Now) + ')');
ChatClientSocket.WriteLn(edScreenName.Text);
memLog.Lines.Add('Authenticated (' + FormatDateTime(StatusDateTimeFormat, Now) + ')');
ChatClientSocket.WriteLn('@' + edScreenName.Text);
end;
end;

procedure TForm_Client_Main.ChatClientSocketDisconnected(Sen der: TObject);
begin

//This event is called when disconnecting from the client.
//If you get disconnected from the server this event is not called until you try to communicate
//with the server. Because this event doesn't get fired the receiving thread doesn't get suspended
//which raises an EIdConnClosedGracefully exception within the thread. After the exception is raised
//and handled this event finally gets fired and everything works as expected.

ScrollingTextInfoThread.Suspend;
ScrollingTextInfoThread.Reset := True;
ScrollingTextInfoThread.Resume;

//Suspended the receiving thread
if not ClientThread.Suspended then
begin
ClientThread.Suspend;
end;
memLog.Lines.Add('Logout (' + FormatDateTime(StatusDateTimeFormat, Now) + ')');
end;

procedure TForm_Client_Main.ChatClientSocketStatus(ASender: TObject; const AStatus: TIdStatus; const AStatusText: String);
begin
memLog.Lines.Add('Socket Status (' + FormatDateTime(StatusDateTimeFormat, Now) + ') ' + AStatusText);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////

procedure TForm_Client_Main.IdLogEvent1Connect(ASender: TIdConnectionIntercept);
begin
memLog.Lines.Add('Log Event (' + FormatDateTime(StatusDateTimeFormat, Now) + ') Connect');
end;

procedure TForm_Client_Main.IdLogEvent1Disconnect(ASender: TIdConnectionIntercept);
begin
memLog.Lines.Add('Log Event (' + FormatDateTime(StatusDateTimeFormat, Now) + ') Disconnect');
end;

procedure TForm_Client_Main.IdLogEvent1Receive(ASender: TIdConnectionIntercept; AStream: TStream);
begin
Form_Client_Main.Ind05.Brush.Color := clLime;
memLog.Lines.Add('Log Event (' + FormatDateTime(StatusDateTimeFormat, Now) + ') Receive');
end;

procedure TForm_Client_Main.IdLogEvent1Received(ASender: TComponent; const AText, AData: String);
begin
Form_Client_Main.Ind05.Brush.Color := clLime;
memLog.Lines.Add('Log Event (' + FormatDateTime(StatusDateTimeFormat, Now) + ') Received');
end;

procedure TForm_Client_Main.IdLogEvent1Send(ASender: TIdConnectionIntercept; AStream: TStream);
begin
Form_Client_Main.Ind04.Brush.Color := clLime;
memLog.Lines.Add('Log Event (' + FormatDateTime(StatusDateTimeFormat, Now) + ') Send');
end;

procedure TForm_Client_Main.IdLogEvent1Sent(ASender: TComponent; const AText, AData: String);
begin
Form_Client_Main.Ind04.Brush.Color := clLime;
memLog.Lines.Add('Log Event (' + FormatDateTime(StatusDateTimeFormat, Now) + ') Sent');
end;

procedure TForm_Client_Main.IdLogEvent1Status(ASender: TComponent; const AText: String);
begin
// I commented this out since the status didn't appear to be firing in the right display order
// when disconnecting from the server.
// memLog.Lines.Add('Log Event Status (' + FormatDateTime(StatusDateTimeFormat, Now) + ') ' + AText);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////

{ TClientThread }

procedure TClientThread.Execute;
begin
while not Terminated do
begin
try
if Form_Client_Main.ChatClientSocket.Connected then
begin
Msg := Form_Client_Main.ChatClientSocket.ReadLn;
Synchronize(ReceivedLine);
end;
except
on E: EIdConnClosedGracefully do
begin
Msg := 'Client Thread Exception: [' + E.ClassName + ']: ' + E.Message;
Synchronize(MessageToLog);
//Do nothing. Eat the exception so the thread does not terminate because I want to use it later.
//Also, eating the exception will allow the disconnect event to fire and the connected property to update.
end;
on E: EIdSocketError do
begin
Msg := 'Client Thread Exception: [' + E.ClassName + ']: ' + E.Message;
Synchronize(MessageToLog);
//Do nothing. Eat the exception so the thread does not terminate because I want to use it later.
//Also, eating the exception will allow the disconnect event to fire and the connected property to update.
Suspend;
end;
on E: Exception do
begin
//Something must have really gone wrong if we got to this point. Close and restart the client.
Msg := 'Client Thread Exception: [' + E.ClassName + ']: ' + E.Message;
Synchronize(MessageToLog);
Terminate;
end;
end;
end;
end;

procedure TClientThread.MessageToLog;
begin
Form_Client_Main.memLog.Lines.Add(Msg);
end;

procedure TClientThread.ReceivedLine;
var
Cmd: string;
I: Integer;
begin
Cmd := Copy(Msg,1,1);
with Form_Client_Main do
begin
if Cmd = '@' then
begin
I := lbUsers.Items.IndexOf(Copy(Msg,2,Length(Msg)-1));
if I <= -1 then
begin
I := lbUsers.Items.IndexOf('-----');
if I <= -1 then
begin
lbUsers.Items.Add(Copy(Msg,2,Length(Msg)-1));
end
else
begin
lbUsers.Items[I] := Copy(Msg,2,Length(Msg)-1);
end;
end;
end
else if (Cmd = '-') and (Copy(Msg,1,2) <> '--') then
begin
I := lbUsers.Items.IndexOf(Copy(Msg,2,Length(Msg)-1));
if I > -1 then
begin
lbUsers.Items[I] := '-----';
end;
end
else if Cmd = '~' then
begin
lbUsers.Items.CommaText := Copy(Msg,2,Length(Msg)-1);
lbUsers.Items[0] := '@TJLawrence';
end
else if Cmd = '#' then
begin
Form_Client_Main.Close;
end
else if Cmd = '!' then
begin
ScrollingTextInfoThread.Suspend;
ScrollingTextInfoThread.Reset := True;
ScrollingTextInfoThread.Alert := True;
ScrollingTextInfoThread.AlertMsg := 'Admin Alert!.....' + Copy(Msg,2,Length(Msg)-1);
ScrollingTextInfoThread.Resume;
end
else if Cmd = '&' then //Welcome message or part of welcome message
begin
memChatText.Lines.Add(Copy(Msg,2,Length(Msg)-1));
end
else
begin
memChatText.Lines.Add(Msg);
if cbSpaceMessages.Checked then
begin
memChatText.Lines.Add('');
end;
end;

//Debug lines
//memChatText.Lines.Add(Cmd);
//memChatText.Lines.Add(Msg);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////

{ TStatusThread }

procedure TStatusThread.Execute;
begin
while not Terminated do
begin
try
Sleep(250); //This thread doesn't need to be active all the time. Also this line keeps the CPU out of 100%
FClientConnected := Form_Client_Main.ChatClientSocket.Connected;
FClientThreadTerminated := ClientThread.Terminated;
FClientThreadSuspended := ClientThread.Suspended;
Synchronize(UpdateClientThreadStatus);
except
Terminate;
end;
end;
end;

procedure TStatusThread.UpdateClientThreadStatus;
begin
with Form_Client_Main do
begin
if FClientConnected then
begin
Ind01.Brush.Color := clLime;
btnConnectDisconnect.Caption := 'Disconnect';
end
else
begin
Ind01.Brush.Color := clBlack;
btnConnectDisconnect.Caption := 'Connect';
if lbUsers.Count > 0 then
begin
lbUsers.Clear;
end;
end;

if not FClientThreadTerminated then
begin
Ind02.Brush.Color := clLime;
end
else
begin
Ind02.Brush.Color := clRed;
end;

if FClientThreadSuspended then
begin
Ind02.Brush.Color := clGreen;
Ind03.Brush.Color := clBlack;
end
else
begin
Ind03.Brush.Color := clLime;
end;
end; //with
end;

////////////////////////////////////////////////////////////////////////////////////////////////////

{ TScrollingTextInfoThread }

procedure TScrollingTextInfoThread.Execute;
begin
FReset := False;
Synchronize(SetCaption);
while not Terminated do
begin
try
Sleep(15); //16 This thread doesn't need to be active all the time. Also this line keeps the CPU out of 100%
if FReset then
begin
Synchronize(SetCaption);
FReset := False;
end;

if FAlert then
begin
if FAlertCount <= -1 then
begin
FAlert := False;
FReset := True;
end;
end;

Synchronize(UpdateInfoAndScroll);
except
Terminate;
end;
end;
end;

procedure TScrollingTextInfoThread.SetCaption;
begin
with Form_Client_Main do
begin
if ChatClientSocket.Connected then
begin
if not FAlert then
begin
lblInfo.Caption := 'Indy Version: ' + ChatClientSocket.Version + '.....' +
'Client: ' + ChatClientSocket.LocalName + '.....' +
'Client IP: ' + ChatClientSocket.Socket.Binding.IP + '.....' +
'Client Port: ' + IntToStr(ChatClientSocket.Socket.Binding.Port) + '.....' +
'Server IP: ' + ChatClientSocket.Socket.Binding.PeerIP + '.....' +
'Server Port: ' + IntToStr(ChatClientSocket.Socket.Binding.PeerPort) + '.....';
lblInfo.Font.Color := clWindowText;
end
else
begin
FAlertCount := 3;
lblInfo.Caption := FAlertMsg;
lblInfo.Font.Color := clRed;
end;
end
else
begin
lblInfo.Caption := 'Client: ' + ChatClientSocket.LocalName + '.....' +
'Indy Version: ' + ChatClientSocket.Version + '.....';
lblInfo.Font.Color := clWindowText;
end;
lblInfo.Left := tsTextChat.Width;
end;
end;

procedure TScrollingTextInfoThread.UpdateInfoAndScroll;
begin
with Form_Client_Main do
begin
lblInfo.Left := lblInfo.Left - 1;
//lblInfo.Invalidate;
if (lblInfo.Left + memChatText.Width) <= memChatText.Left then
begin
lblInfo.Left := tsTextChat.Width;
Dec(FAlertCount);
end;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////

procedure TForm_Client_Main.memSendKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
var
SendData: string;
Receivers: TStrings;
I: Integer;
begin
if Key = VK_Return then
begin
if ChatClientSocket.Connected then
begin
Receivers := TStringList.Create;

for I := 0 to lbUsers.Items.Count - 1 do
begin
if lbUsers.Selected[I] then Receivers.Add(lbUsers.Items[I]);
end;

if Receivers.Text <> '' then
begin
SendData := '"' + edScreenName.Text + '",' + //Sender
'"' + Receivers.CommaText + '",' + //Receiver(s)
'"' + memSend.Text + '"'; //Message

ChatClientSocket.WriteLn(SendData);
end;

Receivers.Free;
end;
if cbRecordSentMessages.Checked then
begin
memChatText.Lines.Add(edScreenName.Text + '> ' + memSend.Text);
if cbSpaceMessages.Checked then
begin
memChatText.Lines.Add('');
end;
end;
memSend.Text := '';
end;
end;

procedure TForm_Client_Main.memChatTextKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if Key = VK_Delete then
begin
memChatText.Text := '';
end;
end;

procedure TForm_Client_Main.IndicatorResetTimerTimer(Sender: TObject);
begin
Form_Client_Main.Ind04.Brush.Color := clBlack;
Form_Client_Main.Ind05.Brush.Color := clBlack;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////

procedure TForm_Client_Main.pnlRefreshListClick(Sender: TObject);
begin
ChatClientSocket.WriteLn('~');
end;

procedure TForm_Client_Main.cbWordWrapClick(Sender: TObject);
begin
memChatText.WordWrap := cbWordWrap.Checked;
if cbWordWrap.Checked then
begin
memChatText.ScrollBars := ssVertical;
end
else
begin
memChatText.ScrollBars := ssBoth;
end;
end;

end.


now the server

unit Unit_Server_Main;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ScktComp, WinSock, Grids, ComCtrls, StdCtrls, ExtCtrls, IdBaseComponent,
IdComponent, IdTCPServer, IdAntiFreezeBase, IdAntiFreeze, IdThreadMgr,
IdThreadMgrDefault, IdServerIOHandler, IdServerIOHandlerSocket, IdException,
IdIntercept, IdLogBase, IdLogEvent, SyncObjs, XPMan, Menus, Systray;

resourcestring
StatusDateTimeFormat = 'mm/dd/yyyy" - "hh:nn:ss:zzz AM/PM';
WelcomeMessage = 'Welcome to Simple Chat Server 1.1!' + #13#10 +
'&----------------------------------';
ConnectHelpMsg = 'Commands:';

type

TSCSClientInfo = class(TObject)
ScreenName : string;
LocalName : string;
IP : string;
Port : string;
PeerIP : string;
PeerPort : string;
Index : Integer;
Thread : Pointer; //TIdPeerThread;
end;

TForm_Server_Main = class(TForm)
ChatServerSocket: TIdTCPServer;
pcLearnSockets: TPageControl;
tsServer: TTabSheet;
gbServerSettings: TGroupBox;
lblServerPort: TLabel;
edServerPort: TEdit;
gbUserDefinedServerSettings: TGroupBox;
tsAdminMsg: TTabSheet;
TabSheet2: TTabSheet;
sgServerConnections: TStringGrid;
cbBroadcastAsAlert: TCheckBox;
btnStartStopServer: TButton;
IdAntiFreeze1: TIdAntiFreeze;
IdThreadMgrDefault1: TIdThreadMgrDefault;
lblServerAddress: TLabel;
lbIndyVersion: TLabel;
btnDisconnect: TButton;
btnDisconnectAll: TButton;
cbSendCloseToClient: TCheckBox;
cbSpaceMessages: TCheckBox;
cbRecordSentMessages: TCheckBox;
memMessageBox: TMemo;
edSend: TEdit;
memLog: TMemo;
cbShowAdminMsgs: TCheckBox;
XPManifest1: TXPManifest;
Systray1: TSystray;
PopupMenu1: TPopupMenu;
OpenServer1: TMenuItem;
N1: TMenuItem;
CloseServer1: TMenuItem;
procedure edSendKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure sgServerConnectionsKeyDown(Sender: TObject; var Key: Word;Shift: TShiftState);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure memMessageBoxKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure ChatServerSocketConnect(AThread: TIdPeerThread);
procedure ChatServerSocketExecute(AThread: TIdPeerThread);
procedure ChatServerSocketListenException(AThread: TIdListenerThread; AException: Exception);
procedure ChatServerSocketNoCommandHandler(ASender: TIdTCPServer; const AData: String; AThread: TIdPeerThread);
procedure ChatServerSocketStatus(ASender: TObject; const AStatus: TIdStatus; const AStatusText: String);
procedure btnStartStopServerClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure btnDisconnectClick(Sender: TObject);
procedure ChatServerSocketAfterCommandHandler(ASender: TIdTCPServer; AThread: TIdPeerThread);
procedure ChatServerSocketBeforeCommandHandler(ASender: TIdTCPServer; const AData: String; AThread: TIdPeerThread);
procedure ChatServerSocketDisconnect(AThread: TIdPeerThread);
procedure ChatServerSocketException(AThread: TIdPeerThread; AException: Exception);
procedure btnDisconnectAllClick(Sender: TObject);
procedure memLogKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure FormActivate(Sender: TObject);
procedure cbShowAdminMsgsClick(Sender: TObject);
procedure CloseServer1Click(Sender: TObject);
procedure OpenServer1Click(Sender: TObject);
//
private
{ Private declarations }
ClientList: TList;
procedure AddToClientList(AScreenName: string; AThread: TIdPeerThread);
procedure RemoveFromClientList(ClientInfo: TSCSClientInfo);
//Protocol
procedure BrodcastMessage(Msg: string; AThread: TIdPeerThread);
procedure ProxyMessage(Msg: string; AThread: TIdPeerThread);
function GetLoginList: string;
public
{ Public declarations }
end;

var
Form_Server_Main: TForm_Server_Main;

implementation

uses IdTCPConnection, IdThread;

{$R *.DFM}

procedure TForm_Server_Main.FormCreate(Sender: TObject);
begin
tsAdminMsg.TabVisible := False;

ClientList := TList.Create;

sgServerConnections.RowCount := 2;
sgServerConnections.FixedRows := 1;
sgServerConnections.ColCount := 13;
//Setup Columns
with sgServerConnections do
begin
Cells[0,0] := 'Mem. Addr.';
ColWidths[1] := 25;
Cells[2,0] := 'Screen Name';
ColWidths[2] := 100;
Cells[3,0] := 'Local Host';
ColWidths[3] := 100;
Cells[4,0] := 'Local Address';
ColWidths[4] := 100;
Cells[5,0] := 'Local Port';
ColWidths[5] := 75;
Cells[6,0] := 'Remote Host';
ColWidths[6] := 100;
Cells[7,0] := 'Remote Address';
ColWidths[7] := 100;
Cells[8,0] := 'Remote Port';
ColWidths[8] := 75;
end;
end;

procedure TForm_Server_Main.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
end;

procedure TForm_Server_Main.FormDestroy(Sender: TObject);
begin
if ChatServerSocket.Active then
begin
btnDisconnectAllClick(Self);
try
ChatServerSocket.Active := False;
except
on E: Exception do
begin
memLog.Lines.Add('Exception (' + FormatDateTime(StatusDateTimeFormat, Now) + ') [' + E.ClassName + ']: ' + E.Message);
end; //on
end;
end;
ClientList.Free;
end;

procedure TForm_Server_Main.edSendKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if Key = VK_Return then
begin

if cbBroadcastAsAlert.Checked then
begin
BrodcastMessage('!' + edSend.Text, nil);
end
else
begin
BrodcastMessage('Admin.> ' + edSend.Text, nil);
end;

if cbRecordSentMessages.Checked then
begin
memMessageBox.Lines.Add('Admin.> ' + edSend.Text);
if cbSpaceMessages.Checked then
begin
memMessageBox.Lines.Add('');
end;
end;
edSend.Text := '';
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////

procedure TForm_Server_Main.BrodcastMessage(Msg: string; AThread: TIdPeerThread);
var
List: TList;
I: Integer;
begin
List := ChatServerSocket.Threads.LockList;
try
for I := 0 to List.Count - 1 do
begin
try
if AThread <> TIdPeerThread(List.Items[I]) then
begin
TIdPeerThread(List.Items[I]).Connection.WriteLn(Msg);
end;
except
on E: Exception do
begin
memLog.Lines.Add('Exception (' + FormatDateTime(StatusDateTimeFormat, Now) + ') [' + E.ClassName + ']: ' + E.Message);
memLog.Lines.Add('The thread has been stopped');
TIdPeerThread(List.Items[I]).Stop;
end; //on
end; //try
end; //for
finally
ChatServerSocket.Threads.UnlockList;
end;
end;

procedure TForm_Server_Main.ProxyMessage(Msg: string; AThread: TIdPeerThread);
var
List: TList;
Data: TStrings;
Sender: string;
Receivers: TStrings;
ChatMsg: string;
I, J: Integer;
begin
Data := TStringList.Create;
Receivers := TStringList.Create;
try
Data.CommaText := Msg;
Sender := TSCSClientInfo(AThread.Data).ScreenName; //Also should = Data.Strings[0];
Receivers.CommaText := Data.Strings[1];
ChatMsg := Sender + '> ' + Data.Strings[2];

J := Receivers.IndexOf('Administrator');
if J > -1 then
begin
if cbShowAdminMsgs.Checked then
begin
memMessageBox.Lines.Add(ChatMsg);
end
else
begin
I := sgServerConnections.Cols[2].IndexOf('Administrator');
if I <= -1 then
begin
TIdPeerThread(AThread).Connection.WriteLn('@TJLawr ence is not online.');
end;
end;
end;

List := ChatServerSocket.Threads.LockList;
try
for I := 0 to List.Count - 1 do
begin
try
J := Receivers.IndexOf(TSCSClientInfo(TIdPeerThread(Lis t.Items[I]).Data).ScreenName);
if (J > -1) and (AThread <> TIdPeerThread(List.Items[I])) then
begin
TIdPeerThread(List.Items[I]).Connection.WriteLn(ChatMsg);
end;
except
on E: Exception do
begin
memLog.Lines.Add('Exception (' + FormatDateTime(StatusDateTimeFormat, Now) + ') [' + E.ClassName + ']: ' + E.Message);
memLog.Lines.Add('The thread has been stopped');
TIdPeerThread(List.Items[I]).Stop;
end; //on
end; //try
end; //for
finally
ChatServerSocket.Threads.UnlockList;
end;
finally
Receivers.Free;
Data.Free;
List := nil;
end;
end;

procedure TForm_Server_Main.sgServerConnectionsKeyDown(Sende r: TObject; var Key: Word; Shift: TShiftState);
begin
if (Key = VK_DELETE) and (sgServerConnections.Row <> 0) then
begin
btnDisconnectClick(Self);
end;
end;

procedure TForm_Server_Main.memMessageBoxKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if Key = VK_DELETE then memMessageBox.Clear;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////

procedure TForm_Server_Main.AddToClientList(AScreenName: string; AThread: TIdPeerThread);
var
ClientInfo: TSCSClientInfo;
I: Integer;
begin

ClientInfo := TSCSClientInfo.Create;
ClientInfo.ScreenName := AScreenName;
ClientInfo.LocalName := AThread.Connection.LocalName;
ClientInfo.PeerIP := AThread.Connection.Socket.Binding.PeerIP;
ClientInfo.PeerPort := IntToStr(AThread.Connection.Socket.Binding.PeerPor t);
ClientInfo.IP := AThread.Connection.Socket.Binding.IP;
ClientInfo.Port := IntToStr(AThread.Connection.Socket.Binding.Port);
//ClientInfo.Index
//Assign References
ClientInfo.Thread := AThread;
AThread.Data := ClientInfo;
//
ClientList.Add(ClientInfo);
//Find and empty row in the grid
I := sgServerConnections.Cols[2].IndexOf('-----');
if I <= -1 then
begin
//Add entry to grid
sgServerConnections.RowCount := sgServerConnections.RowCount + 1;
I := ClientList.Count;
sgServerConnections.Cells[1 ,I] := IntToStr(-1);
sgServerConnections.Cells[2 ,I] := '-----';
end;
//Add data
with sgServerConnections do
begin
//Store the address of ClientInfo. Remember objects are automatically dereferenced by the
//compilier so we don't need to use the @ClientInfo symbol here.
Cells[0 ,I] := IntToStr(Integer(ClientInfo));
//Store other info
Cells[1 ,I] := IntToStr(ClientList.Count);
Cells[2 ,I] := ClientInfo.ScreenName;
Cells[3 ,I] := ClientInfo.LocalName;
Cells[4 ,I] := TIdPeerThread(ClientInfo.Thread).Connection.Socket .Binding.IP;
Cells[5 ,I] := IntToStr(TIdPeerThread(ClientInfo.Thread).Connecti on.Socket.Binding.Port);
//Don't know how to get this info yet
Cells[6 ,I] := 'N/A';
Cells[7 ,I] := TIdPeerThread(ClientInfo.Thread).Connection.Socket .Binding.PeerIP;
Cells[8 ,I] := IntToStr(TIdPeerThread(ClientInfo.Thread).Connecti on.Socket.Binding.PeerPort);
end;
end;

procedure TForm_Server_Main.RemoveFromClientList(ClientInfo: TSCSClientInfo);
var
I: Integer;
begin
//Get the address of ClientInfo. Remember objects are automatically dereferenced by the
//compilier so we don't need to use the @ClientInfo symbol here.
I := sgServerConnections.Cols[0].IndexOf(IntToStr(Integer(ClientInfo)));
if I > -1 then
begin
//Setup Columns
with sgServerConnections do
begin
Cells[0 ,I] := '';
Cells[1 ,I] := IntToStr(-1);
Cells[2 ,I] := '-----';
Cells[3 ,I] := '';
Cells[4 ,I] := '';
Cells[5 ,I] := '';
Cells[6 ,I] := '';
Cells[7 ,I] := '';
Cells[8 ,I] := '';
end;
end;
end;

function TForm_Server_Main.GetLoginList: string;
begin
Result := Copy(sgServerConnections.Cols[2].CommaText, 1, Length(sgServerConnections.Cols[2].CommaText)-1);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////

procedure TForm_Server_Main.ChatServerSocketConnect(AThread: TIdPeerThread);
var
Data: string;
I: Integer;
begin
memLog.Lines.Add('Sending connection message (' + FormatDateTime(StatusDateTimeFormat, Now) + ')');

AThread.Connection.WriteLn('&' + WelcomeMessage);
AThread.Connection.WriteLn('&' + 'Date/Time: ' + FormatDateTime(StatusDateTimeFormat, Now));
AThread.Connection.WriteLn('&' + ConnectHelpMsg);
//Get Login Info which the client is expected to send when connecting.
try
AThread.Connection.ReadTimeout := 5000; //If they don't send it in 5 sec. then drop the connection.
try
Data := AThread.Connection.ReadLn;
finally
//Restore default
end;

if Data <> 'Anonymous' then
begin
I := sgServerConnections.Cols[2].IndexOf(Data);
if I <= -1 then
begin
memLog.Lines.Add('Authenticated (' + FormatDateTime(StatusDateTimeFormat, Now) + ') ' + Data);
AThread.Connection.WriteLn('Authenticated: ' + Data);
AddToClientList(Data, AThread);
end
else
begin
memLog.Lines.Add('Not Authenticated (' + FormatDateTime(StatusDateTimeFormat, Now) + ') ' + Data);
AThread.Connection.WriteLn('Not Authenticated. User already logged on.');
Sleep(1000); //Wait for client to get message
AThread.Connection.Disconnect;
end;
end
else
begin
memLog.Lines.Add('Not Authenticated (' + FormatDateTime(StatusDateTimeFormat, Now) + ') ' + Data);
AThread.Connection.WriteLn('Not Authenticated. Server does not accept Anonymous users.');
Sleep(1000); //Wait for client to get message
AThread.Connection.Disconnect;
end;
except
on E: Exception do
begin
memLog.Lines.Add('Exception (' + FormatDateTime(StatusDateTimeFormat, Now) + ') [' + E.ClassName + ']: ' + E.Message);
AThread.Connection.WriteLn('Exception (' + FormatDateTime(StatusDateTimeFormat, Now) + ') [' + E.ClassName + ']: ' + E.Message);
Sleep(1000); //Wait for client to get message
AThread.Connection.Disconnect;
end;
end;
end;

procedure TForm_Server_Main.ChatServerSocketDisconnect(AThre ad: TIdPeerThread);
var
ClientInfo: TSCSClientInfo;
begin
//Do not read/write to thread socket functions at this point because the thread is ending and
//exceptions may occur.

//Cleanup thread data
ClientInfo := TSCSClientInfo(AThread.Data);
AThread.Data := nil;
//Cleanup list
ClientList.Delete(ClientList.IndexOf(ClientInfo));
ClientInfo.Thread := nil;
//Cleanup grid
RemoveFromClientList(ClientInfo);
//Free
ClientInfo.Free;
//
memLog.Lines.Add('Disconnect (' + FormatDateTime(StatusDateTimeFormat, Now) + ')');
end;

procedure TForm_Server_Main.ChatServerSocketException(AThrea d: TIdPeerThread; AException: Exception);
begin
memLog.Lines.Add('Exception (' + FormatDateTime(StatusDateTimeFormat, Now) + ') [' + AException.ClassName + ']: ' + AException.Message);
end;

procedure TForm_Server_Main.ChatServerSocketExecute(AThread: TIdPeerThread);
var
Cmd: string;
Data: string;
begin
try
while AThread.Connection.Connected do
begin
if memLog.Lines.Count > 500 then memLog.Clear;

memLog.Lines.Add('Execute (' + FormatDateTime(StatusDateTimeFormat, Now) + ')');
Data := AThread.Connection.ReadLn;
Cmd := Copy(Data,1,1);
if Cmd = '@' then //Client logging in
begin
BrodcastMessage(Data, AThread);
AThread.Connection.WriteLn('~' + GetLoginList);
end
else if Cmd = '~' then //Client request user list
begin
AThread.Connection.WriteLn('~' + GetLoginList);
end
else if Cmd = '!' then //Server Broadcast Message (from remote client)
begin
BrodcastMessage(Copy(Data,2,Length(Data)-1), nil);
AThread.Connection.WriteLn('+OK "' + Data + '"');
end
else if Cmd = '"' then //Send Message
begin
ProxyMessage(Data, AThread);
end
else if Cmd = '-' then //Quit
begin
BrodcastMessage('-' + TSCSClientInfo(AThread.Data).ScreenName, nil);
AThread.Connection.Disconnect;
end
else
begin
BrodcastMessage('-' + TSCSClientInfo(AThread.Data).ScreenName, nil);
AThread.Connection.WriteLn('Client protocol error. Server disconnected.');
AThread.Connection.Disconnect;
end;
end;
except
on E: Exception do
begin
memLog.Lines.Add('OnExecute Exception (' + FormatDateTime(StatusDateTimeFormat, Now) + ') [' + E.ClassName + ']: ' + E.Message);
end; //on
end;
end;

procedure TForm_Server_Main.ChatServerSocketListenException( AThread: TIdListenerThread; AException: Exception);
begin
memLog.Lines.Add('Listen Exception (' + FormatDateTime(StatusDateTimeFormat, Now) + ')');
end;

procedure TForm_Server_Main.ChatServerSocketAfterCommandHand ler(ASender: TIdTCPServer; AThread: TIdPeerThread);
begin
memLog.Lines.Add('AfterCommandHandler (' + FormatDateTime(StatusDateTimeFormat, Now) + ')');
end;

procedure TForm_Server_Main.ChatServerSocketBeforeCommandHan dler(ASender: TIdTCPServer; const AData: String; AThread: TIdPeerThread);
begin
memLog.Lines.Add('BeforeCommandHandler (' + FormatDateTime(StatusDateTimeFormat, Now) + ')');
end;

procedure TForm_Server_Main.ChatServerSocketNoCommandHandler (ASender: TIdTCPServer; const AData: String; AThread: TIdPeerThread);
begin
memLog.Lines.Add('NoCommandHandler (' + FormatDateTime(StatusDateTimeFormat, Now) + ')');
end;

procedure TForm_Server_Main.ChatServerSocketStatus(ASender: TObject; const AStatus: TIdStatus; const AStatusText: String);
begin
memLog.Lines.Add('Status (' + FormatDateTime(StatusDateTimeFormat, Now) + ') ' + AStatusText);
end;

procedure TForm_Server_Main.btnStartStopServerClick(Sender: TObject);
begin
if ChatServerSocket.Active then
begin
memLog.Lines.Add('Stopping...');
btnDisconnectAllClick(Self);
try
ChatServerSocket.Active := False;
except
on E: Exception do
begin
memLog.Lines.Add('Exception (' + FormatDateTime(StatusDateTimeFormat, Now) + ') [' + E.ClassName + ']: ' + E.Message);
end; //on
end;
memLog.Lines.Add('...Stopped');
btnStartStopServer.Caption := 'Start';
end
else
begin
memLog.Lines.Add('Starting...');
ChatServerSocket.DefaultPort := StrToInt(edServerPort.Text);
ChatServerSocket.Bindings.Clear;
ChatServerSocket.Active := True;
memLog.Lines.Add('...Started');
memLog.Lines.Add('Listening...');
btnStartStopServer.Caption := 'Stop';
lblServerAddress.Caption := 'Server: ' + ChatServerSocket.LocalName;
lbIndyVersion.Caption := 'Indy Version: ' + ChatServerSocket.Version;
end;
end;

procedure TForm_Server_Main.btnDisconnectClick(Sender: TObject);
var
I, X: Integer;
ClientInfo: TSCSClientInfo;
begin
X := sgServerConnections.Row;
I := StrToInt(sgServerConnections.Cells[0,X]);
ClientInfo := Pointer(I);

BrodcastMessage('-' + ClientInfo.ScreenName, nil);
TIdPeerThread(ClientInfo.Thread).Connection.WriteL n('Disconnnected by the server');
if cbSendCloseToClient.Checked then
begin
TIdPeerThread(ClientInfo.Thread).Connection.WriteL n('#');
end;
try
TIdPeerThread(ClientInfo.Thread).Connection.Discon nect;
except
//on E: EIdNotConnected do
//begin
// //Dont worry about this error for now.
//end;
on E: Exception do
begin
memLog.Lines.Add('Exception (' + FormatDateTime(StatusDateTimeFormat, Now) + ') [' + E.ClassName + ']: ' + E.Message);
memLog.Lines.Add('The thread has been stopped');
TIdPeerThread(ClientInfo.Thread).Stop;
end; //on
end;

end;

procedure TForm_Server_Main.btnDisconnectAllClick(Sender: TObject);
var
List: TList;
I: Integer;
begin
List := ChatServerSocket.Threads.LockList;
try
for I := 0 to List.Count - 1 do
begin
try
if cbSendCloseToClient.Checked then
begin
TIdPeerThread(List.Items[I]).Connection.WriteLn('#');
end;
TIdPeerThread(List.Items[I]).Connection.Disconnect;
except
//on E: EIdNotConnected do
//begin
// //Dont worry about this error
//end;
on E: Exception do
begin
memLog.Lines.Add('Exception (' + FormatDateTime(StatusDateTimeFormat, Now) + ') [' + E.ClassName + ']: ' + E.Message);
memLog.Lines.Add('The thread has been stopped');
TIdPeerThread(List.Items[I]).Stop;
end; //on
end; //try
end; //for
finally
ChatServerSocket.Threads.UnlockList;
end;
end;

procedure TForm_Server_Main.memLogKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if Key = VK_DELETE then memMessageBox.Clear;
end;

procedure TForm_Server_Main.FormActivate(Sender: TObject);
begin
pcLearnSockets.ActivePage := tsServer;
end;

procedure TForm_Server_Main.cbShowAdminMsgsClick(Sender: TObject);
begin
if cbShowAdminMsgs.Checked then
begin
tsAdminMsg.TabVisible := True;
pcLearnSockets.ActivePage := tsAdminMsg;
end
else
begin
tsAdminMsg.TabVisible := False;
end;
end;

procedure TForm_Server_Main.CloseServer1Click(Sender: TObject);
begin
application.Terminate;
end;

procedure TForm_Server_Main.OpenServer1Click(Sender: TObject);
begin
Form_Server_Main.Show;
end;

end.


Delphi rocks!
Reply With Quote
Reply

Thread Tools
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is On
Smilies are On
[IMG] code is On
HTML code is On

Forum Jump


All times are GMT. The time now is 05:11 AM.


Powered by vBulletin® Version 3.8.8
Copyright ©2000 - 2019, vBulletin Solutions, Inc.