112
const Protocol, Context, User, Password: string; var valid: Boolean;
UserRoles: TStrings);
/// <summary>
/// Обработчик события "Установка TCP соединения"
/// </summary>
procedure DSTCPServerTransportConnect(Event:
TDSTCPConnectEventObject);
/// <summary>
/// Обработчик события "Создание модуля данных"
/// </summary>
procedure DataModuleCreate(Sender: TObject);
/// <summary>
/// Обработчик события "Разрыв TCP соединения"
/// </summary>
procedure DSTCPServerTransportDisconnect(
Event: TDSTCPDisconnectEventObject);
private
{ Private declarations }
/// <summary>
/// Настройки сервера
/// </summary>
FSettings : TIniFile;
public
{ Public declarations }
/// <summary>
/// Метод определения идентификатора пользователя через логин и
пароль
/// </summary>
function GetUserKey (Login, Password : String; var Blocked : Boolean; var
UserType : Integer) : Integer;
/// <summary>
113
/// Метод выгрузки набора данных через имя таблицы (запроса)
/// </summary>
function GetTable (TableName : String) : TADOTable;
/// <summary>
/// Метод выгрузки набора данных через SQL запрос
/// </summary>
function GetQuery (SQL : String) : TADOQuery;
/// <summary>
/// Метод выполнения запроза
/// </summary>
function ExecQuery (SQL : String) : Integer;
/// <summary>
/// Метод оповещении всех активных клиентов об изменении состояния
склада
/// </summary>
procedure BroadcastStorageProductChanged;
/// <summary>
/// Метод оповещении всех активных клиентов об изменении перечня
товаров
/// </summary>
procedure BroadcastProductChanged;
/// <summary>
/// Метод отправки письма по электронной почте
/// </summary>
procedure SendMessage (Email : string; Subject : string; Msg : TStringList);
/// <summary>
/// Настройки сервера
/// </summary>
/// <link>association</link>
property Settings: TIniFile read FSettings;
end;
114
var
dmServer: TdmServer;
implementation
{$R *.dfm}
uses udssmRemoteData;
procedure TdmServer.BroadcastStorageProductChanged;
var
//
Msg : TJSONString;
begin
//
Msg := TJSONString.Create ('StorageProductChanged');
DSServer.BroadcastMessage('SystemCallback', Msg);
end;
procedure TdmServer.BroadcastProductChanged;
var
//
Msg : TJSONString;
begin
//
Msg := TJSONString.Create ('ProductChanged');
DSServer.BroadcastMessage('SystemCallback', Msg);
115
end;
function TdmServer.GetTable (TableName : String) : TADOTable;
begin
//
Result := TADOTable.Create(nil);
try
//
Result.Connection := adoConnection;
Result.TableName := TableName;
Result.Open;
except
//
on E : Exception do
begin
//
Result.Free;
raise;
end;
end;
end;
function TdmServer.GetQuery (SQL : String) : TADOQuery;
begin
//
Result := TADOQuery.Create(nil);
try
//
Result.Connection := adoConnection;
Result.SQL.Text := SQL;
Result.Open;
except
116
//
on E : Exception do
begin
//
Result.Free;
raise;
end;
end;
end;
function TdmServer.ExecQuery (SQL : String) : Integer;
var
//
R : TADOQuery;
begin
//
R := TADOQuery.Create(nil);
try
//
R.Connection := adoConnection;
R.SQL.Text := SQL;
Result := R.ExecSQL;
finally
R.Free;
end;
end;
function TdmServer.GetUserKey (Login, Password : String; var Blocked :
Boolean; var UserType : Integer) : Integer;
var
117
//
T : TADOQuery;
begin
//
Result := 0;
T := TADOQuery.Create (nil);
T.Connection := adoConnection;
T.SQL.Text := 'select * from Пользователь where Логин = ' + QuotedStr
(Login);
try
//
T.Active := true;
if (T.RecordCount > 0) then
begin
//
if T.FieldByName('Пароль').AsString = Password then
begin
//
Result := T.FieldByName('Код').AsInteger;
UserType := T.FieldByName('Код_Тип_пользователя').AsInteger;
Blocked := T.FieldByName('Блокировать_доступ').AsBoolean;
end;
end;
finally
//
end;
T.Free;
end;
118
procedure TdmServer.DataModuleCreate(Sender: TObject);
function GetDataBaseName : String;
begin
//
Result := Settings.ReadString(c_Settings_Setion_Base,
c_Settings_Setion_Base_FileName, 'Base.mdb');
if (ExtractFilePath(Result) = '') then
begin
//
Result := ExtractFilePath(Application.ExeName) + Result;
end;
end;
begin
//
FSettings := TIniFile.Create (ExtractFilePath (Application.ExeName) + '\' +
c_Settings_File);
if adoConnection.Connected = true then
begin
ShowMessage ('adoConnection.Connected = true. Приложение будет
закрыто.');
Application.Terminate;
end;
adoConnection.ConnectionString := 'Provider=Microsoft.Jet.OLEDB.4.0;' +
'Data Source=' + GetDataBaseName + ';' +
'Persist Security Info=False';
try
//
DSTCPServerTransport.Port :=
Settings.ReadInteger(c_Settings_Setion_Server,
c_Settings_Setion_Server_Port,
119
5000);
DSServer.Start;
adoConnection.Connected := True;
except
//
on E : Exception do
begin
//
Application.MainForm.Show;
MessageDlg (E.Message, mtError, [mbOK], 0);
MessageDlg ('Приложение будет закрыто.', mtInformation, [mbOK],
0);
Application.Terminate;
end;
end;
end;
procedure TdmServer.DSAuthenticationManagerUserAuthenticate(Sender:
TObject;
const Protocol, Context, User, Password: string; var valid: Boolean;
UserRoles: TStrings);
var
//
UserKey, UserTypeKey : Integer;
CI : TConnectionInfo;
Blocked : Boolean;
begin
//
UserKey := GetUserKey (User, Password, Blocked, UserTypeKey);
if (UserTypeKey <> 1) and (UserTypeKey <> 2) and (UserTypeKey <> 9)
then
120
raise Exception.Create('Данному типу пользователей доступ закрыт');
if (Blocked = True) then raise Exception.Create('Вход в систему
невозможен. Ваш аккаунт заблокирован.');
valid := UserKey > 0;
if (valid = False) then
raise Exception.Create('Неверная пара логин/пароль.');
if valid = true then
begin
CI := ConnectionList.GetConnectionKey(GetCurrentThreadId);
CI.UserKey := UserKey;
CI.UserTypeKey := UserTypeKey;
end;
end;
procedure TdmServer.DSServerClassGetClass(DSServerClass:
TDSServerClass;
var PersistentClass: TPersistentClass);
begin
//
PersistentClass := udssmRemoteData.TdssmRemoteData;
end;
procedure TdmServer.DSTCPServerTransportConnect(
Event: TDSTCPConnectEventObject);
var
//
CI : TConnectionInfo;
begin
//
CI := ConnectionList.AddConnection(Windows.GetCurrentThreadId);
CI.IP := Event.Channel.ChannelInfo.ClientInfo.IpAddress;
CI.Channel := Event.Channel;
121
end;
procedure TdmServer.DSTCPServerTransportDisconnect(
Event: TDSTCPDisconnectEventObject);
begin
//
ConnectionList.DelConnection(GetCurrentThreadId);
end;
procedure TdmServer.SendMessage (Email : string; Subject : string; Msg :
TStringList);
var
ServerAddress : String; ServerPort : Integer; Login : String; Password : String;
Q : TADOQuery;
IdSMTP : TIdSMTP;
IdMsg : TIdMessage;
IdText : TIdText;
begin
//
Q := dmServer.GetQuery('select * from Параметры where Код = 1');
try
ServerAddress := Trim(Q.FieldByName ('Email_Адрес_сервера').Value);
Login := Trim(Q.FieldByName ('Email').Value);
Password := Q.FieldByName ('Email_Пароль').Value;
ServerPort := Q.FieldByName ('Email_Порт').AsInteger;
Email := Trim(Email);
if (Email = '') then
raise Exception.Create('Email получателя не задан');
if (ServerPort <= 0) then
raise Exception.Create('Порт почтового сервера не задан. См.
"Параметры"');
if (ServerAddress = '') then