unit baseconnection;

{$mode ObjFPC}{$H+}

interface

uses
  Classes, SysUtils, extTypes, Contnrs, cgiDM,reportDMUnit;
type
   { TBaseConnection }
  TBaseConnection=class;

  { TCommand }

  TCommand=class
    protected
      fData,
      fResult: TCommandData;
    fCommandID: string;
    fStatus: integer;
    fcurrentStage: string;
    fconnect: TBaseConnection;
    TimeOut: single;
    fisDone,fisFinished: boolean;
    fIsError: boolean;
    fSubClass: string;
    public
      AccessTime: TDateTime;

      property Arguments: TCommandData read fData;
      property Results: TCommandData read fResult;
      property CommandID: string read fCommandID;
      property Status: integer read fStatus;
      property isDone: boolean read fIsDone;
      property Error: boolean read fIsError;
      property isFinished: boolean read fIsFinished;
      property CurrentStage: string read fCurrentStage;
      property Connect: TBaseConnection read fConnect;
      constructor Create(aConnect: TBaseConnection; ASubClass: string);
    destructor Destroy; override;
    procedure doRun;
    procedure Done;
    function Run: boolean; virtual; abstract;
    class function CommandName: string; virtual; abstract;
    class function CommandSubClass: string; virtual; abstract;
    function CheckArgs(out Errors: TStrings): boolean; virtual; abstract;
    function ParseCommand(ACode: DWORD; iParam: QWORD; ACommand: string; Args: TStrings; intArgs: TParamArray; CmdData: TStream; out Errors: TStrings): boolean;
    function ParseArguments(Args: TStrings; out Errors: TStrings): boolean; virtual; abstract;
    procedure Log(msg: string);
    function ProcessOptionValues(ParamName: string;  out Answer: string; out RetValue: QWORD; out OptionValues: TStrings): boolean; virtual; abstract;
  end;
  TCommandClass=class of TCommand;

  { TCommandCollection }
  TCommandCollection=Class;
  TCommandCollection=Class(TClassList)
  private
  class var fCollection: TCommandCollection;
  public
  class procedure Register(ACommand: TCommandClass);
  class function Find(Action,SubClass: string): TCommandClass;
  class procedure Init;
  class procedure Done;
  end;

  TBaseConnection=class(TThread)
    private
    fOwner:TObject;
    fLogger: TLogger;
    fConnectionID: string;
    fTimeout: integer;
    fProcessor: TNIDBDM;
    fReportProcessor: TReportDM;
    Commands: TStrings;
    DoneCommands: TList;
    fCreated,
    fCommandReceived,
    fCommandCompleted: TDateTime;
    nCommandComplete: integer;
    nCommandReceived: integer;
    nCommandReady: integer;
    nErrors: integer;

    procedure CleanDone;
    public
    Host: string;
    port: integer;
    DataBase: string;
    User: string;
    UserID: integer;
    LastAccess: TDateTime;
    procedure Log(sender: TObject; msg: 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: TObject read fOwner;
    property ConnectionID: string read fConnectionID;
    property Processor: TNIDBDM read fProcessor;
    property ReportProcessor: TReportDM read fReportProcessor;
    procedure Init;
    constructor Create(AOwner: TObject;ATimeOut: integer; aLogger: TLogger);
    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;
    procedure Idle;
    procedure Execute; override;
    function ProcessOptionValues(ReportName,ParamName: string; ParamValues: TStrings; out Answer: string; out RetValue: QWORD; out OptionValues: TStrings): boolean;
    class function newID: string;
  end;

implementation
{ TBaseConnection }

procedure TBaseConnection.Init;
begin
  Processor.connection.RemoteHost:=Host;
  Processor.connection.RemotePort:=Port;
  Processor.connection.Database:=DataBase;
  Processor.OpenConnection;
end;


constructor TBaseConnection.Create(AOwner: TObject; ATimeOut: integer;
  aLogger: TLogger);
begin
  inherited Create(true);
  fTimeout:=ATimeOut;
  fOwner := AOwner;
  flogger := ALogger;
  fProcessor:=TNIDBDM.Create(nil);
  fProcessor.logger:=aLogger;
  fReportProcessor:=TReportDM.Create(nil);
  fReportProcessor.NidbData := fProcessor;
  Commands:=TStringList.Create;
  DoneCommands:=TList.Create;
  fCreated := now();
  fCommandReceived := 0;
  fCommandCompleted := 0;
  nCommandComplete:=0;
  nCommandReceived:=0;
  nCommandReady:=0;
  nErrors:=0;
  fConnectionID:=newID;

end;

destructor TBaseConnection.Destroy;
begin
  log(self,'Destroy');
  Processor.Free;
  Commands.Free;
  DoneCommands.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
  log(self,'AddCommand '+ACommandClass+ ' '+ACommandName);
  fCommandReceived:=Now();
  cc := TCommandCollection.Find(ACommandClass,ACommandName);
  if assigned(cc) then
    begin
      cmd := cc.Create(self,ACommandName);
      cmd.AccessTime:=NOW();
      result := cmd.ParseCommand(ACode,iParam,ACommandName,Arguments,intArgs,CmdData, Errors);
      if result then
          begin
          Commands.AddObject(ACommandName,cmd);
          ID := cmd.CommandID;
          retCode := Commands.Count;
        end
      else
        begin
          ID := 'неверные параметры запроса';
          retCode := ErrorArguments;
          inc(nErrors);
          cmd.fIsError:=true;
          cmd.Done;
          DoneCommands.Add(cmd);
        end;
      inc(nCommandReceived);



    end
  else
    inc(nErrors);
end;

function TBaseConnection.RunCommand(ACommand: TCommand): boolean;
begin
  ACommand.doRun();
  log(Self,'complete '+ACommand.CommandID);
  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;

procedure TBaseConnection.Idle;
var
  d: TDateTime;
begin
  d := Created;
  if LastAccess>d then d := LastAccess;
  if (now()-d)*24*60>fTimeout then
    begin
      log(self,'TIMEOUT');
      terminate;
    end
  else
    fProcessor.ExecuteSQL('SELECT 1');
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;

procedure TBaseConnection.Log(sender: TObject; msg: string);
begin
  if assigned(fLogger) then
    flogger(sender,msg);
end;

procedure TBaseConnection.Execute;
var
  cmd: TCommand;
begin
  log(self,'started');
  while not terminated do
    begin
      while Commands.Count>0 do
        begin
          cmd := Commands.Objects[0] as TCommand;
          log(self,format('run(%s) %s %s ',[cmd.CommandID,cmd.CommandName, cmd.CommandSubClass]));
          try
            RunCommand(cmd);
          finally
            Commands.Delete(0);
            DoneCommands.Add(cmd);
          end;
        end;
      CleanDone;
      sleep(100);
    end;
  log(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;
begin
  with TCommandCollection.Find('report',Reportname).Create(self,ReportName) do
  try
    ParseCommand(0,0,ReportName,ParamValues,[],nil,tmp);
    if assigned(tmp) then FreeAndNil(tmp);
    result := ProcessOptionValues(ParamName,answer,RetValue,OptionValues);
  finally
    free
  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;


{ TCommandCollection }

class procedure TCommandCollection.Register(ACommand: TCommandClass);
begin
  fCollection.Add(ACommand);
end;

class function TCommandCollection.Find(Action, SubClass: string): TCommandClass;
var
  i: integer;
begin
  for i := 0 to fCollection.Count-1 do
    if  fCollection.Items[i].InheritsFrom(TCommand) and SameText(Action, TCommandClass(fCollection.Items[i]).CommandName) and SameText(SubClass, TCommandClass(fCollection.Items[i]).CommandSubClass) then
      begin
        result := TCommandClass(fCollection.Items[i]) ;
        exit;
      end;
  for i := 0 to fCollection.Count-1 do
    if  fCollection.Items[i].InheritsFrom(TCommand) and SameText(Action, TCommandClass(fCollection.Items[i]).CommandName) and SameText('', TCommandClass(fCollection.Items[i]).CommandSubClass) then
      begin
        result := TCommandClass(fCollection.Items[i]) ;
        exit;
      end;
  result := nil;
end;

class procedure TCommandCollection.Init;
begin
  fCollection := TCommandCollection.Create;
end;

class procedure TCommandCollection.Done;
begin
  fCollection.Free;
end;

{ TCommand }

constructor TCommand.Create(aConnect: TBaseConnection; ASubClass: string);
begin
  fconnect := AConnect;
  fSubClass := ASubClass;
  fStatus:=StatusWaiting;
  fcurrentStage := 'в очереди';
  TimeOut:=1/24/4;
  fCommandID:=TBaseConnection.newID;
end;

destructor TCommand.Destroy;
begin
  if assigned(fData) then fData.Free;
  if assigned(fResult) then fResult.free;
  inherited Destroy;
end;

procedure TCommand.doRun;
begin
  fStatus:=StatusProcessing;
  fcurrentStage := 'исполняется';
  try
  if Run then
    begin
    fStatus:=StatusComplete;
    fcurrentStage := 'завершена';
    end
  else
    begin
    fStatus := StatusError;
    fcurrentStage := 'завершена c ошибкой';
    end;

  except on e: Exception do
    begin
      fStatus:=StatusError;
      fcurrentStage := 'error';
      Results.Name:=e.Message;
    end;
  end;
end;

procedure TCommand.Done;
begin
  fisDone:=true;
end;

function TCommand.ParseCommand(ACode: DWORD; iParam: QWORD; ACommand: string;
  Args: TStrings; intArgs: TParamArray; CmdData: TStream; out Errors: TStrings
  ): boolean;
begin
  self.fData := TCommandData.Create(ACode,iParam,ACommand,Args,intArgs,cmdData);
  result := ParseArguments(fData.Keys,Errors);
end;

procedure TCommand.Log(msg: string);
begin
  connect.log(self, self.CommandID+#09+msg)
end;

end.