Сервер
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Buttons, ExtCtrls, ScktComp, ComCtrls, mesage;
type
sUser = record
Name, Pass : String[32]; //логин и пароль
end;
PSock = ^TSock; // Указатель на динамическую структуру...
TSock = record
Key: String[32]; //ID клиента
end;
TServer = class(TForm)
ServerSocket1: TServerSocket;
LabeledEdit1: TLabeledEdit;
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
ListBox1: TListBox;
procedure BitBtn1Click(Sender: TObject);
procedure BitBtn2Click(Sender: TObject);
procedure ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure ServerSocket1ClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
procedure SetReg(user : sUser);
function Encrypt(const str : String; key : byte) : String; // функция шифрования
function Decrypt(const cryptstr : String; key : byte) : String; // функция расшифровки
function IsLoginExists(user : sUser; reg : boolean) : boolean;
function AddUser(login : string) : boolean;
function FndandDelFile(name : string) : string;
public
{ Public declarations }
end;
var
Server: TServer;
start : boolean;
datasize : integer;
let : TFileStream;
recive : boolean;
filename, msg_to, msg_from : string;
FPipeRead: THandle;
FPipeWrite: THandle;
FDataLen: DWORD;
FDataRead: DWORD;
implementation
{$R *.dfm}
//открываем порт
procedure TServer.BitBtn1Click(Sender: TObject);
begin
ListBox1.Items.Clear;
ServerSocket1.Port := StrToInt(LabeledEdit1.Text);
ServerSocket1.Open;
BitBtn2.Enabled := true;
BitBtn1.Enabled := false;
LabeledEdit1.Enabled := false;
end;
//закрываем порт
procedure TServer.BitBtn2Click(Sender: TObject);
begin
ListBox1.Items.Clear;
if ServerSocket1.Active = true then ServerSocket1.Close;
BitBtn1.Enabled := true;
BitBtn2.Enabled := false;
LabeledEdit1.Enabled := true;
end;
//сохраняем файл с логинами и паролями
procedure TServer.SetReg(user : sUser);
var fl, tmp : TFileStream;
sz : Integer;
Usr : sUser;
begin
if not DirectoryExists(ExtractFilePath(Application.ExeName) + '\DBases\') then
CreateDir(ExtractFilePath(Application.ExeName) + '\DBases\');
SetCurrentDir(ExtractFilePath(Application.ExeName) + '\DBases\');
if FileExists('users.cs') then
begin
fl := TFileStream.Create('users.cs', fmOpenRead);
tmp := TFileStream.Create('users.tmp', fmCreate);
fl.Read(sz, 4);
sz := sz + 1;
tmp.Write(sz, 4);
tmp.CopyFrom(fl, fl.Size - 4);
fl.Free;
end
else
begin
tmp := TFileStream.Create('users.cs', fmCreate);
sz := 1;
tmp.Write(sz, 4);
end;
Usr.Name := Encrypt(user.Name, 128);
Usr.Pass := Encrypt(user.Pass, 128);
sz := sizeof(Usr);
tmp.Write(sz, 4);
tmp.Write(Usr, sz);
tmp.Free;
if FileExists('users.tmp') then
begin
CopyFile('users.tmp', 'users.cs', False);
DeleteFile('users.tmp');
end;
end;
function TServer.Encrypt(const str : String; key : byte) : String; //шифруем сроку
var i : Integer;
tmp, cryptstr : String;
begin
for i:=1 to Length(str) do
begin
tmp := chr(ord(str[i]) xor key);
cryptstr := cryptstr + tmp;
end;
Result := cryptstr;
end;
function TServer.Decrypt(const cryptstr : String; key : byte) : String; //расшифруем сроку
var i : Integer;
tmp, decryptstr : String;
begin
for i:=1 to Length(cryptstr) do
begin
tmp := chr(ord(cryptstr[i]) xor key);
decryptstr := decryptstr + tmp;
end;
Result := decryptstr;
end;
//проверяем при регистрации: не занят ли логин, а также при входе - логин и пароль
function TServer.IsLoginExists(user : sUser; reg : boolean) : boolean;
var fl : TFileStream;
sz, len, i : Integer;
str : String;
Usr : sUser;
begin
Result := false;
SetCurrentDir(ExtractFilePath(Application.ExeName) + '\DBases\');
if FileExists('users.cs') then
begin
fl := TFileStream.Create('users.cs', fmOpenRead);
fl.Read(len, 4);
for i := 1 to len do
begin
fl.Read(sz, 4);
fl.Read(Usr, sz);
str := Decrypt(Usr.Name, 128);
if user.Name = str then
begin
Result := true;
if reg = false then
begin
str := Decrypt(Usr.Pass, 128);
if str <> user.Pass then Result := false;
end;
break;
end;
end;
fl.Free;
end;
end;
//закрываем сервер
procedure TServer.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if ServerSocket1.Active = true then ServerSocket1.Close;
end;
//добавляем нового активного пользователя
function TServer.AddUser(login : string) : boolean;
var i : integer;
begin
Result := true;
for i:=0 to ListBox1.Items.Count-1 do
begin
if login = ListBox1.Items.Strings[i] then
begin
Result := false;
break;
end;
end;
if Result = true then ListBox1.Items.Add(login);
end;
//обновляем список активных пользователей при отключении одного
procedure TServer.ServerSocket1ClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
var i : integer;
begin
ListBox1.Items.Clear;
for i := 0 to ServerSocket1.Socket.ActiveConnections-1 do
ServerSocket1.Socket.Connections[i].SendText(M_AUT);
end;
//конструктор формы
procedure TServer.FormCreate(Sender: TObject);
begin
recive := false;
end;
procedure TServer.ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
var msg : String;
buf : char;
len : BYTE;
i, sz: integer;
User : sUser;
Buffer: PChar;
dummy: Cardinal;
_data : PSock;
mes : TMesage;
begin
mes := TMesage.Create;
if recive = false then
begin
mes.mesage := Socket.ReceiveText;
case mes.TypeMessage of
R_UID : //получаем ID пользователя
begin
New(_data);
_data.Key := mes.mesage;
ServerSocket1.Socket.Connections[ServerSocket1.Socket.ActiveConnections-1].Data := _data;
end;
R_FIN : //сообщении о том, что пользователь получил сообщение и его можно удалять
begin
msg := mes.NextMessage(true);
if FileExists(ExtractFilePath(Application.ExeName) + '\DBases\' + msg +'\' + mes.mesage) then
DeleteFile(ExtractFilePath(Application.ExeName) + '\DBases\' + msg +'\' + mes.mesage);
filename := FndandDelFile(msg);
if filename <> '' then //если еще есть сообщения для данного пользователя
mes.mesage := M_SND;
mes.AddToMessage(msg, true);
mes.AddToMessage(filename, false); // отправляем сообщения о готоности отправки следующего письма
for i := 0 to ServerSocket1.Socket.ActiveConnections-1 do
ServerSocket1.Socket.Connections[i].SendText(mes.mesage);
end;
R_REG : //регистрация нового пользователя
begin
User.Name := mes.NextMessage(true);
User.Pass := mes.NextMessage(true);
msg := mes.mesage;
if IsLoginExists(User, true) = false then
begin
SetReg(User);
mes.mesage := M_ENT + mes.mesage; //успешная регистрация
end
else
begin
mes.mesage := M_BAD;
mes.AddToMessage(msg, true);
mes.AddToMessage('Пользователь с таким логином уже существует!', false);
end;
//отправляем сообщение о результатах регистрации
for i := 0 to ServerSocket1.Socket.ActiveConnections-1 do
ServerSocket1.Socket.Connections[i].SendText(mes.mesage);
end;
R_ENT : //вход пользователя
begin
User.Name := mes.NextMessage(true);
User.Pass := mes.NextMessage(true);
msg := mes.mesage;
if IsLoginExists(User, false) = true then
begin
mes.mesage := M_ENT + msg; //успешный вход
AddUser(User.Name);
end
else
begin
mes.mesage := M_BAD;
mes.AddToMessage(msg, true);
mes.AddToMessage('Неверные логин/пароль!', false);
end;
//отправляем сообщение о результатах входа
for i := 0 to ServerSocket1.Socket.ActiveConnections-1 do
ServerSocket1.Socket.Connections[i].SendText(mes.mesage);
end;
R_AUT : ListBox1.Items.Add(mes.mesage); //получаем логин при опросе клиентов
R_OFF : //проверяем наличие сообщений для пользователя из офф-лайна
begin
msg := mes.mesage;
filename := FndandDelFile(msg);
if filename <> '' then
begin
mes.mesage := M_SND;
mes.AddToMessage(msg, true);
mes.AddToMessage(filename, false);
// отправляем сообщения о готоности отправки следующего сообщения
for i := 0 to ServerSocket1.Socket.ActiveConnections-1 do
ServerSocket1.Socket.Connections[i].SendText(mes.mesage);
end;
end;
R_USR : //проверяем: существует ли пользователь с таким логином
begin
msg := mes.NextMessage(true);
User.Name := mes.mesage;
if IsLoginExists(User, true) = false then
begin
mes.mesage := M_BAD;
mes.AddToMessage(msg, true);
mes.AddToMessage('Пользователя с таким логином не существует!', false);
end
else
begin
mes.mesage := M_USR;
mes.AddToMessage(msg, true);
mes.AddToMessage(User.Name, false); //пользователь существует
end;
//отправляем сообщение о результате проверки
for i := 0 to ServerSocket1.Socket.ActiveConnections-1 do
ServerSocket1.Socket.Connections[i].SendText(mes.mesage);
end;
R_SND :
begin
msg_from := mes.NextMessage(true);
msg_to := mes.NextMessage(true);
filename := mes.NextMessage(true);
msg := mes.mesage;
if not DirectoryExists(ExtractFilePath(Application.ExeName) + '\DBases\' + msg_to +'\') then
CreateDir(ExtractFilePath(Application.ExeName) + '\DBases\'+ msg_to +'\');
SetCurrentDir(ExtractFilePath(Application.ExeName) + '\DBases\'+ msg_to +'\');
recive := true;
mes.mesage := M_YES + msg_from; //передаем сообщение о том, что готовы принять файл
for i := 0 to ServerSocket1.Socket.ActiveConnections-1 do
begin
if PSock(ServerSocket1.Socket.Connections[i].Data)^.Key = msg then
begin
ServerSocket1.Socket.Connections[i].SendText(mes.mesage);
break;
end;
end;
CreatePipe(FPipeRead, FPipeWrite, nil, $8000);
FDataLen:=0;
end;
R_YES : //принимаем сообщение от пользователя, что он готов принять файл и отправляем его
begin
let := TFileStream.Create(filename, fmOpenRead);
try
sz := let.Size;
for i := 0 to ServerSocket1.Socket.ActiveConnections-1 do
begin
if PSock(ServerSocket1.Socket.Connections[i].Data)^.Key = mes.mesage then
begin
ServerSocket1.Socket.Connections[i].SendBuf(sz, SizeOf(sz));
ServerSocket1.Socket.Connections[i].SendStream(let);
end;
end;
except
let.Free;
end;
end;
end;
end
else
begin
//принимаем файл
sz:=Socket.ReceiveLength;
Buffer:=GetMemory(sz);
try
sz:=Socket.ReceiveBuf(Buffer^, sz);
WriteFile(FPipeWrite, Buffer^, sz, dummy, nil);
finally
FreeMemory(Buffer);
end;
while True do
begin
sz:=GetFileSize(FPipeRead, nil);
if sz=0 then Break;
if FDataLen=0 then
begin
if sz
ReadFile(FPipeRead, FDataLen, SizeOf(DWORD), dummy, nil);
FDataRead:=0;
let:=TFileStream.Create(filename, fmCreate);
end
else
begin
Buffer:=GetMemory(sz);
try
ReadFile(FPipeRead, Buffer^, sz, dummy, nil);
let.Write(Buffer^, sz);
Inc(FDataRead, sz);
if FDataRead=FDataLen then
begin
let.Free;
recive := false;
CloseHandle(FPipeWrite);
CloseHandle(FPipeRead);
FDataLen:=0;
mes.mesage := M_SND;
mes.AddToMessage(msg_to, true);
mes.AddToMessage(filename, false);
//отправляем сообщенbе о том, что файл принят его можно передавать дальше по назначению
for i := 0 to ServerSocket1.Socket.ActiveConnections-1 do
ServerSocket1.Socket.Connections[i].SendText(mes.mesage);
end;
finally
FreeMemory(Buffer);
end;
end;
end;
end;
mes.Free;
end;
//проверяем наличие файлов в очереди на отправку
function TServer.FndandDelFile(name : string) : string;
var sr : TSearchRec;
done : integer;
tmp : String;
begin
Result := '';
if DirectoryExists(ExtractFilePath(Application.ExeName) + '\Dbases\'+ name + '\') then
begin
SetCurrentDir(ExtractFilePath(Application.ExeName) + '\Dbases\' +name + '\');
tmp := '*.*';
done := FindFirst(tmp, faAnyFile, sr);
while done = 0 do
begin
if ExtractFileExt(sr.Name) = '.snd' then
begin
Result := sr.Name;
break;
end;
done := FindNext(sr);
end;
FindClose(sr);
end;
end;
end.
unit mesage;
interface
const
//неизвестный идентификатор
R_ERR = -1;
//ошибки входа/регистрации
M_BAD = '#M';
R_BAD = 0;
//успешный вход
M_ENT = '#E';
R_ENT = 1;
//авторизация пользователя
M_AUT = '#A';
R_AUT = 2;
//проверка существования пользователя
M_USR = '#U';
R_USR = 3;
//подтверждение отправки письма
M_YES = '#Y';
R_YES = 4;
//отправка письма
M_SND = '#S';
R_SND = 5;
//проверка сообщений в оффлайне
M_OFF = '#X';
R_OFF = 6;
//проверка ID клиента
M_UID = '#Z';
R_UID = 7;
//завершение отправки письма
M_FIN = '#F';
R_FIN = 8;
//регистрация нового пользователя
M_REG = '#R';
R_REG = 9;
type
TMesage = class //класс для обработки сообщений
public
mesage : String; //само сообщение
function TypeMessage() : integer;
function NextMessage(size : boolean) : String;
procedure AddToMessage(str: string; size : boolean);
end;
implementation
//определяем тип сообщения
function TMesage.TypeMessage() : integer;
var str : string;
begin
str := Copy(mesage, 1, 2);
Delete(mesage, 1, 2);
Result := R_ERR;
if str = M_BAD then
begin
Result := R_BAD;
end
else
begin
if str = M_ENT then
begin
Result := R_ENT;
end
else
begin
if str = M_AUT then
begin
Result := R_AUT;
end
else
begin
if str = M_USR then
begin
Result := R_USR;
end
else
begin
if str = M_YES then
begin
Result := R_YES;
end
else
begin
if str = M_SND then
begin
Result := R_SND;
end
else
begin
if str = M_OFF then
begin
Result := R_OFF;
end
else
begin
if str = M_UID then
begin
Result := R_UID;
end
else
begin
if str = M_FIN then
begin
Result := R_FIN;
end
else
begin
if str = M_REG then Result := R_REG;
end;
end;
end;
end;
end;
end;
end;
end;
end;
end;
function TMesage.NextMessage(size : boolean) : String;
var buf : char;
len : BYTE;
begin
if size = true then
begin //узнаем параметр с учетом его размера в количестве символов
buf := mesage[1];
len := BYTE(buf);
Delete(mesage, 1, 1);
Result := Copy(mesage, 1, len);
Delete(mesage, 1, len);
end
else
begin //безразмерный параметр
Result := mesage;
end;
end;
procedure TMesage.AddToMessage(str: string; size : boolean);
var buf : char;
len : BYTE;
begin
if size = true then
begin //добавляем параметр к сообщению с учетом его размера в количестве символов
len := Length(str);
buf := char(len);
mesage := mesage + buf + str;
end
else
begin //безразмерный параметр
mesage := mesage + str;
end;
end;
end.
Клиент:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Buttons, ScktComp, ExtCtrls, ComCtrls, Grids,
DB, DBTables, mesage, Outline;
type
sLetter = record //структура, описывающая письма
Name, From : String[32]; //кому и от кого
Theme : String[255]; //тема письма
Date : TDateTime; //время создания
Sz : integer; //размер
end;
TPost = class (TObject) //класс для просмотра писем
constructor Create; overload;
public
Body : TStringList; //тело письма
Letter : sLetter;
Level : integer; //уровень
num : integer; //порядковый номер в базе
typ : boolean; //тип письма: true - входящие, false - исходящие
end;
TClient = class(TForm)
ClientSocket1: TClientSocket;
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
LabeledEdit1: TLabeledEdit;
LabeledEdit2: TLabeledEdit;
BitBtn3: TBitBtn;
BitBtn4: TBitBtn;
BitBtn5: TBitBtn;
Panel1: TPanel;
LabeledEdit3: TLabeledEdit;
LabeledEdit4: TLabeledEdit;
RichEdit1: TRichEdit;
OutLine1: TOutline;
BitBtn7: TBitBtn;
BitBtn6: TBitBtn;
BitBtn8: TBitBtn;
procedure BitBtn1Click(Sender: TObject);
procedure BitBtn2Click(Sender: TObject);
procedure BitBtn3Click(Sender: TObject);
procedure ClientSocket1Connect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ClientSocket1Disconnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure BitBtn5Click(Sender: TObject);
procedure BitBtn7Click(Sender: TObject);
procedure OutLine1Click(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure BitBtn6Click(Sender: TObject);
procedure BitBtn8Click(Sender: TObject);
private
{ Private declarations }
function SendLetter(): string;
procedure SaveLetter(name : String; inbox : boolean);
procedure OpenPost;
procedure DeleteLetter(ind : integer; inbox : boolean);
procedure FndandDelFile;
public
{ Public declarations }
r_i : boolean;
login : string;
function GetKey : Longint;
end;
var
Client: TClient;
key, filename : string;
List : TStringList;
s_let : boolean;
recive : boolean;
let : TFileStream;
FPipeRead: THandle;
FPipeWrite: THandle;
FDataLen: DWORD;
FDataRead: DWORD;
implementation
uses Unit2, Unit3;
{$R *.dfm}
//соединяемся с сервером
procedure TClient.BitBtn1Click(Sender: TObject);
begin
ClientSocket1.Host := LabeledEdit1.Text;
ClientSocket1.Port := StrToInt(LabeledEdit2.Text);
ClientSocket1.Open;
end;
//закрываем соединение
procedure TClient.BitBtn2Click(Sender: TObject);
begin
ClientSocket1.Close;
end;
//открываем форму входа/регистрации
procedure TClient.BitBtn3Click(Sender: TObject);
begin
if ( r_i = false ) and ( ClientSocket1.Active = true ) then
begin
Authorisation := TAuthorisation.Create(Application);
Authorisation.Tag := TBitBtn(Sender).Tag;
Authorisation.Show;
end;
end;
//действие при подключении
procedure TClient.ClientSocket1Connect(Sender: TObject;
Socket: TCustomWinSocket);
begin
BitBtn2.Enabled := true;
BitBtn3.Enabled := true;
BitBtn4.Enabled := true;
BitBtn1.Enabled := false;
LabeledEdit1.Enabled := false;
LabeledEdit2.Enabled := false;
List := TStringList.Create;
s_let := false;
Key := IntToStr(GetKey);
Socket.SendText('#Z' + Key); //сообщаем ID серверу
end;
//действия при отключении
procedure TClient.ClientSocket1Disconnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
BitBtn2.Enabled := false;
BitBtn3.Enabled := false;
BitBtn4.Enabled := false;
BitBtn5.Enabled := false;
BitBtn7.Enabled := false;
BitBtn8.Enabled := false;
BitBtn6.Enabled := false;
BitBtn1.Enabled := true;
Panel1.Visible := false;
LabeledEdit1.Enabled := true;
LabeledEdit2.Enabled := true;
if r_i = true then Authorisation.Visible := false;
r_i := false;
OutLine1.Lines.Clear;
FndandDelFile;
end;
procedure TClient.ClientSocket1Read(Sender: TObject;
Socket: TCustomWinSocket);
var sz: integer;
Buffer: PChar;
dummy: Cardinal;
mes : TMesage;
begin
mes := TMesage.Create;
if recive = false then
begin
mes.mesage := Socket.ReceiveText;
case mes.TypeMessage of
R_BAD : //получакм сообщение об ошибке входа регистрации
begin
if (r_i = true) and (Authorisation.key = mes.NextMessage(true) ) then ShowMessage(mes.mesage);
if (r_i = false) and (Panel1.Visible = true ) and (login = mes.NextMessage(true)) then
begin
ShowMessage(mes.mesage);
s_let := false;
end;
end;
R_ENT :
begin
if (r_i = true) and (mes.mesage = Authorisation.key ) then
begin
login := Authorisation.LabeledEdit3.Text;
OpenPost;
Authorisation.Close;
BitBtn5.Enabled := true;
BitBtn3.Enabled := false;
BitBtn4.Enabled := false;
BitBtn6.Enabled := true;
mes.mesage := M_OFF + login; //отправляем серверу сообщение о том, что мы вошли и хотим проверить - не было ли чообщений в наше отсутствие
Socket.SendText(mes.mesage);
end;
end;
R_AUT :
begin
mes.mesage := M_AUT + login; //сообщаем серверу логин
Socket.SendText(mes.mesage);
end;
R_USR : //принимаем сообщение о том, что юзер существует и мы готовы отправить на сервер сообщение для него
begin
if s_let = true then
begin
s_let := false;
filename := SendLetter();
mes.mesage := M_SND;
mes.AddToMessage(login, true);
mes.AddToMessage(LabeledEdit3.Text, true);
mes.AddToMessage(filename, true);
mes.AddToMessage(Key, false);
Socket.SendText(mes.mesage);
end;
end;
R_YES : //тправляем письмо на сервер
begin
if mes.mesage = login then
begin
let := TFileStream.Create(filename, fmOpenRead);
try
sz := let.Size;
Socket.SendBuf(sz, SizeOf(sz));
ClientSocket1.Socket.SendStream(let);
except
let.Free;
end;
end;
end;
R_SND : //готовимся к приему письма
begin
if login = mes.NextMessage(true) then
begin
filename := mes.mesage;
mes.mesage := M_YES + key;
Socket.SendText(mes.mesage);
recive := true;
if not DirectoryExists(ExtractFilePath(Application.ExeName) + login + '\') then
CreateDir(ExtractFilePath(Application.ExeName) + login + '\');
SetCurrentDir(ExtractFilePath(Application.ExeName) + login + '\');
CreatePipe(FPipeRead, FPipeWrite, nil, $8000);
FDataLen:=0;
end;
end;
end;
end
else
//прием письма
begin
sz:=Socket.ReceiveLength;
Buffer:=GetMemory(sz);
try
sz:=Socket.ReceiveBuf(Buffer^, sz);
WriteFile(FPipeWrite, Buffer^, sz, dummy, nil);
finally
FreeMemory(Buffer);
end;
while True do
begin
sz:=GetFileSize(FPipeRead, nil);
if sz=0 then Break;
if FDataLen=0 then
begin
if sz
ReadFile(FPipeRead, FDataLen, SizeOf(DWORD), dummy, nil);
FDataRead:=0;
let:=TFileStream.Create(filename, fmCreate);
end
else
begin
Buffer:=GetMemory(sz);
try
ReadFile(FPipeRead, Buffer^, sz, dummy, nil);
let.Write(Buffer^, sz);
Inc(FDataRead, sz);
if FDataRead=FDataLen then
begin
let.Free;
recive := false;
CloseHandle(FPipeWrite);
CloseHandle(FPipeRead);
SaveLetter(filename, false);
OpenPost;
Outline1.SelectedItem := OutLine1.Lines.Count;
OutLine1Click(nil);
SetForeGroundWindow(Handle);
Beep;
ShowMessage('Вам письмо!'); //сообщаем об этом пользователю, а так же отправляем серверу сообщение о том, что письмо получено
mes.mesage := M_FIN;
mes.AddToMessage(login, true);
mes.AddToMessage(filename, false);
Socket.SendText(mes.mesage);
FDataLen:=0;
end;
finally
FreeMemory(Buffer);
end;
end;
end;
end;
mes.Free;
end;
//конструктор формы
procedure TClient.FormCreate(Sender: TObject);
begin
r_i := false;
end;
//завершение работы
procedure TClient.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if ClientSocket1.Active = true then ClientSocket1.Close;
end;
//конструктор класса для работы с почтой
constructor TPost.Create;
begin
Body := TStringList.Create;
end;
//готовимся отправить письмо
procedure TClient.BitBtn5Click(Sender: TObject);
begin
Panel1.Visible := true;
BitBtn7.Enabled := true;
LabeledEdit3.EditLabel.Caption := 'Кому:';
LabeledEdit3.Text := '';
LabeledEdit4.Text := '';
RichEdit1.Lines.Clear;
end;
//формируем файл для отправки
function TClient.SendLetter(): string;
var let, body : TFileStream;
struct : sLetter;
len : Integer;
name : string;
begin
if not DirectoryExists(ExtractFilePath(Application.ExeName) + login + '\') then
CreateDir(ExtractFilePath(Application.ExeName) + login + '\');
SetCurrentDir(ExtractFilePath(Application.ExeName) + login + '\');
name := IntToStr(GetKey) + '.snd';
let := TFileStream.Create(name, fmCreate);
RichEdit1.Lines.SaveToFile('rich.tmp');
body := TFileStream.Create('rich.tmp', fmOpenRead);
struct.Name := LabeledEdit3.Text;
struct.From := login;
struct.Theme := LabeledEdit4.Text;
struct.Date := Now;
struct.Sz := body.Size;
len := sizeof(struct);
let.Write(len, 4);
let.Write(struct, len);
let.CopyFrom(body, body.Size);
let.Free;
body.Free;
DeleteFile('rich.tmp');
Result := name;
SaveLetter(name, true);
OpenPost;
end;
//получаем уникальный ID
function TClient.GetKey : Longint;
var key, tmp : Longint;
getst : TSystemTime;
begin
GetLocalTime(getst);
key := GetTickCount();
tmp := Longint(getst.wDay) * Longint(24) * Longint(3600);
key := key + tmp;
tmp := Longint(getst.wMonth) * Longint(30) * Longint(24) * Longint(3600);
key := key + tmp;
Result := key;
end;
//проверяем - существует ли адресат
procedure TClient.BitBtn7Click(Sender: TObject);
var str : AnsiString;
buf : char;
len : BYTE;
begin
len := Length(login);
buf := char(len);
str := '#U' + buf + login + LabeledEdit3.Text;
ClientSocket1.Socket.SendText(str);
s_let := true;
end;
//сохраняем переписку
procedure TClient.SaveLetter(name : String; inbox : boolean);
var yang, old : TFileStream;
nm : string;
sz : integer;
begin
if not DirectoryExists(ExtractFilePath(Application.ExeName) + login + '\') then
CreateDir(ExtractFilePath(Application.ExeName) + login + '\');
SetCurrentDir(ExtractFilePath(Application.ExeName) + login + '\');
if inbox = true then
begin
nm := 'out.cs'; //исходящие
end
else
begin
nm := 'in.cs'; //входящие
end;
if FileExists(nm) then
begin
old := TFileStream.Create(nm, fmOpenRead);
yang := TFileStream.Create('tmp.tmp', fmCreate);
old.Read(sz, 4);
sz := sz + 1;
yang.Write(sz, 4);
yang.CopyFrom(old, old.Size - 4);
old.Free;
end
else
begin
yang := TFileStream.Create(nm, fmCreate);
sz := 1;
yang.Write(sz, 4);
end;
old := TFileStream.Create(name, fmOpenRead);
sz := old.Size;
yang.Write(sz, 4);
yang.CopyFrom(old, sz);
yang.Free;
old.Free;
if FileExists('tmp.tmp') then
begin
CopyFile('tmp.tmp', PChar(nm), False);
DeleteFile('tmp.tmp');
end;
end;
//открываем переписку
procedure TClient.OpenPost;
var pos, len, sz, i: integer;
old, yang : TFileStream;
Letter : sLetter;
begin
if not DirectoryExists(ExtractFilePath(Application.ExeName) + login + '\') then
CreateDir(ExtractFilePath(Application.ExeName) + login + '\');
SetCurrentDir(ExtractFilePath(Application.ExeName) + login + '\');
OutLine1.Lines.Clear;
OutLine1.Lines.AddObject(login, TPost.Create);
(TPost(OutLine1.Lines.Objects[OutLine1.Lines.Count-1])).Level := 0;
pos := OutLine1.AddChildObject(1,'Исходящие', TPost.Create);
(TPost(OutLine1.Lines.Objects[OutLine1.Lines.Count-1])).Level := 1;
if FileExists('out.cs') then
begin
old := TFileStream.Create('out.cs', fmOpenRead);
old.Read(len, 4);
for i:=0 to len-1 do
begin
old.Read(sz, 4);
old.Read(sz, 4);
old.Read(Letter, sz);
yang := TFileStream.Create('rich.tmp', fmCreate);
yang.CopyFrom(old, Letter.Sz);
yang.Free;
OutLine1.AddChildObject(pos, DateTimeToStr(Letter.Date) + ' ' + Letter.Name + ' (' + Letter.Theme +')', TPost.Create);
(TPost(OutLine1.Lines.Objects[OutLine1.Lines.Count-1])).Level := 2;
(TPost(OutLine1.Lines.Objects[OutLine1.Lines.Count-1])).Letter := Letter;
(TPost(OutLine1.Lines.Objects[OutLine1.Lines.Count-1])).Body.LoadFromFile('rich.tmp');
(TPost(OutLine1.Lines.Objects[OutLine1.Lines.Count-1])).typ := false;
(TPost(OutLine1.Lines.Objects[OutLine1.Lines.Count-1])).num := i;
DeleteFile('rich.tmp');
end;
old.Free;
end;
pos := OutLine1.AddChildObject(1, 'Входящие', TPost.Create);
(TPost(OutLine1.Lines.Objects[OutLine1.Lines.Count-1])).Level := 1;
if FileExists('in.cs') then
begin
old := TFileStream.Create('in.cs', fmOpenRead);
old.Read(len, 4);
for i:=0 to len-1 do
begin
old.Read(sz, 4);
old.Read(sz, 4);
old.Read(Letter, sz);
yang := TFileStream.Create('rich.tmp', fmCreate);
yang.CopyFrom(old, Letter.Sz);
yang.Free;
OutLine1.AddChildObject(pos, DateTimeToStr(Letter.Date) + ' ' + Letter.From + ' (' + Letter.Theme +')', TPost.Create);
(TPost(OutLine1.Lines.Objects[OutLine1.Lines.Count-1])).Level := 2;
(TPost(OutLine1.Lines.Objects[OutLine1.Lines.Count-1])).Letter := Letter;
(TPost(OutLine1.Lines.Objects[OutLine1.Lines.Count-1])).Body.LoadFromFile('rich.tmp');
(TPost(OutLine1.Lines.Objects[OutLine1.Lines.Count-1])).typ := true;
(TPost(OutLine1.Lines.Objects[OutLine1.Lines.Count-1])).num := i;
DeleteFile('rich.tmp');
end;
old.Free;
OutLine1.FullExpand;
end;
end;
//просматриваем архив
procedure TClient.OutLine1Click(Sender: TObject);
begin
SetCurrentDir(ExtractFilePath(Application.ExeName) + login + '\');
if (TPost(OutLine1.Lines.Objects[OutLine1.SelectedItem-1])).Level = 2 then
begin
BitBtn8.Enabled := true;
Panel1.Visible := true;
(TPost(OutLine1.Lines.Objects[OutLine1.SelectedItem-1])).Body.SaveToFile('rich.tmp');
RichEdit1.Lines.Clear;
RichEdit1.Lines.LoadFromFile('rich.tmp');
DeleteFile('rich.tmp');
if (TPost(OutLine1.Lines.Objects[OutLine1.Lines.Count-1])).typ = true then
begin
LabeledEdit3.Text := (TPost(OutLine1.Lines.Objects[OutLine1.SelectedItem-1])).Letter.From;
LabeledEdit3.EditLabel.Caption := 'От кого:';
end
else
begin
LabeledEdit3.Text := (TPost(OutLine1.Lines.Objects[OutLine1.SelectedItem-1])).Letter.Name;
LabeledEdit3.EditLabel.Caption := 'Кому:';
end;
LabeledEdit4.Text := (TPost(OutLine1.Lines.Objects[OutLine1.SelectedItem-1])).Letter.Theme;
end
else
begin
BitBtn8.Enabled := false;
end;
end;
//подгон размеров
procedure TClient.FormResize(Sender: TObject);
begin
OutLine1.Width := ClientWidth - OutLine1.Left - 2;
LabeledEdit4.Width := Panel1.ClientWidth - LabeledEdit4.Left - 2;
Panel1.Height := ClientHeight - OutLine1.Top - OutLine1.Height - 2;
RichEdit1.Height := Panel1.ClientHeight - LabeledEdit3.Top - LabeledEdit3.Height - 2;
end;
//открываем адресную книгу
procedure TClient.BitBtn6Click(Sender: TObject);
begin
AdrBook := TAdrBook.Create(Application);
AdrBook.Show;
BitBtn6.Enabled := false;
end;
//сохраняем ихменения после удаления письма
procedure TClient.DeleteLetter(ind : integer; inbox : boolean);
var yang, old : TFileStream;
nm : string;
sz, len, i : integer;
begin
if not DirectoryExists(ExtractFilePath(Application.ExeName) + login + '\') then
CreateDir(ExtractFilePath(Application.ExeName) + login + '\');
SetCurrentDir(ExtractFilePath(Application.ExeName) + login + '\');
if inbox = false then
begin
nm := 'out.cs';
end
else
begin
nm := 'in.cs';
end;
if FileExists(nm) then
begin
old := TFileStream.Create(nm, fmOpenRead);
yang := TFileStream.Create('tmp.tmp', fmCreate);
old.Read(sz, 4);
len := sz;
sz := sz - 1;
if sz = 0 then
begin
old.Free;
yang.Free;
DeleteFile('tmp.tmp');
DeleteFile(nm);
exit;
end;
yang.Write(sz, 4);
for i:=0 to len-1 do
begin
old.Read(sz, 4);
if i = ind then
begin
old.Seek(sz, soFromCurrent);
end
else
begin
yang.Write(sz, 4);
yang.CopyFrom(old, sz);
end;
end;
yang.Free;
old.Free;
if FileExists('tmp.tmp') then
begin
CopyFile('tmp.tmp', PChar(nm), False);
DeleteFile('tmp.tmp');
end;
end;
end;
//удалям письмо
procedure TClient.BitBtn8Click(Sender: TObject);
begin
DeleteLetter((TPost(OutLine1.Lines.Objects[OutLine1.SelectedItem-1])).num, (TPost(OutLine1.Lines.Objects[OutLine1.SelectedItem-1])).typ);
OpenPost;
BitBtn7.Enabled := false;
BitBtn8.Enabled := false;
Panel1.Visible := false;
end;
//удаляем ненужные файлы
procedure TClient.FndandDelFile;
var sr : TSearchRec;
done : integer;
tmp : String;
begin
if DirectoryExists(ExtractFilePath(Application.ExeName) + login + '\') then
begin
SetCurrentDir(ExtractFilePath(Application.ExeName) + login + '\');
tmp := '*.*';
done := FindFirst(tmp, faAnyFile, sr);
while done = 0 do
begin
if ExtractFileExt(sr.Name) = '.snd' then
DeleteFile(sr.Name);
done := FindNext(sr);
end;
FindClose(sr);
end;
end;
end.
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Buttons, ExtCtrls, Unit1, Unit3, mesage;
type
TAuthorisation = class(TForm)
LabeledEdit3: TLabeledEdit;
LabeledEdit4: TLabeledEdit;
BitBtn2: TBitBtn;
BitBtn3: TBitBtn;
procedure BitBtn3Click(Sender: TObject);
procedure BitBtn2Click(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure LabeledEdit3KeyPress(Sender: TObject; var Key: Char);
private
{ Private declarations }
public
{ Public declarations }
key : String;
end;
var
Authorisation: TAuthorisation;
const
Digit: Set of Char = ['0' .. '9'];
LetLrg: Set of Char = ['A' .. 'Z'];
LetLtl: Set of Char = ['a' .. 'z'];
implementation
{$R *.dfm}
procedure TAuthorisation.BitBtn3Click(Sender: TObject);
begin
Close;
end;
//пытаемся войти или зарегистрироваться
procedure TAuthorisation.BitBtn2Click(Sender: TObject);
var mes : TMesage;
begin
if Client.ClientSocket1.Active then
begin
mes := TMesage.Create;
if Tag = 1 then
begin
mes.mesage := M_REG; //регистрация
end
else
begin
mes.mesage := M_ENT; //вход
end;
mes.AddToMessage(LabeledEdit3.Text, true);
mes.AddToMessage(LabeledEdit4.Text, true);
mes.AddToMessage(key, false);
Client.ClientSocket1.Socket.SendText(mes.mesage);
mes.Free;
end;
end;
procedure TAuthorisation.FormActivate(Sender: TObject);
begin
if Tag = 1 then BitBtn2.Caption := 'Зарегистрироваться';
end;
//конструктор формы
procedure TAuthorisation.FormCreate(Sender: TObject);
begin
Client.r_i := true;
key := IntToStr(Client.GetKey);
end;
//закрываем форму
procedure TAuthorisation.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Client.r_i := false;
end;
//проверяем при вводе символы: должны быть только цыфры и буквы латинского алфавита
procedure TAuthorisation.LabeledEdit3KeyPress(Sender: TObject; var Key: Char);
begin
if not (Key in Digit) and not (Key in LetLrg) and not (Key in LetLtl) and not (Key = #8) then
Key:=#0;
end;
end.
unit Unit3;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Unit1, StdCtrls, Buttons, ExtCtrls, Grids;
type
sAdr = record
Login, Name, Surname : String[32];
Comment : String[255];
end;
TAdrBook = class(TForm)
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
BitBtn3: TBitBtn;
BitBtn4: TBitBtn;
StringGrid1: TStringGrid;
Panel1: TPanel;
procedure BitBtn4Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure BitBtn1Click(Sender: TObject);
procedure StringGrid1SetEditText(Sender: TObject; ACol, ARow: Integer;
const Value: String);
procedure BitBtn3Click(Sender: TObject);
procedure BitBtn2Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
procedure SaveAdr;
procedure OpenAdr;
public
{ Public declarations }
end;
var
AdrBook: TAdrBook;
implementation
{$R *.dfm}
//кнопка "Закрыть"
procedure TAdrBook.BitBtn4Click(Sender: TObject);
begin
Close;
end;
//конструктор формы
procedure TAdrBook.FormCreate(Sender: TObject);
begin
StringGrid1.Cells[0,0] := 'Логин';
StringGrid1.Cells[1,0] := 'Имя';
StringGrid1.Cells[2,0] := 'Фамилия';
StringGrid1.Cells[3,0] := 'Примечание';
OpenAdr;
end;
//сохраняе адресную книгу
procedure TAdrBook.SaveAdr;
var name : TFileStream;
sz, i, len : integer;
adr : sAdr;
begin
if not DirectoryExists(ExtractFilePath(Application.ExeName) + Client.login + '\') then
CreateDir(ExtractFilePath(Application.ExeName) + Client.login + '\');
SetCurrentDir(ExtractFilePath(Application.ExeName) + Client.login + '\');
if FileExists('adr.cs') then
begin
DeleteFile('adr.cs');
end
else
begin
name := TFileStream.Create('adr.cs', fmCreate);
end;
len := StringGrid1.RowCount - 2;
name.Write(len, 4);
for i:=1 to len do
begin
adr.Login := StringGrid1.Cells[0,i];
adr.Name := StringGrid1.Cells[1,i];
adr.Surname := StringGrid1.Cells[2,i];
adr.Comment := StringGrid1.Cells[3,i];
sz := sizeof(adr);
name.Write(sz, 4);
name.Write(adr, sz);
end;
name.Free;
if FileExists('tmp.tmp') then
begin
CopyFile('tmp.tmp', 'adr.cs', False);
DeleteFile('tmp.tmp');
end;
end;
//открываем адресную книгу
procedure TAdrBook.OpenAdr;
var name : TFileStream;
sz, i, len : integer;
adr : sAdr;
begin
if not DirectoryExists(ExtractFilePath(Application.ExeName) + Client.login + '\') then
CreateDir(ExtractFilePath(Application.ExeName) + Client.login + '\');
SetCurrentDir(ExtractFilePath(Application.ExeName) + Client.login + '\');
if FileExists('adr.cs') then
begin
name := TFileStream.Create('adr.cs', fmOpenRead);
len := StringGrid1.RowCount - 2;
name.Read(len, 4);
StringGrid1.RowCount := len + 2;
for i:=1 to len do
begin
name.Read(sz, 4);
name.Read(adr, sz);
StringGrid1.Cells[0,i] := adr.Login ;
StringGrid1.Cells[1,i] := adr.Name;
StringGrid1.Cells[2,i] := adr.Surname;
StringGrid1.Cells[3,i] := adr.Comment;
end;
name.Free;
end;
end;
//кнопк "Сохранить"
procedure TAdrBook.BitBtn1Click(Sender: TObject);
begin
SaveAdr;
end;
//добавление новой строки в книге
procedure TAdrBook.StringGrid1SetEditText(Sender: TObject; ACol,
ARow: Integer; const Value: String);
begin
if ARow = StringGrid1.RowCount - 1 then StringGrid1.RowCount := StringGrid1.RowCount + 1;
end;
//вставляем адресата в поле "Кому:"
procedure TAdrBook.BitBtn3Click(Sender: TObject);
begin
Client.LabeledEdit3.Text := StringGrid1.Cells[0,StringGrid1.Row];
end;
//удаляем запись в адресной книге
procedure TAdrBook.BitBtn2Click(Sender: TObject);
var i, j : integer;
begin
if StringGrid1.Row <> StringGrid1.RowCount -1 then
begin
for i:=StringGrid1.Row to StringGrid1.RowCount - 2 do
begin
for j:=0 to StringGrid1.ColCount - 1 do
begin
StringGrid1.Cells[j,i] := StringGrid1.Cells[j,i+1];
end;
end;
StringGrid1.RowCount := StringGrid1.RowCount - 1;
end;
end;
//закрываем адресную книгу
procedure TAdrBook.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Client.BitBtn6.Enabled := true;
end;
end.
unit mesage;
interface
const
//неизвестный идентификатор
R_ERR = -1;
//ошибки входа/регистрации
M_BAD = '#M';
R_BAD = 0;
//успешный вход
M_ENT = '#E';
R_ENT = 1;
//авторизация пользователя
M_AUT = '#A';
R_AUT = 2;
//проверка существования пользователя
M_USR = '#U';
R_USR = 3;
//подтверждение отправки письма
M_YES = '#Y';
R_YES = 4;
//отправка письма
M_SND = '#S';
R_SND = 5;
//проверка сообщений в оффлайне
M_OFF = '#X';
R_OFF = 6;
//проверка ID клиента
M_UID = '#Z';
R_UID = 7;
//завершение отправки письма
M_FIN = '#F';
R_FIN = 8;
//регистрация нового пользователя
M_REG = '#R';
R_REG = 9;
type
TMesage = class //класс для обработки сообщений
public
mesage : String; //само сообщение
function TypeMessage() : integer;
function NextMessage(size : boolean) : String;
procedure AddToMessage(str: string; size : boolean);
end;
implementation
//определяем тип сообщения
function TMesage.TypeMessage() : integer;
var str : string;
begin
str := Copy(mesage, 1, 2);
Delete(mesage, 1, 2);
Result := R_ERR;
if str = M_BAD then
begin
Result := R_BAD;
end
else
begin
if str = M_ENT then
begin
Result := R_ENT;
end
else
begin
if str = M_AUT then
begin
Result := R_AUT;
end
else
begin
if str = M_USR then
begin
Result := R_USR;
end
else
begin
if str = M_YES then
begin
Result := R_YES;
end
else
begin
if str = M_SND then
begin
Result := R_SND;
end
else
begin
if str = M_OFF then
begin
Result := R_OFF;
end
else
begin
if str = M_UID then
begin
Result := R_UID;
end
else
begin
if str = M_FIN then
begin
Result := R_FIN;
end
else
begin
if str = M_REG then Result := R_REG;
end;
end;
end;
end;
end;
end;
end;
end;
end;
end;
function TMesage.NextMessage(size : boolean) : String;
var buf : char;
len : BYTE;
begin
if size = true then
begin //узнаем параметр с учетом его размера в количестве символов
buf := mesage[1];
len := BYTE(buf);
Delete(mesage, 1, 1);
Result := Copy(mesage, 1, len);
Delete(mesage, 1, len);
end
else
begin //безразмерный параметр
Result := mesage;
end;
end;
procedure TMesage.AddToMessage(str: string; size : boolean);
var buf : char;
len : BYTE;
begin
if size = true then
begin //добавляем параметр к сообщению с учетом его размера в количестве символов
len := Length(str);
buf := char(len);
mesage := mesage + buf + str;
end
else
begin //безразмерный параметр
mesage := mesage + str;
end;
end;
end.
|
Главная
Каталог файлов
