unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ScktComp, StdCtrls, ExtCtrls, IdBaseComponent, IdComponent,
  IdTCPServer, SyncObjs;

type
  TfrmServer = class(TForm)
    GroupBox1: TGroupBox;     //Рамка вокруг списка событий
    lstEvents: TListBox;      //Список событий
    Timer1: TTimer;
    TCPServer: TIdTCPServer;
    procedure Timer1Timer(Sender: TObject);
    procedure TCPServerExecute(AThread: TIdPeerThread);
    procedure TCPServerConnect(AThread: TIdPeerThread);
    procedure TCPServerDisconnect(AThread: TIdPeerThread);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmServer: TfrmServer;
  REPORT: Boolean;   //Если = True, то все события записываются в ListBox
                     //окна сервера
  SERVERVISIBLE: Boolean; //Если = True, то окно показывается на экране и
                     //приложение есть на панели задач

implementation
{Следующая структура используется для храчения информации и
 пользователе, подключившемуся к серверу}
type
  client = record
    fUsed: Boolean;  {Ячейка занята}
    fNamed: Boolean; {Клиент сообщил свое имя}
    strName: string; {Имя пользователя}
    strIP: string;   {IP-адрес клиента}
    Connection: TIdTCPServerConnection; {Соединение клиента с сервером}
  end;
const
  MAX_CLIENT = 100;//Максимальное количество книентов
var
  clients: array [1..MAX_CLIENT] of client;//Массив со сведениями о клиентах
  section: TCriticalSection; //Критическая секция для синхронизации потоков

{Процедура добавляет текст в список в осне сервера}
procedure AddEvent(strEvent: string);
begin
  section.Enter;
  frmServer.lstEvents.Items.Append(strEvent);
  section.Leave;
end;

//Реализуцию процедуры ErrorCloseConnection см. ниже
procedure ErrorCloseConnection(Connection: TIdTCPServerConnection); forward;
{Процедура рассылает текстовое сообщение всем зарегистрированным
 (сообщившим свое имя) пользователям}
procedure SendAll(strMessage: string);
var
  i: Integer;
begin
  for i:=1 to MAX_CLIENT do
    if (clients[i].fNamed)then
    begin
      try
        clients[i].Connection.WriteLn(strMessage);
      except
        //При возникновении ошибки отключим клиента и продолжим рассылку
        ErrorCloseConnection(clients[i].Connection);
      end;
    end;
end;

{Процедура посылает текстовое сообщение клиенту с заданным именем}
procedure SendTo(strMessage: string; strName: string);
var
  i: Integer;
begin
  for i:=1 to MAX_CLIENT do
    if (clients[i].fNamed)then
      if (clients[i].strName = strName) then
        //Нашли колиента с заданным именем
        try
          clients[i].Connection.WriteLn(strMessage);
        except
          //При возникновении ошибки отключим клиента и продолжим рассылку
          ErrorCloseConnection(clients[i].Connection);
        end;
end;


{Функция добавляет информацию о новом клиенте (если есть место)
 возвращает True в случае успеха}
function AddClient(Connection: TIdTCPServerConnection): Boolean;
var
  i: Integer;
begin
  section.Enter;
  for i:=1 to MAX_CLIENT do
  begin
    if (not clients[i].fUsed) then
    begin
      //Нашли свободную запись - заполним ее (клиент пока безымянный)
      clients[i].fUsed := True;
      clients[i].Connection := Connection;
      clients[i].strIP := Connection.Socket.Binding.PeerIP;
      AddClient := True;
      section.Leave;
      Exit;
    end;
  end;
  section.Leave;
  AddClient := False;
end;

{Функция помечает запись о клиенте как свободную (клиент отсоединен)
 и возвращает структуру с заполненным полем имени и IP-адреса клиента}
function DeleteClient(Connection: TIdTCPServerConnection):client;
var
  i: Integer;
begin
  section.Enter;
  for i:=1 to MAX_CLIENT do
    if (clients[i].fUsed) then
      if (clients[i].Connection = Connection) then
      begin
        //Вот она - запись о нужном клиенте
        clients[i].fUsed := False;
        clients[i].fNamed := False;
        clients[i].Connection := Nil;
        DeleteClient := clients[i];
        clients[i].strName := '';
        clients[i].strIP := '';

        section.Leave;
        Exit;
      end;
end;

{Процедура посылает заданному клиенту имена всех остальных
 присоединенных с серверу клиентов}
procedure SendClientList(Connection: TIdTCPServerConnection);
var
  i: Integer;
begin
  for i:= 1 to MAX_CLIENT do
    if (clients[i].fNamed) then
      if (clients[i].Connection <> Connection) then
        try
          //Сообщим имя очередного найденного пользователя
          Connection.WriteLn('adduser:' + clients[i].strName);
        except
          //При возникновении ошибки отключим клиента и продолжим рассылку
          ErrorCloseConnection(clients[i].Connection);
        end;
end;

{Процедура отсоединяет закрывает соединение с клиентом}
procedure ErrorCloseConnection(Connection: TIdTCPServerConnection);
var
  clError: client; //Информация о пользователе, соединение с
                   //которым прервалось (только имя и IP)
begin
  //Отключим соединение, работающее с ошибками
  clError := DeleteClient(Connection);
  //Сообщим от отключении остальным пользователям
  SendAll('deluser:' + clError.strName);
  SendAll('Нас покинул "' + clError.strName + '".');

  //Добавим событие в журнал
  if (REPORT) then AddEvent('Из-за ошибки отсоединен клиент "' +
   clError.strName + '" на компьютере "' + clError.strIP + '"');
end;

{Процедура сохраняет имя клиента.
 Если клиент с указанным именем уже зарегистрирован, то клиенту посылается
 сообщение об ощибке, после чего соединение разрывается.}
procedure RegisterClient(Connection: TIdTCPServerConnection;
 strName: string);
var
  i: Integer;
begin
  //Проверим, чтобы имя клиента еще не использовалось
  for i:=1 to MAX_CLIENT do
  begin
    if (clients[i].fNamed) then
      if (clients[i].strName = strName) then
      begin
        //Дублирование имени - придется разрывать соединение
        Connection.WriteLn('error:Пользователь с именем "' + strName +
         '" уже участвует в разговоре.');
        DeleteClient(Connection);
        Connection.Socket.Close;
        Exit;
      end;
  end;

  //Поиск записи о нужном клиенте и присвоение ему имени
  for i:=1 to MAX_CLIENT do
  begin
    if (not clients[i].fNamed and clients[i].fUsed) then
      if (clients[i].Connection = Connection) then
      begin
        //Вот он, наш клиент...
        clients[i].fNamed := True;
        clients[i].strName := strName;

        //Сообщим другим о появлении нового участника
        SendAll('adduser:' + strName);
        SendAll('text:К нам присоединился "' + strName +
         '". Поприветствуем!');
        //Отсылаем новому книенту список остальных участников разговора
        SendClientList(Connection);
        //Разрешим новому клиенту отсылать сообщения
        Connection.WriteLn('ok:');

        //Если нужно, то добавим событие в список
        if (REPORT) then AddEvent('Присоединен клиент "' + strName +
         '" на компьютере "' + Connection.Socket.Binding.PeerIP + '"');
      end;
  end;
end;

{Функция возвращает имя клиента по Socket'у, которым он связан с сервером}
function GetClientName(Connection: TIdTCPServerConnection):string;
var
  i: Integer;
begin
  for i:=1 to MAX_CLIENT do
    if (clients[i].fNamed) then
      if (clients[i].Connection.Socket.Binding.Handle
       = Connection.Socket.Binding.Handle) then
      begin
        GetClientName := clients[i].strName;
        Exit;
      end;
end;

{Процедура обрабатывает сообщение, присланное клиентом}
procedure ProcessMessage(Connection: TIdTCPServerConnection;
 strMessage: string);
var
  strName: string;   //Имя отправителя сообщения
  strAction: string; //Строка с обозначением действия (префикс)
  len: Integer;      //Длина строки strAction
begin
  //Определим действие, которое хочет выполнить клиент
  len := Pos(':', strMessage);
  strAction := Copy(strMessage,1,len-1);
  Delete(strMessage,1,len);
  if (strAction = 'name') then
  begin
    //Клиент сообщает свое имя - пытаемся его зарегистрировать
    RegisterClient(Connection, strMessage);
  end
  else if (strAction = 'text') then
  begin
    //Клиент передает соощение всем: подпишем сообщение и отошлем
    strMessage := GetClientName(Connection) + ': ' + strMessage;
    SendAll('text:' + strMessage);
    //Если надо, со сохраняем сообщение в списке событий
    if (REPORT) then AddEvent('Сообщение от ' + strMessage);
  end
  else
  begin
    //Клиент передает сообщение определенному собеседнику
    //(строка strAction содержит имя собеседника)
    strName := GetClientName(Connection);
    SendTo('text:' + strName + ': ' + strMessage, strAction);
    if (strName <> strAction) then
      //Передадим копию сообщения отправителю
      Connection.WriteLn('text:' + strName + ' для ' + strAction + ': '
       + strMessage);

    //Если надо, со сохраняем сообщение в списке событий
    if (REPORT) then AddEvent('Сообщение для ' + strAction +
     ' от ' + strName + ': ' + strMessage);
  end;
end;

{
***************************************************************************
  Далее идут процедуры-обработчики событий
***************************************************************************
}
{$R *.dfm}
procedure TfrmServer.Timer1Timer(Sender: TObject);
begin
  //Если нужно, то скроем окно сервера
  if (not SERVERVISIBLE) then
  begin
    frmServer.Visible := False;
    ShowWindow(Application.Handle,SW_HIDE);
  end;
  //Таймер больше не нужен
  Timer1.Enabled := False;
end;

procedure TfrmServer.TCPServerExecute(AThread: TIdPeerThread);
begin
  //Обработаем сообщение, пришедшее от клиента
  ProcessMessage(AThread.Connection, AThread.Connection.ReadLn);
end;

procedure TfrmServer.TCPServerConnect(AThread: TIdPeerThread);
begin
  //Попытаемся добавить нового пользователя
  if (AddClient(AThread.Connection)) then
    //Пользователь должен прислать свое имя
    ProcessMessage(AThread.Connection, AThread.Connection.ReadLn)
  else
  begin
    //Нет места для нового пользователя
    AThread.Connection.WriteLn('error:Достигнуто максимальное количество ' +
     'пользователей. Извините, невозможно принять Вас в разговор.');
    AThread.Connection.Socket.Close;
  end;
end;

procedure TfrmServer.TCPServerDisconnect(AThread: TIdPeerThread);
var clDisconnected: client; //Структура с информацией об
     //отсоединенном клиенте (заполнены только поля strName и strIP)
begin
  //Удалим информацию об отсоединенном клиенте
  clDisconnected := DeleteClient(AThread.Connection);
  if (clDisconnected.strName <> '')then
  begin
    //Сообщим о событии остальным клиентам
    SendAll('deluser:' + clDisconnected.strName);
    SendAll('Нас покинул "' + clDisconnected.strName + '".');
    //Добавим событие в журнал
    if (REPORT) then AddEvent('Отсоединился клиент "' +
     clDisconnected.strName + '" на компьютере "' +
     clDisconnected.strIP + '"');
  end;
end;

procedure TfrmServer.FormCreate(Sender: TObject);
begin
  //Создаем критическую секцию
  section := TCriticalSection.Create;
end;

end.
