LMS2.1

baseconnection.pas

@@ -18,7 +18,7 @@ type
     fConnectionID: string;
     fTimeout: integer;
     fProcessor: TNIDBDM;
-
+    fJournal: TStrings;
     Commands: TStrings;
     DoneCommands: TList;
     fCreated,
@@ -51,7 +51,7 @@ type
     property ConnectionID: string read fConnectionID;
     property Processor: TNIDBDM read fProcessor;
     procedure Init;
-    constructor Create(AOwner: TComponent;ATimeOut: integer; aLogger: TLogger);
+    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;
@@ -63,6 +63,7 @@ type
     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;
   end;
 
 implementation
@@ -84,10 +85,13 @@ end;
 
 
 constructor TBaseConnection.Create(AOwner: TComponent; ATimeOut: integer;
-  aLogger: TLogger);
+  aLogger: TLogger; ID: string);
 begin
   inherited Create(true);
-  fConnectionID:=newID;
+  if ID='' then
+    fConnectionID:=newID
+  else
+    fConnectionID:=ID;
   fTimeout:=ATimeOut;
   fOwner := AOwner;
   flogger := ALogger;
@@ -103,7 +107,7 @@ begin
   nCommandReceived:=0;
   nCommandReady:=0;
   nErrors:=0;
-
+  fJournal := TStringList.Create;
 
 end;
 
@@ -113,6 +117,7 @@ begin
   Processor.Free;
   Commands.Free;
   DoneCommands.Free;
+  fJournal.free;
   inherited;
 end;
 
@@ -132,7 +137,7 @@ begin
   cc := TCommandCollection.Find(ACommandClass,ACommandName);
   if assigned(cc) then
     begin
-      cmd := cc.Create(self.newID, self.Processor,ACommandName,fLogger,User,UserID);
+      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);
@@ -145,14 +150,18 @@ begin
       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;
@@ -217,7 +226,7 @@ begin
   fCheckConnect:=false;
   d := Created;
   if LastAccess>d then d := LastAccess;
-  if (now()-d)*24*60>fTimeout then
+  if (ConnectionID<>'0') and ((now()-d)*24*60>fTimeout) then
     begin
       log(mtInfo,self,'TIMEOUT');
       terminate;
@@ -251,6 +260,11 @@ 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;

cgi_daemon.pas

@@ -17,7 +17,7 @@ type
     procedure Execute;override;
     function sleepMin(n: integer): boolean;
     constructor Create(AOwner: TLMSReportCGI);
-
+    function CheckTerminated(Sender: TObject): boolean;
   end;
 
   { TLMSReportCGI }
@@ -60,6 +60,12 @@ begin
   {$ENDIF}
   self.logger.Identification:='LMS-Report-Service';
   self.Logger.Active:=true;
+  if Definition<>nil then
+    try
+      self.logger.Info(format('Daemon(%d) %s/%s {%s} (%s)',[Definition.ID, Definition.Name,Definition.DisplayName,Definition.Description,Definition.RunArguments]));
+    except on e: Exception do
+      self.logger.Error('DataModuleCreate '+e.Message);
+    end;
   workThread := TDaemonThread.create(self);
 end;
 
@@ -88,7 +94,9 @@ procedure TDaemonThread.Execute;
 begin
   fData := TConnectionsDM.CreateWithLog(fLogger);
   try
-    fData.Start;
+    flogger.Debug('TDaemonThread.Execute.1');
+    fData.Start(@CheckTerminated);
+    flogger.Debug('TDaemonThread.Execute.Started');
     while not terminated do
       begin
       if sleepMin(5) then
@@ -119,6 +127,11 @@ begin
   fLogger:=AOwner.Logger;
 end;
 
+function TDaemonThread.CheckTerminated(Sender: TObject): boolean;
+begin
+  result := terminated;
+end;
+
 
 initialization
   RegisterDaemon;

cgi_mapper.lfm

@@ -13,8 +13,10 @@ object DaemonMapper1: TDaemonMapper1
       WinBindings.ServiceType = stWin32
       WinBindings.ErrorSeverity = esIgnore
       WinBindings.AcceptedCodes = []
+      OnCreateInstance = DaemonMapper1DaemonDefs0CreateInstance
       LogStatusReport = False
     end>
+  OnCreate = DaemonMapper1Create
   Left = 1065
   Top = 332
 end

cgi_mapper.pas

@@ -8,7 +8,12 @@ uses
   Classes, SysUtils, DaemonApp;
 
 type
+
+  { TDaemonMapper1 }
+
   TDaemonMapper1 = class(TDaemonMapper)
+    procedure DaemonMapper1Create(Sender: TObject);
+    procedure DaemonMapper1DaemonDefs0CreateInstance(Sender: TObject);
   private
 
   public
@@ -19,7 +24,8 @@ var
   DaemonMapper1: TDaemonMapper1;
 
 implementation
-
+uses
+  lazutf8;
 procedure RegisterMapper;
 begin
   RegisterDaemonMapper(TDaemonMapper1)
@@ -27,6 +33,25 @@ end;
 
 {$R *.lfm}
 
+{ TDaemonMapper1 }
+
+procedure TDaemonMapper1.DaemonMapper1Create(Sender: TObject);
+var
+  i: integer;
+begin
+  for i := 0 to DaemonDefs.Count-1 do
+    begin
+     DaemonDefs.Daemons[i].DisplayName:=UTF8ToConsole(DaemonDefs.Daemons[i].DisplayName);
+     DaemonDefs.Daemons[i].Description:=UTF8ToConsole(DaemonDefs.Daemons[i].Description);
+    end;
+end;
+
+procedure TDaemonMapper1.DaemonMapper1DaemonDefs0CreateInstance(Sender: TObject
+  );
+begin
+
+end;
+
 
 initialization
   RegisterMapper;

cgidm.pas

@@ -43,6 +43,7 @@ type
     function CheckConnection: boolean;
     function QueryValue(ASQL: string; Default: string=''): string;
     function QueryIntValue(ASQL: string): integer;
+    function QueryDateValue(ASQL: string): TDateTime;
     function GetData(ASQL: string): TDataSet;
     function CheckUser(const login,password: string; out UserID: integer): boolean;
     procedure OpenConnection;
@@ -330,6 +331,22 @@ begin
     end;
 end;
 
+function TNIDBDM.QueryDateValue(ASQL: string): TDateTime;
+begin
+  log(mtDebug,self,'QueryIntValue'#13#10+ASQL);
+  CheckConnection;
+  with TnnzQuery.Create(self) do
+    try
+      Connection := fcon;
+      SQL.Text:=ASQL;
+      Open;
+      if not eof then result := Fields[0].AsDateTime else result := 0;
+    finally
+      free;
+    end;
+end;
+
+
 
 function TNIDBDM.GetData(ASQL: string): TDataSet;
 begin
@@ -355,7 +372,7 @@ end;
 
 procedure TNIDBDM.OpenConnection;
 begin
-  log(mtDebug,self,'OpenConnection');
+  log(mtDebug,self,format('OpenConnection %s:%d',[connection.RemoteHost,connection.RemotePort]));
   fcon.Connected:=true;
   fcon.Identify;
 end;

cgireport.pas

@@ -85,11 +85,11 @@ var
   d: TStringDynArray;
   i: integer;
 begin
-  ReportCode := Processor.QueryValue(format('select report_routine from xp_report_cgi where cgi_name=%s',[TNidbDM.StringAsSQL(ReportName)]));
+  ReportCode := Processor.QueryValue(format('select report_routine from xp_report_cgi where cgi_name=%s',[TNIDBDM.StringAsSQL(ReportName)]));
   UpdateCodeWithArguments(ReportCode);
   if reportcode<>'' then
     Processor.ExecuteSQL(format('select %s;',[ReportCode]));
-  ASQL := format( 'select array_to_string(extra_routines,'';'') as v from  xp_report_cgi where cgi_name=%s',[TNidbDM.StringAsSQL(ReportName)]);
+  ASQL := format( 'select array_to_string(extra_routines,'';'') as v from  xp_report_cgi where cgi_name=%s',[TNIDBDM.StringAsSQL(ReportName)]);
   v := Processor.QueryValue(ASQL);
   if v>'' then
     begin
@@ -106,7 +106,7 @@ end;
 
 procedure TReportCommand.PrepareVars;
 begin
-  VarCode := Processor.QueryValue(format('select report_routine_vars from xp_report_cgi where cgi_name=%s',[TNidbDM.StringAsSQL(ReportName)]));
+  VarCode := Processor.QueryValue(format('select report_routine_vars from xp_report_cgi where cgi_name=%s',[TNIDBDM.StringAsSQL(ReportName)]));
   UpdateCodeWithArguments(VarCode);
   if VarCode<>'' then
     Processor.ExecuteSQL(format('select %s;',[VarCode]));
@@ -144,7 +144,7 @@ begin
             vs := '';
           end;
           script := script + format(#13#10'insert into tmp_report_variables(name,value_string,var_type) values (%s,%s,0); ',
-            [TNIDBDM.StringAsSQL(fieldByName('name').asString),TNidbDM.StringAsSQL(vs)]);
+            [TNIDBDM.StringAsSQL(fieldByName('name').asString),TNIDBDM.StringAsSQL(vs)]);
           Next;
         end;
     finally
@@ -212,13 +212,13 @@ begin
   fcurrentStage := 'исполняется (инициализация)';
   fileData := TMemoryStream.Create;
   try
-  ReportID  := Processor.QueryIntValue(format('select xp_rpt_id from xp_report_cgi where cgi_name=%s',[TNidbDM.StringAsSQL(ReportName)]));
+  ReportID  := Processor.QueryIntValue(format('select xp_rpt_id from xp_report_cgi where cgi_name=%s',[TNIDBDM.StringAsSQL(ReportName)]));
   if ReportID<=0 then
     begin
       fResult := TCommandData.Create(ErrorArguments,0,'Отчет не найден',nil,[],nil);
       exit;
     end;
-  ReportTitle :=  Processor.QueryValue(format('select r.name from xp_report_cgi g join xp_report r on r.xp_rpt_id=g.xp_rpt_id where cgi_name=%s',[TNidbDM.StringAsSQL(ReportName)]));
+  ReportTitle :=  Processor.QueryValue(format('select r.name from xp_report_cgi g join xp_report r on r.xp_rpt_id=g.xp_rpt_id where cgi_name=%s',[TNIDBDM.StringAsSQL(ReportName)]));
   CreateVariablesTable;
   log(mtInfo,'Построение отчета '+ReportTitle);
   ReportProcessor.RecordID:=ReportID;
@@ -253,7 +253,7 @@ begin
       exit;
     end;
   end;
-  fResult := TCommandData.Create(0,fileData.size,ReportTitle+'.pdf',['type=application/pdf'],[],fileData);
+  fResult := TCommandData.Create(0,fileData.size,ReportTitle+'.pdf',['{"type":"application/pdf"}'],[],fileData);
   fileData.Seek(0,soFromBeginning);
   {$IFDEF DEBUG} (fileData as TMemoryStream).SaveToFile(format('%sout/%s_%s.pdf',[ Extractfilepath(paramstr(0)),self.CommandID,ReportTitle])); {$ENDIF}
   fileData.Seek(0,soFromBeginning);
@@ -269,6 +269,19 @@ var
   asql: string;
   ids: string;
   i: integer;
+  value: string;
+  val_int: integer;
+  val_float: double;
+  val_date: TDateTime;
+  fmt: TFormatSettings;
+  val_ids: TStringDynArray;
+procedure AddToErrors(error: string);
+begin
+  if not assigned(Errors) then
+    Errors := TStringList.Create;
+  Errors.Add(error);
+end;
+
 begin
   result := false;
   Errors := nil;
@@ -302,7 +315,45 @@ begin
     finally
       free;
     end;
-
+  asql := format(
+    'select p.name, p.type from xp_report_cgi c '+
+    'join xp_report_params p on p.xp_rpt_id=c.xp_rpt_id and  coalesce(p.required,true) '+
+    'where c.cgi_name=%s and p.name  in (%s) '+
+    ' and p.type in (1,2) '+
+    'order by fill_order,p.name ',
+    [TNIDBDM.StringAsSQL(ReportName),(ids)]);
+  fmt.DateSeparator:='-';
+  fmt.TimeSeparator:=':';
+  fmt.ShortDateFormat:='yyyy-mm-dd';
+  fmt.ShortTimeFormat:='hh:nn:ss';
+  with Processor.GetData(asql) do
+    try
+      while not eof do
+        begin
+          value := Arguments.Keys.Values[fieldbyname('name').AsString];
+          case FieldByName('type').asInteger of
+            1: if not TryStrToInt(value,val_int) then AddToErrors(format('{name:"%s",type:"ID"}',[TNIDBDM.StringAsJSON(FieldByName('name').AsString)]));
+            2: if not TryStrToInt(value,val_int) then AddToErrors(format('{name:"%s",type:"integer"}',[TNIDBDM.StringAsJSON(FieldByName('name').AsString)]));
+            3: if not TryStrToFloat(value,val_float) then AddToErrors(format('{name:"%s",type:"float"}',[TNIDBDM.StringAsJSON(FieldByName('name').AsString)]));
+            4: if not TryStrToDate(value,val_date,'yyyy-mm-dd','-') then AddToErrors(format('{name:"%s",type:"date"}',[TNIDBDM.StringAsJSON(FieldByName('name').AsString)]));
+            5: if not TryStrToDateTime(value,val_date,fmt) then AddToErrors(format('{name:"%s",type:"time"}',[TNIDBDM.StringAsJSON(FieldByName('name').AsString)]));
+            6: if not( (Value='0') or (Value='1') ) then  AddToErrors(format('{name:"%s",type:"boolean"}',[TNIDBDM.StringAsJSON(FieldByName('name').AsString)]));
+            17: begin
+              val_ids := SplitString(value,',');
+              for i := low(val_ids) to high(val_ids) do
+                if not TryStrToInt(val_ids[i],val_int) then
+                  begin
+                    AddToErrors(format('{name:"%s",type:"IDS"}',[TNIDBDM.StringAsJSON(FieldByName('name').AsString)]));
+                    break;
+                  end;
+            end;
+          end;
+          next;
+        end;
+    finally
+      free;
+    end;
+  result := not assigned(Errors);
 end;
 
 function TReportCommand.ProcessOptionValues(ParamName: string; out

commandcol.pas

@@ -125,6 +125,8 @@ end;
 constructor TCommand.Create(ID: string; aProcessor: TNIDBDM; ASubClass: string;
   aLogger: TLogger; AUser: string; IDUser: integer);
 begin
+  if assigned(aLogger) then
+    aLogger(mtExtra,self,'CREATE '+self.ClassName);
   fProcessor := AProcessor;
   fSubClass := ASubClass;
   fStatus:=StatusWaiting;
@@ -149,6 +151,7 @@ end;
 
 procedure TCommand.doRun;
 begin
+  log(mtInfo,format('%s(%s) %s - начато выполнение',[commandName,CommandSubClass, commandID]));
   fStatus:=StatusProcessing;
   fcurrentStage := 'исполняется';
   try
@@ -156,11 +159,13 @@ begin
     begin
     fStatus:=StatusComplete;
     fcurrentStage := 'завершена';
+    log(mtInfo,format('%s(%s) %s - выполнена',[commandName,CommandSubClass, commandID]));
     end
   else
     begin
     fStatus := StatusError;
     fcurrentStage := 'завершена c ошибкой';
+    log(mtInfo,format('%s(%s) %s - ошибка',[commandName,CommandSubClass, commandID]));
     end;
 
   except on e: Exception do

connectionsdmunit.lfm

@@ -4,7 +4,7 @@ object ConnectionsDM: TConnectionsDM
   OldCreateOrder = False
   Height = 150
   HorizontalOffset = 738
-  VerticalOffset = 342
+  VerticalOffset = 344
   Width = 533
   object Process1: TProcess
     Active = False

connectionsdmunit.pas

@@ -34,8 +34,9 @@ type
     fLogger: TEventLog;
     fTimeOut: integer;
     fRunning: boolean;
+    fTermiinateCheck: TChecker;
      function getConnection(ID: string): TBaseConnection;
-    function NewConnection: TBaseConnection;
+    function NewConnection(ID: string=''): TBaseConnection;
     procedure Remove(con: TBaseConnection); overload;
     procedure Remove(ID: string); overload;
     procedure ClearConnections;
@@ -55,7 +56,7 @@ type
     procedure Log(ALevel: TLogLevel; Sender: TObject; msg: string);
     procedure LogError(Sender: TObject; e: Exception; Command: string);
     procedure InitBaseCon;
-    procedure Start;
+    procedure Start(isTerminated: TChecker);
     procedure Stop;
     procedure Idle(Sender: TObject);
     property Running: boolean read fRunning;
@@ -65,6 +66,7 @@ type
     constructor CreateWithLog(ALogger: TEventLog);
     procedure FillTemplates(RepList: TStrings);
     procedure EditTemplate(ReportID: integer);
+    procedure TestReport(ReportID: integer);
     function CalcHash(Data: TStream): string;
   end;
 
@@ -82,12 +84,20 @@ uses
 { TConnectionsDM }
 
 procedure TConnectionsDM.DataModuleCreate(Sender: TObject);
+var
+  con: TBaseConnection;
 begin
   fRunning := false;
   conList := TList.Create;
   MainCon := TNIDBDM.CreateWithLogger(@log);
   LoadConfig;
-  input := TServerMainThread.Create(@log,fServicePort,@ProcessRequest);
+  input := nil;
+  {$IFDEF DEBUG}
+  con := NewConnection('0');
+  con.User:='anonymous';
+  con.UserID := 0;
+  con.Start;
+  {$ENDIF}
 end;
 
 procedure TConnectionsDM.DataModuleDestroy(Sender: TObject);
@@ -99,8 +109,10 @@ begin
     begin
       Input.Terminate;
       Input.WaitFor;
-    end;
       Input.Free;
+    end;
+
+
   MainCon.Free;
   conList.Free;
 
@@ -120,13 +132,13 @@ begin
   result := nil;
 end;
 
-function TConnectionsDM.NewConnection: TBaseConnection;
+function TConnectionsDM.NewConnection(ID: string): TBaseConnection;
 var
   g: TGUID;
   s: string;
   i: integer;
 begin
-  result := TBaseConnection.Create(self,fTimeOut,@Log);
+  result := TBaseConnection.Create(self,fTimeOut,@Log,ID);
   conlist.add(result);
   result.Host:=DataHost;
   result.port:=DataPort;
@@ -209,14 +221,24 @@ function TConnectionsDM.ProcessRequest(Sender: TMainThread;
   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;
+procedure waitforresult(Pause: integer; acmd: TCommand);
+begin
+  if acmd.Status in [StatusComplete,StatusError] then exit;
+  while (pause>0) and not(acmd.Status in [StatusWaiting,StatusProcessing]) do
+    begin
+    Sleep(1000);
+    dec(pause);
+    end;
+end;
 var
   UserID: integer;
   con: TBaseConnection;
   userName,conID,cmdID: string;
   cmd: TCommand;
+  i: integer;
 begin
   try
-  log(mtDebug, Self,'Обработка запроса '+ACommand);
+  log(mtInfo, Self,'Обработка запроса '+ACommand);
   ClearTerminated;
   result := false;
   RetValue := 0;
@@ -240,10 +262,11 @@ begin
       rvalues.Add('"help"');
       rvalues.Add('"version"');
       rValues.add('"reports"');
-      rValues.add('{action:"arguments",params:["name"]}');
+      rValues.add('{action:"arguments",params:["report"]}');
       rValues.add('{action:"login",params:["user","password"]}');
       rValues.add('{action:"logout",params:["connect"]}');
       rValues.add('{action:"test",params:["connect"]}');
+      rValues.add('{action:"log",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"]}');
@@ -257,7 +280,7 @@ begin
     end;
   if ACommand='arguments' then
     begin
-      result := ProcessArguments(Fields.Values['name'],RetValue,Answer,rValues);
+      result := ProcessArguments(Fields.Values['report'],RetValue,Answer,rValues);
       if not result then
         begin
           Code := ErrorArguments;
@@ -310,6 +333,19 @@ begin
       Remove(con.ConnectionID);
       exit;
     end;
+  if ACommand='log' then
+    begin
+      result := true;
+      Answer := 'OK';
+      rValues := TStringList.Create;
+          for i := 0 to con.Journal.count-1 do
+            begin
+            rValues.add('"'+TNIDBDM.StringAsJSON(con.Journal[i])+'"');
+            end;
+      con.Journal.Clear;
+      exit;
+    end;
+  con.Log(mtInfo,self,'Получен запрос '+ACommand);
   if ACommand='connectStatus' then
     begin
       result := true;
@@ -348,7 +384,8 @@ begin
       else
         begin
           rValues := TSTringList.Create;
-          rValues.Assign(cmd.Journal);
+          for i := 0 to cmd.Journal.count-1 do
+            rValues.add('"'+TNIDBDM.StringAsJSON(cmd.Journal[i])+'"');
         end;
       code := cmd.Status;
       if (code=StatusComplete) and assigned(cmd.Results.Data) then
@@ -360,12 +397,19 @@ begin
     end;
   if ACommand='result' then
     begin
+      waitforresult(StrToIntDef(Fields.Values['wait'],0),cmd);
       if cmd.Status=StatusComplete then
         begin
           cmd.Results.AssignTo(Code,RetValue,Answer,rValues,iValues,ByteData);
           cmd.Done;
           result := true;
         end
+      else if cmd.Status=StatusError then
+        begin
+          cmd.Results.AssignTo(Code,RetValue,Answer,rValues,iValues,ByteData);
+          cmd.Done;
+          result := false;
+        end
       else
         begin
           Code := ErrorComplete;
@@ -463,6 +507,30 @@ begin
      end;
 end;
 
+procedure TConnectionsDM.TestReport(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.Run();
+
+     finally
+        cmd.free;
+     end;
+end;
+
+
 function TConnectionsDM.ProcessLogin(UserName, UserPassword: string; out  UserID: integer): boolean;
 var
   ASQL: string;
@@ -636,6 +704,8 @@ begin
   log(mtInfo,self,format('База данных %s:%d/%s Порт для соединения %d',[fDataHost,fDataPort,fDataBase,fServicePort]));
 end;
 
+
+
 procedure TConnectionsDM.Log(ALevel: TLogLevel; Sender: TObject; msg: string);
 var
   s: string;
@@ -655,7 +725,10 @@ begin
     mtError: fLogger.Error(s);
     mtWarning: fLogger.Warning(s);
     mtInfo: flogger.Info(s);
+    {$IFDEF DEBUG}
     mtDebug: fLogger.Debug(s);
+    mtExtra: fLogger.Log(#09+s);
+   {$ENDIF}
   end;
   except
   end;
@@ -675,9 +748,11 @@ begin
   MainCon.OpenConnection;
 end;
 
-procedure TConnectionsDM.Start;
+procedure TConnectionsDM.Start(isTerminated: TChecker);
 begin
+  fTermiinateCheck := isTerminated;
   InitBaseCon;//Input.OnIdle:=@Idle;
+  input := TServerMainThread.Create(@log,fServicePort,fTermiinateCheck,@ProcessRequest);
   Input.Start;
   fRunning:=true;
 end;

exttypes.pas

@@ -30,6 +30,7 @@ type
   TParamArray=Array of QWORD;
   TLogLevel=(mtError,mtWarning,mtInfo,mtDebug,mtExtra);
   TLogger=procedure(ALevel: TLogLevel; Sender: TObject; Msg: String ) of object;
+  TChecker=function(Sender: TObject): boolean of object;
   EFormatException=class(Exception);
   { TConnectionThread }
 

fr_utils.pas

@@ -65,7 +65,6 @@ begin
   if AMethodName = '_' then Result := _(Params[0])
   else
   if AnsiSameText(AMethodName,'Log') then begin
-    {$IFDEF DEBUG} cxlogger.TLogSystem.Loggers['fastreport'].writelog(Params[0],Params[1]); {$ENDIF}
     result := true;
   end
   else

lms_cgi.lpr

@@ -178,6 +178,18 @@ log(mtDebug,self,'Data READY');
 {$ENDIF}
   if not assigned(fData) then
     begin
+      if fmODE=3 then
+        case fCode of
+          ErrorProcessor:  AResponse.Code:=503;
+          ErrorLogin:  AResponse.Code:=401;
+          ErrorConnect:  AResponse.Code:=401;
+          ErrorCommand:  AResponse.Code:=501;
+          ErrorComplete:  AResponse.Code:=202;
+          ErrorArguments:  AResponse.Code:=400;
+          ErrorInternal:  AResponse.Code:=500;
+        end
+      else
+        AResponse.Code:=200;
       AResponse.ContentType := 'application/json';
       AResponse.Contents.add('{');
       AResponse.Contents.add('"type":'+aTypes[fMode]+',');
@@ -259,6 +271,7 @@ begin
   flogger := TEventLog.Create(self);
   flogger.Identification:='lms_cgi_client';
   flogger.LogType:={$IFDEF LINUX}ltSystem{$ELSE}ltFile{$ENDIF};
+  flogger.AppendContent:=true;
   inherited Create(AOwner);
 
 end;

lms_cgi_server.ini

@@ -4,4 +4,4 @@ port=7079
 database=lms
 [PARAMS]
 port=6543
-log=/var/log/nintegra/cgireport.log
+log=./cgireport.log

lms_cgi_server.lpi

@@ -15,7 +15,7 @@
       <ResourceType Value="res"/>
     </General>
     <BuildModes>
-      <Item Name="Default" Default="True"/>
+      <Item Name="Debug" Default="True"/>
       <Item Name="Release">
         <CompilerOptions>
           <Version Value="11"/>
@@ -166,6 +166,12 @@
       <OtherUnitFiles Value="reports"/>
       <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
     </SearchPaths>
+    <Other>
+      <CustomOptions Value="-dDEBUG"/>
+      <OtherDefines Count="1">
+        <Define0 Value="DEBUG"/>
+      </OtherDefines>
+    </Other>
   </CompilerOptions>
   <Debugging>
     <Exceptions>

lmsreport.lpi

@@ -55,6 +55,12 @@
               </Win32>
             </Options>
           </Linking>
+          <Other>
+            <CustomOptions Value="-dDEBUG"/>
+            <OtherDefines Count="1">
+              <Define0 Value="DEBUG"/>
+            </OtherDefines>
+          </Other>
         </CompilerOptions>
       </Item>
       <Item Name="Release">

maintcpserver.lfm

@@ -1,5 +1,5 @@
 object CGIServerGUI: TCGIServerGUI
-  Left = 401
+  Left = 602
   Height = 566
   Top = 219
   Width = 870
@@ -8,7 +8,7 @@ object CGIServerGUI: TCGIServerGUI
   ClientWidth = 870
   OnCreate = FormCreate
   OnDestroy = FormDestroy
-  LCLVersion = '2.2.2.0'
+  LCLVersion = '3.6.0.0'
   object Panel1: TPanel
     Left = 0
     Height = 50
@@ -25,8 +25,8 @@ object CGIServerGUI: TCGIServerGUI
       Top = 14
       Width = 75
       Caption = 'Запрос'
-      OnClick = SendButtonClick
       TabOrder = 0
+      OnClick = SendButtonClick
     end
     object StartButton: TButton
       Left = 8
@@ -34,8 +34,8 @@ object CGIServerGUI: TCGIServerGUI
       Top = 14
       Width = 75
       Caption = 'Запуск'
-      OnClick = StartButtonClick
       TabOrder = 1
+      OnClick = StartButtonClick
     end
   end
   object GroupBox1: TGroupBox
@@ -45,14 +45,14 @@ object CGIServerGUI: TCGIServerGUI
     Width = 368
     Align = alLeft
     Caption = 'Запрос'
-    ClientHeight = 227
+    ClientHeight = 226
-    ClientWidth = 366
+    ClientWidth = 364
     TabOrder = 1
     object Keys: TMemo
       Left = 0
-      Height = 197
+      Height = 203
-      Top = 30
+      Top = 23
-      Width = 366
+      Width = 364
       Align = alClient
       Lines.Strings = (
         'user=nnz'
@@ -62,11 +62,11 @@ object CGIServerGUI: TCGIServerGUI
     end
     object edtRequest: TComboBox
       Left = 0
-      Height = 30
+      Height = 23
       Top = 0
-      Width = 366
+      Width = 364
       Align = alTop
-      ItemHeight = 0
+      ItemHeight = 15
       ItemIndex = 3
       Items.Strings = (
         'version'
@@ -91,42 +91,41 @@ object CGIServerGUI: TCGIServerGUI
     Width = 497
     Align = alClient
     Caption = 'Ответ'
-    ClientHeight = 227
+    ClientHeight = 226
-    ClientWidth = 495
+    ClientWidth = 493
     TabOrder = 2
     object edtAnswer: TEdit
       Left = 0
-      Height = 30
+      Height = 23
       Top = 25
-      Width = 495
+      Width = 493
       Align = alTop
-      OnDblClick = edtAnswerDblClick
       TabOrder = 0
+      OnDblClick = edtAnswerDblClick
     end
     object retValues: TMemo
       Left = 0
-      Height = 92
+      Height = 105
-      Top = 85
+      Top = 71
-      Width = 495
+      Width = 493
       Align = alClient
       TabOrder = 1
     end
     object intValues: TListBox
       Left = 0
       Height = 50
-      Top = 177
+      Top = 176
-      Width = 495
+      Width = 493
       Align = alBottom
       Columns = 4
       ItemHeight = 0
       TabOrder = 2
-      TopIndex = -1
     end
     object edtQValue: TEdit
       Left = 0
-      Height = 30
+      Height = 23
-      Top = 55
+      Top = 48
-      Width = 495
+      Width = 493
       Align = alTop
       TabOrder = 3
     end
@@ -134,7 +133,7 @@ object CGIServerGUI: TCGIServerGUI
       Left = 0
       Height = 25
       Top = 0
-      Width = 495
+      Width = 493
       Align = alTop
       TabOrder = 4
     end
@@ -152,17 +151,17 @@ object CGIServerGUI: TCGIServerGUI
     Width = 870
     Align = alBottom
     Caption = 'Шаблоны'
-    ClientHeight = 251
+    ClientHeight = 250
-    ClientWidth = 868
+    ClientWidth = 866
     TabOrder = 4
     object ReportsPanel: TPanel
       Left = 0
       Height = 50
-      Top = 201
+      Top = 200
-      Width = 868
+      Width = 866
       Align = alBottom
       ClientHeight = 50
-      ClientWidth = 868
+      ClientWidth = 866
       TabOrder = 0
       object EditTemplate: TButton
         Left = 760
@@ -170,19 +169,27 @@ object CGIServerGUI: TCGIServerGUI
         Top = 11
         Width = 100
         Caption = 'Шаблон'
-        OnClick = EditTemplateClick
         TabOrder = 0
+        OnClick = EditTemplateClick
+      end
+      object TestButton: TButton
+        Left = 672
+        Height = 25
+        Top = 11
+        Width = 75
+        Caption = 'Проверка'
+        TabOrder = 1
+        OnClick = TestButtonClick
       end
     end
     object ReportsList: TListBox
       Left = 0
-      Height = 201
+      Height = 200
       Top = 0
-      Width = 868
+      Width = 866
       Align = alClient
       ItemHeight = 0
       TabOrder = 1
-      TopIndex = -1
     end
   end
 end

maintcpserver.pas

@@ -17,6 +17,7 @@ type
   { TCGIServerGUI }
 
   TCGIServerGUI = class(TForm)
+    TestButton: TButton;
     EditTemplate: TButton;
     edtAnswer: TEdit;
     edtQValue: TEdit;
@@ -40,12 +41,14 @@ type
     procedure StartButtonClick(Sender: TObject);
     procedure FormCreate(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
+    procedure TestButtonClick(Sender: TObject);
   private
    fLogger: TEventLog;
    Server: TConnectionsDM;
    Client: TClientMainThread;
    cmdDone: boolean;
    started: boolean;
+   function IsTerminated(Sender: TObject): boolean;
     procedure LogQuery(const qtype: integer; const command: string; const aKeys: TStrings; const code: DWORD; const Param: QWORD; const data: TParamArray);
     function onAnswer(Sender: TMainThread; const mode: byte;
     const Code:DWORD; const QValue: QWORD; const Answer: string; const Values: TStrings; const iValues: TParamArray; const Data: TStream): boolean;
@@ -122,7 +125,7 @@ end;
 procedure TCGIServerGUI.StartButtonClick(Sender: TObject);
 begin
 
-  Server.Start;
+  Server.Start(@isTerminated);
   Server.FillTemplates(ReportsList.Items);
   started := true;
   Panel1.Caption := 'запущен';
@@ -135,6 +138,20 @@ begin
   fLogger.Free;
 end;
 
+procedure TCGIServerGUI.TestButtonClick(Sender: TObject);
+var
+  rID: integer;
+begin
+  rID := PtrInt(ReportsList.Items.Objects[ReportsList.ItemIndex]);
+  Server.TestReport(rID);
+end;
+
+function TCGIServerGUI.IsTerminated(Sender: TObject): boolean;
+begin
+  result := false;
+end;
+
+
 procedure TCGIServerGUI.LogQuery(const qtype: integer; const command: string;
   const aKeys: TStrings; const code: DWORD; const Param: QWORD;
   const data: TParamArray);

reports/allreportsunit.pas

@@ -9,7 +9,7 @@ uses
 
 implementation
 uses
-  cgiReport,applicantlist,applicantresult;
+  cgiReport,applicantlist,applicantresult, journal;
 initialization
 TCommandCollection.Register(TReportCommand);
 end.

tcpclient.pas

@@ -81,7 +81,7 @@ end;
 procedure TClientMainThread.execute;
 begin
   doStart;
-  log(mtExtra, self,'start main thread');
+  log(mtExtra, self,format('start main thread %s:%d',[Host,Port]));
   Connect.Connect(Host,Port);
   try
   while not terminated and not Complete do
@@ -100,6 +100,7 @@ end;
 
 procedure TClientMainThread.ProcessConnect(thread: TConnectionThread);
 begin
+  log(mtDebug,self,'ProcessConnect '+GuidToString(thread.ID));
   thread.SendMessage(cmdRequest,1,0,self.Command,self.fFields);
 end;
 

tcpserver.pas

@@ -23,12 +23,13 @@ type
     private
     fOnReceive: TCommandReceived;
     fOnIdle: TNotifyEvent;
+    fTerminateCheck: TChecker;
     function processReceive(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;
     public
     property OnIdle: TNotifyEvent read fOnIdle write fOnIdle;
     procedure execute; override;
-    constructor Create( ALogger: TLogger; APort: integer; OnReceive:TCommandReceived);
+    constructor Create( ALogger: TLogger; APort: integer;TermCheck: TChecker; OnReceive:TCommandReceived);
   end;
 
 implementation
@@ -62,10 +63,10 @@ var
   n: integer;
 begin
   doStart;
-  log(mtExtra,self,'start main thread');
+  log(mtExtra,self,format('start main thread %d',[Port]));
   Connect.Listen(Port);
   n := 0;
-  while not terminated and not Complete do
+  while not terminated and not Complete and not fTerminateCheck(self) do
     begin
       try
       Connect.CallAction;
@@ -73,9 +74,9 @@ begin
       except on e: Exception do
         log(mtError,e, '!!ERROR '+e.message);
       end;
-      sleep(10);
+      sleep(100);
       inc(n);
-      if n>100 then
+      if n>1000 then
         begin
           if Assigned(fOnIdle) then fOnIdle(self);
           n :=0;
@@ -86,9 +87,10 @@ begin
 end;
 
 constructor TServerMainThread.Create(ALogger: TLogger; APort: integer;
-  OnReceive: TCommandReceived);
+  TermCheck: TChecker; OnReceive: TCommandReceived);
 begin
   inherited Create(TServerThread,ALogger,APort);
+  fTerminateCheck:=TermCheck;
   fOnReceive := OnReceive;
   Connect.OnAccept:=@Accept;
   //FreeOnTerminate:=true;

tcpthreadhelper.pas

@@ -129,6 +129,7 @@ var
   clt: TConnectionThread;
   i: integer;
 begin
+  result := nil;
   for i := 0 to fclients.Count-1 do
     if TConnectionThread(fclients[i]).Socket=index then
     begin
@@ -137,7 +138,7 @@ begin
       exit;
     end;
   result := fThreadClass.Create(self,index);
-  log(mtExtra,self,format('new Thread(%d) %s',[index.Handle,guidToString(result.ID)]));
+  log(mtDebug,self,format('new Thread(%d) %s',[index.Handle,guidToString(result.ID)]));
   fclients.Add(Result);
 
 end;
@@ -147,13 +148,13 @@ var
   i: integer;
   clt: TConnectionThread;
 begin
-  log(mtExtra,Self,'Terminate Clients');
+  log(mtDebug,Self,'Terminate Clients '+inttostr(fclients.Count));
   for i :=  fclients.Count-1 downto 0 do
     begin
       sleep(0);
       clt := TConnectionThread(fclients[i]);
       try
-      log(mtExtra,self,GuidToString(clt.ID));
+      log(mtDebug,self,GuidToString(clt.ID));
       clt.Terminate;
       clt.WaitFor;
       clt.free;
@@ -182,7 +183,11 @@ end;
 
 procedure TMainThread.RemoveClient(clt: TConnectionThread);
 begin
+  clt.Terminate;
+  clt.WaitFor;
+  log(mtDebug,self,'RemoveClient '+GuidToString(clt.ID));
   fclients.Remove(clt);
+  clt.free;
 end;
 
 
@@ -190,7 +195,7 @@ procedure TMainThread.dataReady(aSocket: TLSocket);
 var
   clt: TConnectionThread;
 begin
-  log(mtExtra,self,'dataReady');
+  log(mtExtra,self,format('dataReady(%s:%d<-%s:%d) ',[aSocket.LocalAddress,aSocket.LocalPort,aSocket.PeerAddress,aSocket.PeerPort]));
   if Terminated then  exit;
 
   clt := Client[aSocket];
@@ -203,19 +208,19 @@ end;
 
 procedure TMainThread.ProcessConnect(thread: TConnectionThread);
 begin
-
+  log(mtExtra,self,'ProcessConnect'+GUIDToString(thread.ID));
 end;
 
 procedure TMainThread.ProcessAccept(thread: TConnectionThread);
 begin
-
+  log(mtExtra,self,'ProcessAccept'+GUIDToString(thread.ID));
 end;
 
 procedure TMainThread.Accept(aSocket: TLSocket);
 var
   clt: TConnectionThread;
 begin
-  log(mtExtra,self,'connect');
+  log(mtExtra,self,format('accept(%s:%d<-%s:%d) ',[aSocket.LocalAddress,aSocket.LocalPort,aSocket.PeerAddress,aSocket.PeerPort]));
   if Terminated then  exit;
   clt := Client[aSocket];
   log(mtExtra,self,format('connected %s on %d ',[GUIDToString(clt.ID), aSocket.Handle]));
@@ -229,14 +234,17 @@ var
   clt: TConnectionThread;
 begin
   if terminated then exit;
-  log(mtExtra,self,'disconnect');
+  log(mtDebug,self,format('disconnect(%s:%d<-%s:%d) ',[aSocket.LocalAddress,aSocket.LocalPort,aSocket.PeerAddress,aSocket.PeerPort]));
   try
   clt := Client[aSocket];
-  if clt.terminated then exit;
+  if assigned(clt) then
-  log(mtExtra,self,format('disconnected %s on %d ',[GUIDToString(clt.ID), aSocket.Handle]));
+    begin
+      log(mtDebug,self,format('disconnected %s on %d ',[GUIDToString(clt.ID), aSocket.Handle]));
       clt.Terminate;
       fclients.remove(clt);
-
+      clt.WaitFor;
+      clt.free;
+    end;
   except on e: Exception do
     begin
       log(mtError,self,'!!ERROR doDisconnect '+e.Message);
@@ -249,7 +257,7 @@ procedure TMainThread.doConnect(aSocket: TLSocket);
 var
   clt: TConnectionThread;
 begin
-  log(mtExtra,self,'doConnect');
+  log(mtExtra,self,format('doConnect(%s:%d<-%s:%d) ',[aSocket.LocalAddress,aSocket.LocalPort,aSocket.PeerAddress,aSocket.PeerPort]));
   if Terminated then  exit;
   clt := Client[aSocket];
   log(mtExtra,self,format('connected %s on %d ',[GUIDToString(clt.ID), aSocket.Handle]));
@@ -1040,7 +1048,7 @@ begin
   fOwner := AOwner;
   CreateGuid(ID);
   recNo := 0;
-  log(mtExtra,'Create');
+  log(mtExtra,'Create client thread ');
 end;
 
 destructor TConnectionThread.Destroy;
@@ -1064,7 +1072,12 @@ begin
   log(mtExtra,'start thread');
   while not terminated do
     begin
-      if cache.ReadReady.WaitFor(1000)<>wrSignaled then begin sleep(10);continue;end;
+      if cache.ReadReady.WaitFor(10000)<>wrSignaled then
+        begin
+          log(mtDebug,'TConnectionThread.Wait');
+          sleep(100);
+          continue;
+        end;
       if terminated then break;
       if not Socket.Connected then break;
       Keys := nil;