364 lines
9.8 KiB
ObjectPascal
364 lines
9.8 KiB
ObjectPascal
unit baseconnection;
|
|
|
|
{$mode ObjFPC}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, extTypes,commandcol, Contnrs, cgiDM;
|
|
type
|
|
{ TBaseConnection }
|
|
TBaseConnection=class;
|
|
|
|
|
|
TBaseConnection=class(TThread)
|
|
private
|
|
fOwner:TComponent;
|
|
fLogger: TLogger;
|
|
fConnectionID: string;
|
|
fTimeout: integer;
|
|
fProcessor: TNIDBDM;
|
|
fJournal: TStrings;
|
|
Commands: TStrings;
|
|
DoneCommands: TList;
|
|
fCreated,
|
|
fCommandReceived,
|
|
fCommandCompleted: TDateTime;
|
|
nCommandComplete: integer;
|
|
nCommandReceived: integer;
|
|
nCommandReady: integer;
|
|
nErrors: integer;
|
|
fCheckConnect: boolean;
|
|
procedure CleanDone;
|
|
function getCommand(index: integer): TCommand;
|
|
public
|
|
Host: string;
|
|
port: integer;
|
|
DataBase: string;
|
|
User: string;
|
|
UserID: integer;
|
|
LastAccess: TDateTime;
|
|
procedure Log(ALevel:TLogLevel;sender: TObject; msg: string);
|
|
procedure LogError(Sender: TObject; e: Exception; Command: string);
|
|
|
|
property Created: TDateTime read fCreated;
|
|
property LastReceive: TDateTime read fCommandReceived;
|
|
property LastComplete: TDateTime read fCommandCompleted;
|
|
property CountReceived: integer read nCommandReceived;
|
|
property CountCompleted: integer read nCommandComplete;
|
|
property CountReady: integer read nCommandReady;
|
|
property CountErrors: integer read nErrors;
|
|
property Owner: TComponent read fOwner;
|
|
property ConnectionID: string read fConnectionID;
|
|
property Processor: TNIDBDM read fProcessor;
|
|
procedure Init;
|
|
constructor Create(AOwner: TComponent;ATimeOut: integer; aLogger: TLogger; ID: string='');
|
|
destructor Destroy; override;
|
|
// CommandID,Param,ACommand,Fields,iParam.Data
|
|
function AddCommand(ACode: DWORD; iParam: QWORD; ACommandClass,ACommandName: string; Arguments: TStrings; intArgs: TParamArray; CmdData: TStream; out ID: string; out retCode:DWORD; out Errors: TStrings): boolean;
|
|
function RunCommand(ACommand: TCommand): boolean;
|
|
function FindCommand(IDCommand: string): TCommand;
|
|
function CommandCount: integer;
|
|
procedure Idle;
|
|
procedure SetIdle;
|
|
procedure Execute; override;
|
|
function ProcessOptionValues(ReportName,ParamName: string; ParamValues: TStrings; out Answer: string; out RetValue: QWORD; out OptionValues: TStrings): boolean;
|
|
class function newID: string;
|
|
function calchash(data: TStream): string;
|
|
property Journal: TStrings read fJournal;
|
|
property AllCommands[index: integer]: TCommand read getCommand;
|
|
end;
|
|
|
|
implementation
|
|
uses
|
|
ConnectionsDmUnit;
|
|
{ TBaseConnection }
|
|
function TBaseConnection.calchash(data: TStream): string;
|
|
begin
|
|
result := (Owner as TConnectionsDM).CalcHash(data);
|
|
end;
|
|
|
|
procedure TBaseConnection.Init;
|
|
begin
|
|
Processor.connection.RemoteHost:=Host;
|
|
Processor.connection.RemotePort:=Port;
|
|
Processor.connection.Database:=DataBase;
|
|
Processor.OpenConnection;
|
|
end;
|
|
|
|
|
|
constructor TBaseConnection.Create(AOwner: TComponent; ATimeOut: integer;
|
|
aLogger: TLogger; ID: string);
|
|
begin
|
|
inherited Create(true);
|
|
if ID='' then
|
|
fConnectionID:=newID
|
|
else
|
|
fConnectionID:=ID;
|
|
fTimeout:=ATimeOut;
|
|
fOwner := AOwner;
|
|
flogger := ALogger;
|
|
fProcessor:=TNIDBDM.Create(nil);
|
|
fProcessor.Name := 'NIDB_'+fConnectionID;
|
|
fProcessor.logger:=aLogger;
|
|
Commands:=TStringList.Create;
|
|
DoneCommands:=TList.Create;
|
|
fCreated := now();
|
|
fCommandReceived := 0;
|
|
fCommandCompleted := 0;
|
|
nCommandComplete:=0;
|
|
nCommandReceived:=0;
|
|
nCommandReady:=0;
|
|
nErrors:=0;
|
|
fJournal := TStringList.Create;
|
|
|
|
end;
|
|
|
|
destructor TBaseConnection.Destroy;
|
|
begin
|
|
log(mtExtra,self,'Destroy');
|
|
Processor.Free;
|
|
Commands.Free;
|
|
DoneCommands.Free;
|
|
fJournal.free;
|
|
inherited;
|
|
end;
|
|
|
|
function TBaseConnection.AddCommand(ACode: DWORD; iParam: QWORD; ACommandClass,
|
|
ACommandName: string; Arguments: TStrings; intArgs: TParamArray;
|
|
CmdData: TStream; out ID: string; out retCode: DWORD; out Errors: TStrings
|
|
): boolean;
|
|
var
|
|
cc: TCommandClass;
|
|
cmd: TCommand;
|
|
begin
|
|
Errors := nil;
|
|
ID := '';
|
|
retCode := 0;
|
|
log(mtDebug,self,'AddCommand '+ACommandClass+ ' '+ACommandName);
|
|
fCommandReceived:=Now();
|
|
cc := TCommandCollection.Find(ACommandClass,ACommandName);
|
|
if assigned(cc) then
|
|
begin
|
|
cmd := cc.Create(self.newID, self.Processor,ACommandName,@log,User,UserID);
|
|
cmd.AccessTime:=NOW();
|
|
try
|
|
result := cmd.ParseCommand(ACode,iParam,ACommandName,Arguments,intArgs,CmdData, Errors);
|
|
|
|
except on e: Exception do
|
|
begin
|
|
LogError(self,e,format('ParseCommand(%s,%s)',[ACommandClass, ACommandName]));
|
|
result := false;
|
|
end;
|
|
end;
|
|
if result then
|
|
begin
|
|
|
|
Commands.AddObject(ACommandName,cmd);
|
|
ID := cmd.CommandID;
|
|
retCode := Commands.Count;
|
|
log(mtInfo,cmd, format('%s(%s) %s поставлена в очередь %d',[cmd.CommandName, cmd.CommandSubClass, cmd.CommandID,Commands.Count]));
|
|
end
|
|
else
|
|
begin
|
|
ID := 'неверные параметры запроса';
|
|
retCode := ErrorArguments;
|
|
log(mtError,cmd, format('%s(%s) %s неверные параметры запроса %s',[cmd.CommandName, cmd.CommandSubClass, cmd.CommandID, Errors.CommaText]));
|
|
|
|
inc(nErrors);
|
|
cmd.Error:=true;
|
|
cmd.Done;
|
|
DoneCommands.Add(cmd);
|
|
end;
|
|
inc(nCommandReceived);
|
|
|
|
|
|
|
|
end
|
|
else
|
|
begin
|
|
inc(nErrors);
|
|
result := false;
|
|
ID := format('Неизвестная команда %s(%s)',[ACommandClass, ACommandName]);
|
|
log(mtWarning,self,ID);
|
|
retCode := ErrorCommand;
|
|
end;
|
|
end;
|
|
|
|
function TBaseConnection.RunCommand(ACommand: TCommand): boolean;
|
|
begin
|
|
log(mtDebug,self,format('Запуск на исполнение %s_%s %s',[ACommand.CommandName,ACommand.CommandSubClass, ACommand.CommandID]));
|
|
try
|
|
ACommand.doRun();
|
|
log(mtDebug,Self,'Завершена '+ACommand.CommandID);
|
|
|
|
except on e: Exception do
|
|
begin
|
|
LogError(self,e,format('Command %s',[ACommand.CommandID]));
|
|
end;
|
|
end;
|
|
fCommandCompleted:=Now();
|
|
inc(nCommandReady);
|
|
end;
|
|
|
|
function TBaseConnection.FindCommand(IDCommand: string): TCommand;
|
|
var
|
|
i: integer;
|
|
begin
|
|
for i := 0 to Commands.Count-1 do
|
|
if (Commands.Objects[i] as TCommand).CommandID=IDCommand then
|
|
begin
|
|
result := Commands.Objects[i] as TCommand;
|
|
result.AccessTime:=now();
|
|
exit;
|
|
end;
|
|
for i := DoneCommands.Count-1 downto 0 do
|
|
if TCommand(DoneCommands[i]).CommandID=IDCommand then
|
|
begin
|
|
result := TCommand(DoneCommands[i]);
|
|
result.AccessTime:=now();
|
|
exit;
|
|
end;
|
|
result := nil;
|
|
end;
|
|
|
|
function TBaseConnection.CommandCount: integer;
|
|
begin
|
|
result := Commands.Count;
|
|
end;
|
|
|
|
procedure TBaseConnection.Idle;
|
|
var
|
|
d: TDateTime;
|
|
begin
|
|
fCheckConnect:=false;
|
|
d := Created;
|
|
if LastAccess>d then d := LastAccess;
|
|
if (ConnectionID<>'0') and ((now()-d)*24*60>fTimeout) then
|
|
begin
|
|
log(mtInfo,self,'TIMEOUT');
|
|
terminate;
|
|
end
|
|
else
|
|
fProcessor.ExecuteSQL('SELECT 1');
|
|
end;
|
|
|
|
procedure TBaseConnection.SetIdle;
|
|
begin
|
|
fCheckConnect:=true;
|
|
end;
|
|
|
|
procedure TBaseConnection.CleanDone;
|
|
var
|
|
i: integer;
|
|
cmd: TCommand;
|
|
begin
|
|
for i := DoneCommands.Count-1 downto 0 do
|
|
begin
|
|
cmd := TCommand(DoneCommands[i]);
|
|
if cmd.isDone or (now()-cmd.AccessTime > cmd.TimeOut) then
|
|
begin
|
|
cmd.free;
|
|
DoneCommands.Delete(i);
|
|
Dec(nCommandReady);
|
|
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TBaseConnection.getCommand(index: integer): TCommand;
|
|
begin
|
|
result := (Commands.Objects[index] as TCommand);
|
|
end;
|
|
|
|
procedure TBaseConnection.Log(ALevel: TLogLevel; sender: TObject; msg: string);
|
|
begin
|
|
case ALevel of
|
|
mtError: fJournal.AddObject('ERROR:'#09+msg, TObject(PtrInt(trunc(now()*24*60*60*10))));
|
|
mtWarning: fJournal.AddObject('WARNING:'#09+msg, TObject(PtrInt(trunc(now()*24*60*60*10))));
|
|
mtInfo: fJournal.AddObject('INFO:'#09+msg, TObject(PtrInt(trunc(now()*24*60*60*10))));
|
|
end;
|
|
if assigned(fLogger) then
|
|
flogger(ALevel,sender,msg);
|
|
end;
|
|
|
|
procedure TBaseConnection.LogError(Sender: TObject; e: Exception;
|
|
Command: string);
|
|
begin
|
|
log(mtError,Sender,format('%s вызвала ошибку %s(%s) ',[Command, e.classname,e.message]));
|
|
end;
|
|
|
|
procedure TBaseConnection.Execute;
|
|
var
|
|
cmd: TCommand;
|
|
begin
|
|
log(mtExtra,self,'started');
|
|
while not terminated do
|
|
begin
|
|
while Commands.Count>0 do
|
|
begin
|
|
cmd := Commands.Objects[0] as TCommand;
|
|
try
|
|
RunCommand(cmd);
|
|
finally
|
|
Commands.Delete(0);
|
|
DoneCommands.Add(cmd);
|
|
end;
|
|
end;
|
|
CleanDone;
|
|
if fCheckConnect then Idle;
|
|
sleep(200);
|
|
end;
|
|
log(mtExtra,self,'finished');
|
|
end;
|
|
|
|
function TBaseConnection.ProcessOptionValues(ReportName, ParamName: string;
|
|
ParamValues: TStrings; out Answer: string; out RetValue: QWORD; out
|
|
OptionValues: TStrings): boolean;
|
|
var
|
|
c: TCommand;
|
|
tmp: TStrings;
|
|
cc: TCommandClass;
|
|
begin
|
|
cc := TCommandCollection.Find('report',Reportname);
|
|
if assigned(cc) then
|
|
try
|
|
with cc.Create('', self.Processor,ReportName,fLogger,User,UserID) do
|
|
try
|
|
ParseCommand(0,0,ReportName,ParamValues,[],nil,tmp);
|
|
if assigned(tmp) then FreeAndNil(tmp);
|
|
result := ProcessOptionValues(ParamName,answer,RetValue,OptionValues);
|
|
finally
|
|
free
|
|
end;
|
|
|
|
except on e: Exception do
|
|
begin
|
|
LogError(self,e,format('ProcessOptionValues(report=%s,param=%s)',[ReportName,ParamName]));
|
|
result := false;
|
|
Answer := e.Message;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
result := false;
|
|
answer := 'Отчет не найден '+ReportName;
|
|
end;
|
|
end;
|
|
|
|
class function TBaseConnection.newID: string;
|
|
var
|
|
g: TGUID;
|
|
i: integer;
|
|
begin
|
|
createguid(g);
|
|
result := inttohex(g.D1,8)+inttohex(g.D2,4)+inttohex(g.D3,4);
|
|
for i := 0 to 7 do
|
|
result := result + inttohex(g.D4[i],2);
|
|
end;
|
|
|
|
|
|
|
|
end.
|
|
|