652 lines
17 KiB
ObjectPascal
652 lines
17 KiB
ObjectPascal
unit ConnectionsDmUnit;
|
|
|
|
{$mode ObjFPC}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, Contnrs, SysUtils, types, process, cgiDM, reportDMUnit, LNet,eventlog,
|
|
lnetbase,tcpserver, tcpthreadhelper, DCPsha1, extTypes,syncobjs, baseconnection,LazLoggerBase,LazLogger;
|
|
|
|
type
|
|
|
|
{ TCommand }
|
|
|
|
|
|
|
|
|
|
|
|
{ TConnectionsDM }
|
|
|
|
TConnectionsDM = class(TDataModule)
|
|
Hash: TDCP_sha1;
|
|
Process1: TProcess;
|
|
procedure DataModuleCreate(Sender: TObject);
|
|
procedure DataModuleDestroy(Sender: TObject);
|
|
private
|
|
MainCon: TNIDBDM;
|
|
conlist: TList;
|
|
Input: TServerMainThread;
|
|
fDataHost: string;
|
|
fDataPort: integer;
|
|
fDataBase: string;
|
|
fServicePort: integer;
|
|
fLogger: TEventLog;
|
|
fTimeOut: integer;
|
|
fRunning: boolean;
|
|
function getConnection(ID: string): TBaseConnection;
|
|
function NewConnection: TBaseConnection;
|
|
procedure Remove(con: TBaseConnection); overload;
|
|
procedure Remove(ID: string); overload;
|
|
procedure ClearConnections;
|
|
procedure ClearTerminated;
|
|
procedure ConnectNew(aSocket: TLSocket);
|
|
function ProcessLogin(UserName,UserPassword: string; out UserID: integer):boolean;
|
|
function ProcessArguments(ReportName: string; out RetValue: QWORD;out ReportTitle: string; out rValues: TStrings): boolean;
|
|
function ProcessReports(out rValues: TStrings): boolean;
|
|
function ProcessOptionValues(ReportName,ParamName: string; ParamValues: TStrings; out Answer: string; out RetValue: QWORD; out OptionValues: TStrings): boolean;
|
|
procedure LoadConfig;
|
|
|
|
public
|
|
property DataHost: string read fDataHost;
|
|
property DataPort: integer read fDataPort;
|
|
property DataBase: string read fDataBase;
|
|
property Logger: TEventLog read fLogger write fLogger;
|
|
procedure Log(ALevel: TLogLevel; Sender: TObject; msg: string);
|
|
procedure InitBaseCon;
|
|
procedure Start;
|
|
procedure Stop;
|
|
procedure Idle(Sender: TObject);
|
|
property Running: boolean read fRunning;
|
|
function ProcessRequest(Sender: TMainThread;
|
|
const CommandID:DWORD; const Param:QWord; const ACommand: string; const Fields: TStrings; const iParams: TParamArray; const Data: TStream;
|
|
out Code: DWORD; out RetValue: QWord; out Answer: string; out rValues: TStrings; out iValues: TParamArray; out ByteData: TStream ): boolean;
|
|
constructor CreateWithLog(ALogger: TEventLog);
|
|
procedure FillTemplates(RepList: TStrings);
|
|
procedure EditTemplate(ReportID: integer);
|
|
function CalcHash(Data: TStream): string;
|
|
end;
|
|
|
|
var
|
|
ConnectionsDM: TConnectionsDM;
|
|
|
|
implementation
|
|
uses
|
|
xpUtilUnit, strutils, xpAccessUnit, inifiles,commandcol, cgiReport;
|
|
{$R *.lfm}
|
|
|
|
|
|
|
|
|
|
{ TConnectionsDM }
|
|
|
|
procedure TConnectionsDM.DataModuleCreate(Sender: TObject);
|
|
begin
|
|
fRunning := false;
|
|
conList := TList.Create;
|
|
MainCon := TNIDBDM.CreateWithLogger(@log);
|
|
LoadConfig;
|
|
input := TServerMainThread.Create(@log,fServicePort,@ProcessRequest);
|
|
end;
|
|
|
|
procedure TConnectionsDM.DataModuleDestroy(Sender: TObject);
|
|
begin
|
|
log(mtExtra,Sender,'Destroy');
|
|
ClearConnections;
|
|
|
|
if fRunning then
|
|
begin
|
|
Input.Terminate;
|
|
Input.WaitFor;
|
|
end;
|
|
Input.Free;
|
|
MainCon.Free;
|
|
conList.Free;
|
|
|
|
end;
|
|
|
|
function TConnectionsDM.getConnection(ID: string): TBaseConnection;
|
|
var
|
|
i: integer;
|
|
begin
|
|
for i := 0 to conList.Count-1 do
|
|
if TBaseConnection(conlist[i]).ConnectionID=ID then
|
|
begin
|
|
result := TBaseConnection(conlist[i]);
|
|
result.LastAccess := NOW();
|
|
exit;
|
|
end;
|
|
result := nil;
|
|
end;
|
|
|
|
function TConnectionsDM.NewConnection: TBaseConnection;
|
|
var
|
|
g: TGUID;
|
|
s: string;
|
|
i: integer;
|
|
begin
|
|
result := TBaseConnection.Create(self,fTimeOut,@Log);
|
|
conlist.add(result);
|
|
result.Host:=DataHost;
|
|
result.port:=DataPort;
|
|
result.DataBase:=DataBase;
|
|
log(mtDebug, self, 'New '+result.ConnectionID);
|
|
result.Init;
|
|
|
|
end;
|
|
|
|
procedure TConnectionsDM.Remove(con: TBaseConnection);
|
|
var
|
|
i: integer;
|
|
begin
|
|
|
|
for i := conList.Count-1 downto 0 do
|
|
if TBaseConnection(conlist[i])=con then
|
|
begin
|
|
log(mtDebug,self,'terminate '+con.ConnectionID);
|
|
TBaseConnection(conlist[i]).terminate;
|
|
exit;
|
|
end;
|
|
end;
|
|
|
|
procedure TConnectionsDM.Remove(ID: string);
|
|
var
|
|
i: integer;
|
|
begin
|
|
|
|
for i := conList.Count-1 downto 0 do
|
|
if TBaseConnection(conlist[i]).ConnectionID=ID then
|
|
begin
|
|
log(mtDebug,self,'terminate '+ID);
|
|
TBaseConnection(conlist[i]).terminate;
|
|
exit;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TConnectionsDM.ClearConnections;
|
|
var
|
|
i: integer;
|
|
con: TBaseConnection;
|
|
begin
|
|
log(mtDebug, self,'ClearConnections');
|
|
for i := 0 to conList.Count-1 do
|
|
begin
|
|
con := TBaseConnection(conlist[i]);
|
|
con.terminate;
|
|
con.WaitFor;
|
|
con.Free;
|
|
end;
|
|
conList.Clear;
|
|
end;
|
|
|
|
procedure TConnectionsDM.ClearTerminated;
|
|
var
|
|
i: integer;
|
|
con: TBaseConnection;
|
|
begin
|
|
for i := conlist.Count-1 downto 0 do
|
|
begin
|
|
con := TBaseConnection(conlist[i]);
|
|
if con.Finished then
|
|
begin
|
|
log(mtDebug, self,'Destroy terminated '+con.ConnectionID);
|
|
con.free;
|
|
conlist.delete(i);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TConnectionsDM.ConnectNew(aSocket: TLSocket);
|
|
begin
|
|
// aSocket
|
|
end;
|
|
|
|
function TConnectionsDM.ProcessRequest(Sender: TMainThread;
|
|
const CommandID: DWORD; const Param: QWord; const ACommand: string;
|
|
const Fields: TStrings; const iParams: TParamArray; const Data: TStream; out
|
|
Code: DWORD; out RetValue: QWord; out Answer: string; out rValues: TStrings;
|
|
out iValues: TParamArray; out ByteData: TStream): boolean;
|
|
var
|
|
UserID: integer;
|
|
con: TBaseConnection;
|
|
userName,conID,cmdID: string;
|
|
cmd: TCommand;
|
|
begin
|
|
try
|
|
log(mtInfo, Self,'Process Request '+ACommand);
|
|
ClearTerminated;
|
|
result := false;
|
|
RetValue := 0;
|
|
Code := 0;
|
|
rValues := nil;
|
|
ByteData := nil;
|
|
setLength(iValues,0);
|
|
if ACommand='stop' then
|
|
begin
|
|
ClearConnections;
|
|
Input.Terminate;
|
|
fRunning:=false;
|
|
result := true;
|
|
exit;
|
|
end;
|
|
if ACommand='help' then
|
|
begin
|
|
result := true;
|
|
rValues := TStringList.Create;
|
|
rvalues.Add('"help"');
|
|
rvalues.Add('"version"');
|
|
rValues.add('"reports"');
|
|
rValues.add('{action:"arguments",params:["name"]}');
|
|
rValues.add('{action:"login",params:["user","password"]}');
|
|
rValues.add('{action:"logout",params:["connect"]}');
|
|
rValues.add('{action:"test",params:["connect"]}');
|
|
rValues.add('{action:"option_values",params:["connect","report","name"]}');
|
|
rValues.add('{action:"report",params:["connect","name"]}');
|
|
rValues.add('{action:"status",params:["connect","operation"]}');
|
|
rValues.add('{action:"result",params:["connect","operation"]}');
|
|
end;
|
|
if ACommand='version' then
|
|
begin
|
|
result := true;
|
|
Answer := extTypes.version;
|
|
exit;
|
|
end;
|
|
if ACommand='arguments' then
|
|
begin
|
|
result := ProcessArguments(Fields.Values['name'],RetValue,Answer,rValues);
|
|
if not result then
|
|
begin
|
|
Code := ErrorArguments;
|
|
end;
|
|
exit;
|
|
end;
|
|
if ACommand='reports' then
|
|
begin
|
|
result := ProcessReports(rValues);
|
|
exit;
|
|
end;
|
|
if ACommand='login' then
|
|
begin
|
|
UserName :=Fields.Values['user'];
|
|
if ProcessLogin(UserName,EncryptText(Fields.Values['password'],Hash),UserID) then
|
|
begin
|
|
con := NewConnection;
|
|
con.User:=UserName;
|
|
con.UserID := UserID;
|
|
Answer := con.ConnectionID;
|
|
con.Start;
|
|
result := true;
|
|
end
|
|
else
|
|
begin
|
|
Answer := 'Invalid password';
|
|
code := ErrorLogin;
|
|
end;
|
|
exit;
|
|
end;
|
|
conID := fields.Values['connect'];
|
|
con := getConnection(conID);
|
|
|
|
if not assigned(con) or (con.Finished) then
|
|
begin
|
|
Answer := 'invalid connectionID';
|
|
code := ErrorConnect;
|
|
exit;
|
|
end;
|
|
if ACommand='test' then
|
|
begin
|
|
result := true;
|
|
answer := 'OK';
|
|
exit;
|
|
end;
|
|
if ACommand='logout' then
|
|
begin
|
|
result := true;
|
|
Answer := 'OK';
|
|
Remove(con.ConnectionID);
|
|
exit;
|
|
end;
|
|
if ACommand='connectStatus' then
|
|
begin
|
|
result := true;
|
|
SetLength(iValues,7);
|
|
iValues[0] := round(con.Created*24*60*60*100);
|
|
iValues[1] := round(con.LastReceive*24*60*60*100);
|
|
iValues[2] := round(con.LastComplete*24*60*60*100);
|
|
iValues[3] := con.CountReceived;
|
|
iValues[4] := con.CountCompleted;
|
|
iValues[5] := con.CountReady;
|
|
iValues[6] := con.CountErrors;
|
|
Answer := 'OK';
|
|
exit;
|
|
end;
|
|
if (ACommand='option_values') then
|
|
begin
|
|
result := con.ProcessOptionValues(fields.Values['report'],fields.Values['name'],fields,Answer,RetValue,rValues);
|
|
exit;
|
|
end;
|
|
|
|
if (ACommand='status') or (ACommand='result') then
|
|
begin
|
|
cmdID := fields.Values['operation'];
|
|
cmd := con.FindCommand(cmdID);
|
|
if not assigned(cmd) then
|
|
begin
|
|
Answer := 'command not found';
|
|
Code := ErrorCommand;
|
|
exit;
|
|
end;
|
|
if ACommand='status' then
|
|
begin
|
|
Answer := cmd.currentStage;
|
|
if assigned(cmd.Results) then
|
|
cmd.Results.AssignTo(Code,RetValue,Answer,rValues);
|
|
code := cmd.Status;
|
|
if (code=StatusComplete) and assigned(cmd.Results.Data) then
|
|
RetValue:=cmd.Results.Data.Size
|
|
else
|
|
RetValue := 0;
|
|
result := true;
|
|
exit;
|
|
end;
|
|
if ACommand='result' then
|
|
begin
|
|
if cmd.Status=StatusComplete then
|
|
begin
|
|
cmd.Results.AssignTo(Code,RetValue,Answer,rValues,iValues,ByteData);
|
|
cmd.Done;
|
|
result := true;
|
|
end
|
|
else
|
|
begin
|
|
Code := ErrorComplete;
|
|
Answer:='command not complete';
|
|
end;
|
|
exit;
|
|
end;
|
|
|
|
end;
|
|
result := con.AddCommand(CommandID,Param,ACommand,Fields.Values['name'],Fields,iValues,Data,Answer,Code, rValues);
|
|
|
|
except on e: Exception do
|
|
begin
|
|
result := false;
|
|
Answer := e.message;
|
|
Code := ErrorInternal;
|
|
log(mtError,self,format('ProcessRequest () -> %s(%s)',[e.ClassName,e.Message]));
|
|
end;
|
|
end;
|
|
|
|
end;
|
|
|
|
constructor TConnectionsDM.CreateWithLog(ALogger: TEventLog);
|
|
begin
|
|
fLogger:=Alogger;
|
|
inherited Create(nil);
|
|
end;
|
|
|
|
procedure TConnectionsDM.FillTemplates(RepList: TStrings);
|
|
var
|
|
asql: string;
|
|
begin
|
|
asql :=
|
|
'select r.xp_rpt_id,r.name, c.cgi_name from xp_report r '+
|
|
' join xp_report_cgi c on c.xp_rpt_id=r.xp_rpt_id '+
|
|
'order by r.name ';
|
|
with MainCon.GetData(asql) do
|
|
try
|
|
while not eof do
|
|
begin
|
|
RepList.AddObject(format('%s (%s)',[fieldbyname('name').asString, FieldByName('cgi_name').asString]),TObject(ptrint(fieldbyname('xp_rpt_id').asInteger)));
|
|
next;
|
|
end;
|
|
finally
|
|
free;
|
|
end;
|
|
end;
|
|
function TConnectionsDM.CalcHash(Data: TStream): string;
|
|
var
|
|
Digest: packed array[0..19] of byte;
|
|
i,l: integer;
|
|
b: array[0..$100000-1] of byte;
|
|
begin
|
|
Result := '';
|
|
Hash.Init;
|
|
Data.Seek(0,soFromBeginning);
|
|
repeat
|
|
l := Data.Read(b,sizeof(b));
|
|
Hash.Update(b,l);
|
|
until l=0;
|
|
Data.Seek(0,soFromBeginning);
|
|
Hash.Final(Digest);
|
|
Hash.Burn;
|
|
for i:= 0 to 19 do
|
|
Result := Result + AnsiString(IntToHex(Digest[i], 2));
|
|
end;
|
|
|
|
procedure TConnectionsDM.EditTemplate(ReportID: integer);
|
|
var
|
|
asql: string;
|
|
RName: string;
|
|
con: TBaseConnection;
|
|
cc: TCommandClass;
|
|
cmd: TReportCommand;
|
|
begin
|
|
asql := format('select cgi_name from xp_report_cgi where xp_rpt_id=%d',[ReportID]);
|
|
RName := MainCon.QueryValue(asql);
|
|
cc := TCommandCollection.Find('report',RName);
|
|
cmd := cc.Create('', MainCon,RName,@Log,'',0) as TReportCommand;
|
|
try
|
|
cmd.ReportID := ReportID;
|
|
cmd.ReportName:=RName;
|
|
cmd.FillDefaults;
|
|
cmd.EditTemplate(@CalcHash);
|
|
finally
|
|
cmd.free;
|
|
end;
|
|
end;
|
|
|
|
function TConnectionsDM.ProcessLogin(UserName, UserPassword: string; out UserID: integer): boolean;
|
|
var
|
|
ASQL: string;
|
|
begin
|
|
Result := MainCon.CheckUser(UserName,UserPassword,UserID);
|
|
end;
|
|
|
|
function TConnectionsDM.ProcessArguments(ReportName: string; out
|
|
RetValue: QWORD; out ReportTitle: string; out rValues: TStrings): boolean;
|
|
var
|
|
ASQL: string;
|
|
begin
|
|
result := false;
|
|
rValues := TStringList.Create;
|
|
ASQL := format(
|
|
'select r.xp_rpt_id,r.name as reportname,p.name as paramname, '+
|
|
'case p.type '+
|
|
' when 0 then ''A'' '+
|
|
' when 1 then ''ID'' '+
|
|
' when 2 then ''N'' '+
|
|
' when 3 then ''F'' '+
|
|
' when 4 then ''D'' '+
|
|
' when 5 then ''T'' '+
|
|
' when 6 then ''B'' '+
|
|
' when 17 then ''IDS'' '+
|
|
'end as type, '+
|
|
|
|
'case coalesce(p.required,false) or p.def_val is null '+
|
|
'when true then ''!'' '+
|
|
'else p.def_val '+
|
|
'end as def_val, '+
|
|
'string_agg(''"'' || p.argument || ''"'','';'') as arguments, '+
|
|
'p.description '+
|
|
'from xp_report_cgi c '+
|
|
' join xp_report r on r.xp_rpt_id=c.xp_rpt_id '+
|
|
' left join ( '+
|
|
' select xp_rpt_id, type,name, required,def_val,description,fill_order, unnest(coalesce(arguments,array[null])) as argument '+
|
|
' from xp_report_params '+
|
|
')p on p.xp_rpt_id=r.xp_rpt_id '+
|
|
'where c.cgi_name=%0:s '+
|
|
'group by r.xp_rpt_id,r.name, p.name,p.type,p.required, p.def_val,p.description, p.fill_order '+
|
|
'order by p.fill_order, p.name ',
|
|
[TNIDBDM.StringAsSQL(ReportName)]);
|
|
with MainCon.GetData(ASQL) do
|
|
try
|
|
while not eof do
|
|
begin
|
|
ReportTitle := fieldByName('reportname').AsString;
|
|
rValues.Add(format('{"name":"%s","type":"%s","default":"%s","arguments":[%s],"description":"%s"}',
|
|
[fieldbyname('paramname').asString, fieldbyname('type').asString,fieldbyname('def_val').asString,fieldbyname('arguments').asString, TNIDBDM.StringAsJSON(fieldbyname('description').asString)]));
|
|
result := true;
|
|
next;
|
|
end;
|
|
finally
|
|
free;
|
|
end;
|
|
|
|
end;
|
|
|
|
function TConnectionsDM.ProcessReports(out rValues: TStrings): boolean;
|
|
var
|
|
ASQL: string;
|
|
begin
|
|
rValues := TStringList.Create;
|
|
ASQL :=
|
|
'select c.cgi_name,r.name as rep_name '+
|
|
'from xp_report_cgi c '+
|
|
' join xp_report r on r.xp_rpt_id=c.xp_rpt_id '+
|
|
'order by 2 ';
|
|
with MainCon.GetData(ASQL) do
|
|
try
|
|
while not eof do
|
|
begin
|
|
rValues.Add(format('{"name":"%s","title":"%s"}',[fieldbyname('cgi_name').asString, TNIDBDM.StringAsJSON(fieldbyname('rep_name').asString)]));
|
|
result := true;
|
|
next;
|
|
end;
|
|
finally
|
|
free;
|
|
end;
|
|
result := true;
|
|
end;
|
|
|
|
function TConnectionsDM.ProcessOptionValues(ReportName, ParamName: string;
|
|
ParamValues: TStrings; out Answer: string; out RetValue: QWORD; out
|
|
OptionValues: TStrings): boolean;
|
|
var
|
|
ASQL: string;
|
|
code: string;
|
|
i: integer;
|
|
begin
|
|
ASQL := format(
|
|
'select source from xp_report_params p '+
|
|
' join xp_report_cgi c on c.xp_rpt_id=p.xp_rpt_id '+
|
|
'where c.cgi_name=%s and p.name=%s and p.type= in (1,17) ',
|
|
[TNIDBDM.StringAsSQL(ReportName), TNIDBDM.StringAsSQL(ParamName)]);
|
|
code := MainCon.QueryValue(ASQL);
|
|
TNIDBDM.UpdateWithArguments(code,ParamValues);
|
|
if pos('{',code)>0 then
|
|
begin
|
|
result := false;
|
|
Answer := 'недостаточно данных';
|
|
exit;
|
|
end;
|
|
ASQL := code;
|
|
OptionValues := TStringList.Create;
|
|
if ASQL<>'' then
|
|
with MainCon.GetData(ASQL) do
|
|
try
|
|
while not eof do
|
|
begin
|
|
OptionValues.Add(format('{"id":"%d","value":"%s"}',
|
|
[Fields[0].AsInteger, TNIDBDM.StringAsJSON(Fields[1].AsString)]));
|
|
next;
|
|
end;
|
|
finally
|
|
free;
|
|
end;
|
|
result := true;
|
|
end;
|
|
|
|
|
|
procedure TConnectionsDM.LoadConfig;
|
|
var
|
|
ini: TIniFile;
|
|
inifile: string;
|
|
begin
|
|
inifile := ChangeFileExt(ParamStr(0),'.ini');
|
|
ini := TIniFile.Create(inifile);
|
|
try
|
|
fDataHost := ini.ReadString('DATA','host','localhost');
|
|
fDataPort := ini.ReadInteger('DATA','port',7079);
|
|
fDataBase:= ini.ReadString('DATA','database','');
|
|
fServicePort := ini.ReadInteger('PARAMS','port',6543);
|
|
fTimeOut:=ini.ReadInteger('PARAMS','timeout',CONNECT_TIMEOUT);
|
|
log(mtInfo,self,format('server %s:%d/%s',[fDataHost,fDataPort,fDataBase]));
|
|
finally
|
|
ini.free;
|
|
end;
|
|
end;
|
|
|
|
procedure TConnectionsDM.Log(ALevel: TLogLevel; Sender: TObject; msg: string);
|
|
var
|
|
s: string;
|
|
begin
|
|
if not assigned(fLogger) then exit;
|
|
try
|
|
|
|
// assignefile(fLogFolder
|
|
if Sender is TComponent then
|
|
s := Sender.ClassName+'-'+(Sender as TComponent).Name
|
|
else if assigned(Sender) then
|
|
s := Sender.ClassName
|
|
else
|
|
s := '[NIL]';
|
|
s := DateTimeToStr(NOW())+#09+s+#09+Msg;
|
|
case ALevel of
|
|
mtError: fLogger.Error(s);
|
|
mtWarning: fLogger.Warning(s);
|
|
mtInfo: flogger.Info(s);
|
|
mtDebug: fLogger.Debug(s);
|
|
end;
|
|
except
|
|
end;
|
|
end;
|
|
|
|
procedure TConnectionsDM.InitBaseCon;
|
|
begin
|
|
MainCon.connection.RemoteHost:=DataHost;
|
|
MainCon.connection.RemotePort:=DataPort;
|
|
MainCon.connection.Database:=DataBase;
|
|
MainCon.OpenConnection;
|
|
end;
|
|
|
|
procedure TConnectionsDM.Start;
|
|
begin
|
|
InitBaseCon;//Input.OnIdle:=@Idle;
|
|
Input.Start;
|
|
fRunning:=true;
|
|
end;
|
|
|
|
procedure TConnectionsDM.Stop;
|
|
begin
|
|
if fRunning then
|
|
Input.Terminate;
|
|
Input.WaitFor;
|
|
fRunning := false;
|
|
end;
|
|
|
|
|
|
procedure TConnectionsDM.Idle(Sender: TObject);
|
|
var
|
|
i: integer;
|
|
begin
|
|
MainCon.ExecuteSQL('select 1');
|
|
for i := conlist.Count-1 downto 0 do
|
|
if not TBaseConnection(conList[i]).Finished then
|
|
TBaseConnection(conList[i]).SetIdle;
|
|
end;
|
|
|
|
end.
|
|
|