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 LogError(Sender: TObject; e: Exception; Command: 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, 'Новое соединение с БД '+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,'Закрытие соединения '+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,'Закрытие соединения '+ID);
        TBaseConnection(conlist[i]).terminate;
        exit;
      end;
end;


procedure TConnectionsDM.ClearConnections;
var
  i: integer;
  con: TBaseConnection;
begin
  log(mtExtra, 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
  log(mtExtra,self,'ClearTerminated');
  for i := conlist.Count-1 downto 0 do
    begin
      con := TBaseConnection(conlist[i]);
      if con.Finished then
        begin
          log(mtDebug, self,'Закрытие по таймауту '+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(mtDebug, Self,'Обработка запроса '+ACommand);
  ClearTerminated;
  result := false;
  RetValue := 0;
  Code := 0;
  rValues := nil;
  ByteData := nil;
  setLength(iValues,0);
  if ACommand='stop' then
    begin
      log(mtDebug,self,'stop');
      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;
      LogError(self,e, format('ProcessRequest(%s)',[ACommand]));
    end;
  end;

end;

constructor TConnectionsDM.CreateWithLog(ALogger: TEventLog);
begin
  fLogger:=Alogger;
  inherited Create(nil);
end;

procedure TConnectionsDM.FillTemplates(RepList: TStrings);
var
  asql: string;
begin
  try
  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;

  except on e: Exception do
    begin
      logError(Self,e,format('FillTemplates',[]));
      raise;
    end;
  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
  try
  Result := MainCon.CheckUser(UserName,UserPassword,UserID);

  except on e: Exception do
    begin
      logError(Self,e,format('ProcessLogin(user=%s)',[UserName]));
      raise;
    end;
  end;
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;
  try
  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;

  except on e: Exception do
    begin
      logError(Self,e,format('ProcessArguments(report=%s)',[ReportName]));
      raise;
    end;
  end;

end;

function TConnectionsDM.ProcessReports(out rValues: TStrings): boolean;
var
  ASQL: string;
begin
  try
  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;

  except on e: Exception do
    begin
      LogError(self,e,format('ProcessReports',[]));
      raise;
    end;
  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
  try
  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;

  except on e: Exception do
    begin
      LogError(self,e,format('ProcessOptionValues(report=%s,param=%s)',[ReportName,ParamName]));
      raise;
    end;
  end;
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);
  finally
     ini.free;
  end;
  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;
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.LogError(Sender: TObject; e: Exception; Command: string
  );
begin
  log(mtError,Sender,format('%s вызвала ошибку %s(%s)  ',[Command, e.classname,e.message]));
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.