unit tcpserver;

{$mode ObjFPC}{$H+}

interface

uses
  Classes, SysUtils, tcpthreadhelper, extTypes;
type
  { TServerThread }

  TServerThread=class(TConnectionThread)
    class function Role: string; override;
    procedure ProcessMessage(const mode: byte; const Code:DWORD; const Param:QWord; const ACommand: string;const Values: TStrings; const intData: TParamArray; const Data: TStream); override;
  end;

  { TServerMainThread }
  TCommandReceived=function(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 of object;

  TServerMainThread=class(TMainThread)
    private
    fOnReceive: TCommandReceived;
    fOnIdle: TNotifyEvent;
    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);
  end;

implementation
  { TServerMainThread }

function TServerMainThread.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;
begin
  log(self,'ProcessReceive '+ACommand);
  if assigned(fOnReceive) then
    result := fOnReceive(self,CommandID,Param,ACommand,Fields,IParams,Data,Code,RetValue,Answer,rValues,iValues,ByteData)
  else
    begin
      log(self,'Processor not assigned');
      result := false;
      Code := ErrorProcessor;
      RetValue := 0;
      Answer := 'Server error';
      rValues := nil;
      setLength(iValues,0);
      ByteData := nil;
    end;
end;

procedure TServerMainThread.execute;
var
  n: integer;
begin
  doStart;
  log(self,'start main thread');
  Connect.Listen(Port);
  n := 0;
  while not terminated do
    begin
      try
      Connect.CallAction;

      except on e: Exception do
        log(e, '!!ERROR '+e.message);
      end;
      sleep(10);
      inc(n);
      if n>100 then
        begin
          if Assigned(fOnIdle) then fOnIdle(self);
          n :=0;
        end;
      inc(n);
    end;
end;

constructor TServerMainThread.Create(ALogger: TLogger; APort: integer;
  OnReceive: TCommandReceived);
begin
  inherited Create(TServerThread,ALogger,APort);
  fOnReceive := OnReceive;
  Connect.OnAccept:=@Accept;
  //FreeOnTerminate:=true;
end;
{ TServerThread }

class function TServerThread.Role: string;
begin
  result := 'SERVER';
end;

procedure TServerThread.ProcessMessage(const mode: byte; const Code: DWORD;
  const Param: QWord; const ACommand: string; const Values: TStrings;
  const intData: TParamArray; const Data: TStream);
var
  s: string;
  Vals: TStrings;
  B: TStream;
  res: DWORD;
  rVal: QWord;
  iVals: TParamArray;
  ok: boolean;
begin
  log(format('ProcessMessage(%d) Param=%x, Command %s ',[code,Param,ACommand]));
  try
  ok := (Owner as TServerMainThread).ProcessReceive(Code,Param,ACommand,Values,IntData,Data,res,rVal,s,Vals,iVals,B);
  try
        if OK then
          SendMessage(cmdAnswer,res,rVal, s,Vals,iVals,B)
        else
          SendMessage(cmdError,res,rVal,s,Vals);
  finally
    if Assigned(Vals) then Vals.Free;
    if Assigned(B) then B.Free;
  end;

  except on e:Exception do
    begin
      log('!!ERROR ProcessMessage '+e.message);
      raise;
    end;
  end;
end;

end.