unit JrbustcpClient;

interface
uses
  Controls,
  Windows,
  SysUtils,
  Classes,
  IdTCPClient,
  IdGlobal,

  ByteBuf,
  Tags,
  TagTable;

const
  INITPRM_TAGDESCR         = 1;
  INITPRM_TAGSTATUS        = 2;
  INITPRM_EXCLUDE_EXTERNAL = 4;
  INITPRM_INCLUDE_HIDDEN   = 8;

  STATE_CREATED = 0;
  STATE_READING = 1;
  STATE_WRITING = 2;
  STATE_SLEEPING = 3;
  STATE_TERMINATED = 4;

type
  TJrbustcpClientThread = class;

  TJrbustcpClient = class(TObject)
  private
    FThread: TJrbustcpClientThread;
    FTcpClient: TIdTCPClient;
    FClTags: array of TTagRW;
    FWriteCache: array of Integer;
    FBufOut: TByteBuf;
    FBufIn: TByteBuf;
    FReqId: Integer;
    FLastCmd: Byte;
    FConnected: Boolean;
    FNeedReinitList: Boolean;
    FTagTable: TTagTable;
    FState: Integer;
    FStateDt: TDateTime;

    FDescr: string;
    FFilter: string;
    FHost: string;
    FPort: Integer;
    FFlags: Integer;
    FPeriod: cardinal;
    FTimeout: Integer;
    FAuth: boolean;
    FAuthKeyName: string;

    procedure OnThreadTerminate(Sender: TObject);

    function Authenticate: Boolean;
    function InitList: Boolean;
    function Read: Boolean;
    function Write: Boolean;

    procedure startMessage(cmd: integer);
    procedure writeAndReadMessage;

    procedure setState(state: integer);
    function getState: string;
  public
    Constructor Create;
    destructor Destroy; override;

    function Connect: Boolean;
    function Disconnect: Boolean;

    function showSettingsDialog: Boolean;
    procedure setFlag(flag: Integer; value: boolean);

    property Connected: boolean read FConnected;
    property NeedReinitList: boolean read FNeedReinitList;
    property TagTable: TTagTable read FTagTable;
    property State: string read getState;

    property Descr: string read FDescr write FDescr;
    property Filter: string read FFilter write FFilter;
    property Host: string read FHost write FHost;
    property Port: Integer read FPort write FPort;
    property Flags: Integer read FFlags write FFlags;
    property Period: Cardinal read FPeriod write FPeriod;
    property Timeout: Integer read FTimeout write FTimeout;
    property Auth: boolean read FAuth write FAuth;
    property AuthKeyName: string read FAuthKeyName write FAuthKeyName;
  end;

  TJrbustcpClientThread = class(TThread)
  protected
    procedure Execute; override;
  public
    parent: TJrbustcpClient;
  end;

implementation
uses
  RSAOpenSSL,
  JrbustcpClientProp;

const
  MAGIC_HEADER = $ABCD;

  CMD_INIT        = 1;
  CMD_LIST        = 2;
  CMD_UPDATE      = 3;
  CMD_READ        = 4;
  CMD_WRITE       = 5;
  CMD_CRC         = 6;
  CMD_AUTH_INIT   = 7;
  CMD_AUTH_SUBMIT = 8;

  CMD_UNAUTHENTICATED  = 254;
  CMD_UNKNOWN          = 255;

  AUTH_INIT_OK         = 0;
  AUTH_INIT_FAILED     = 1;
  AUTH_INIT_DISABLED   = 2;

  AUTH_SUBMIT_ACCEPTED = 0;
  AUTH_SUBMIT_DENIED   = 255;

  VAL_INDEX_SHORT   = $FE;
  VAL_INDEX_MEDIUM  = $FF;


{ TJrbustcpClient }

Constructor TJrbustcpClient.Create;
begin
  DecimalSeparator := '.';

  FBufIn := TByteBuf.Create(16384);
  FBufOut := TByteBuf.Create(16384);
  FTagTable := TTagTable.Create;
  setState(STATE_CREATED);

  FPeriod := 500;
  FHost := 'localhost';
  FPort := 40000;
  FTimeout := 3000;
  FFlags := INITPRM_TAGSTATUS;
  SetLength(FClTags, 0);

  FConnected := False;
  FNeedReinitList := false;
  FThread := nil;
  FTcpClient := nil;
  Randomize;
end;

destructor TJrbustcpClient.Destroy;
begin
  Disconnect;
  FTagTable.Free;
  FBufIn.Free;
  FBufOut.Free;
end;


function TJrbustcpClient.Connect: Boolean;
begin
  Disconnect;

  FTcpClient := TIdTCPClient.Create;

  FTcpClient.Host := FHost;
  FTcpClient.Port := FPort;
  FTcpClient.ConnectTimeout := FTimeout;
  FTcpClient.ReadTimeout := FTimeout;
  try
    FTcpClient.Connect;

    if (Authenticate) and (InitList) and (Read) then
    begin
      FThread := TJrbustcpClientThread.Create(true);
      FThread.parent := self;
      FThread.Resume;
      FThread.OnTerminate := OnThreadTerminate;

      FReqId := Random(MaxInt);
      FConnected := true;
    end;
  except
  end;

  if not FConnected then
    Disconnect;

  Result := FConnected;
end;


function TJrbustcpClient.Disconnect: Boolean;
begin
  result := true;
  FConnected := False;

  if FThread <> nil then
  begin
    FThread.Terminate;
    FThread.WaitFor;
    FThread.Free;
    FThread := nil;
  end;

  if FTcpClient <> nil then
  begin
    try
      FTcpClient.Disconnect;
    except
    end;
    FTcpClient.Free;
    FTcpClient := nil;
  end;
end;

procedure TJrbustcpClient.OnThreadTerminate(Sender: TObject);
begin
  FConnected := false;
end;


procedure TJrbustcpClient.startMessage(cmd: integer);
begin
  Inc(FReqId);
  FBufOut.clear;
  Inc(FBufOut.writeIndex, 2);
  FBufOut.writeWord(MAGIC_HEADER);
  FBufOut.writeInt(FReqId);
  FBufOut.writeByte(cmd);
  FLastCmd := cmd;
end;


procedure TJrbustcpClient.writeAndReadMessage;
var
  size, gotReqId, crc1, crc2: Integer;
  gotCmd: Byte;
  header: Word;
begin
  crc1 := FBufOut.calcCrc32(4, FBufOut.writeIndex-4);
  FBufOut.writeInt(crc1);
  FBufOut.setWord(0, FBufOut.writeIndex-2);
  FTcpClient.IOHandler.Write(FBufOut.buf, FBufOut.writeIndex);

  repeat
    FBufIn.clear;
    size := FTcpClient.IOHandler.ReadSmallInt();
    FTcpClient.IOHandler.ReadBytes(FBufIn.buf, size, false);
    FBufIn.writeIndex := size;
    header := FBufIn.readWord;
    gotReqId := FBufIn.readInt;
    gotCmd := FBufIn.readByte;
    crc1 := FBufIn.getInt( size-4);
    crc2 := FBufIn.calcCrc32(2, size-6);
  until (header=MAGIC_HEADER) and (gotReqId=FReqId) and (gotCmd=FLastCmd+$80) and (crc1=crc2);
end;


function TJrbustcpClient.Authenticate: Boolean;
var
  status: byte;
  rsa: TRSAOpenSSL;
  rsadata: TRSAData;
begin
  if not FAuth then
  begin
    result := true;
    exit;
  end;

  try
    startMessage(CMD_AUTH_INIT);
    FBufOut.writeBigString( ExtractFileName(FAuthKeyName) );
    writeAndReadMessage;

    status := FBufIn.readByte;
    if status = AUTH_INIT_DISABLED then
    begin
      Result := True;
      exit;
    end;

    if status <> AUTH_INIT_OK then
      begin
        Result := false;
        exit;
      end;

    rsa := TRSAOpenSSL.Create('', FAuthKeyName);
    try
      rsadata.EncryptedData := FBufIn.readBigString;
      rsa.convertToMultilineBase64(rsadata.EncryptedData);
      rsa.PrivateDecrypt(rsadata);
    finally
      rsa.Free
    end;

    startMessage(CMD_AUTH_SUBMIT);
    FBufOut.writeBigString(rsadata.DecryptedData);
    writeAndReadMessage;

    status := FBufIn.readByte;
    result := status = AUTH_SUBMIT_ACCEPTED;

  except
    result := false;
  end;
end;


function TJrbustcpClient.InitList: Boolean;
var
  tagname, tagdescr: string;
  size, qnt, index, i: integer;
  ttype: TTagType;
  ttypeval: integer;
//  b: Byte;
  tag: TTagRW;
begin
  ttype := ttINT;
  Result := true;
  try
    startMessage(CMD_INIT);
    FBufOut.writeSmallSizeString(FFilter);
    FBufOut.writeSmallSizeString(FDescr);
    FBufOut.writeWord(FFlags);
    writeAndReadMessage;

    for i:=0 to Length(FClTags)-1 do
      FClTags[i].setStatus(tsDELETED);

    size := FBufIn.readMedium;
    SetLength(FClTags, size);

    index := 0;
    while index < size do
    begin
      startMessage(CMD_LIST);
      FBufOut.writeMedium(index);
      writeAndReadMessage;

      if index <> FBufIn.readMedium then
      begin
        //todo: log error - invalid index
        result := False;
        break;
      end;
      qnt := FBufIn.readMedium;
      FBufIn.readMedium; // skip 'next'

      for i:=1 to qnt do
      begin
        ttypeval := FBufIn.readByte;
        if (ttypeval >= Ord(Low(TTagType))) and (ttypeval <= Ord(High(TTagType))) then
          ttype := TTagType(ttypeval)
        else
        begin
          //todo: log error - tagtype not found
          result := False;
          break;
        end;

        tagname := FBufIn.readSmallSizeString;
        tagdescr := FBufIn.readSmallSizeString;

        tag := TTagRW(TagTable.get(tagname));
        if (tag = nil) or (tag.getType <> ttype) then
        begin
          tag := createTagRW(ttype, tagname, TAG_FLAG_EXTERNAL);//, writeMutex);
          tagtable.add(tag);
        end;
        tag.setStatus(tsGOOD);

        FClTags[index] := tag;
        Inc(index)
      end;

      if not Result then Break;
    end;

    if index <> size then
    begin
      //todo: log error - didn't get all the tags
      result := false;
    end;
  except
    result := false;
  end;

  if Result then
  begin
    TagTable.removeDeleted;
    FNeedReinitList := false;
  end
  else
  begin
    SetLength(FClTags, 0);
  end;
end;

function TJrbustcpClient.Read: Boolean;
var
  qnt, next, index, i, size: integer;
  valcode: byte;
begin
  Result := true;
  try
    startMessage(CMD_UPDATE);
    writeAndReadMessage;

    qnt := FBufIn.readMedium;
    next := FBufIn.readMedium;
    FNeedReinitList := FBufIn.readByte = $FF;

    if qnt > 0 then
    begin
      size := Length(FClTags);
      repeat
        startMessage(CMD_READ);
        FBufOut.writeMedium(next);
        writeAndReadMessage;

        index := FBufIn.readMedium;
        qnt := FBufIn.readMedium;
        next := FBufIn.readMedium;

        for i:=1 to qnt do
        begin
          valcode := FBufIn.getByte( FBufIn.readIndex );
          if valcode >= VAL_INDEX_SHORT then
          begin
            FBufIn.readByte;
            if valcode = VAL_INDEX_MEDIUM then
              index := FBufIn.readMedium
            else
              index := FBufIn.readWord;
          end;

          if index < size then
            FBufIn.readValueStatus( FClTags[index] );

          Inc(index);
        end;
      until next = 0;
    end;
  except
    result := false;
  end;
end;



function TJrbustcpClient.Write: Boolean;
var
  i,n,size,curindex,index,qnt,qntPos: integer;
  gap: boolean;
begin
  Result := true;

  size := Length(FClTags);
  if Length(FWriteCache) < size then
    SetLength(FWriteCache, length(FClTags));

  qnt := 0;
  for i:=0 to size-1 do
    if FClTags[i].hasWriteValue then
    begin
      FWriteCache[qnt] := i;
      inc(qnt);
    end;

  if qnt > 0 then
  begin
    i := 0;
    while i < qnt do
    begin
      curindex := FWriteCache[i];
      startMessage(CMD_WRITE);
      FBufOut.writeMedium(curindex);
      qntPos := FBufOut.writeIndex;
      FBufOut.writeMedium(0);

      n := 0;
      while i < qnt do
      begin
        if not FBufOut.canWrite then
          Break;

        index := FWriteCache[i];
        gap := curindex <> index;

        if gap then begin
          if index < $10000 then
          begin
            FBufOut.writeByte(VAL_INDEX_SHORT);
            FBufOut.writeWord(index);
          end
          else
          begin
            FBufOut.writeByte(VAL_INDEX_MEDIUM);
            FBufOut.writeMedium(index);
          end;
          curindex := index;
        end;

        FBufOut.writeValue(FClTags[curindex]);
        Inc(i);
        Inc(n);
        Inc(curindex);
      end;

      FBufOut.setMedium(qntPos, n);
      writeAndReadMessage;
    end;
  end;

end;




{*************************** TJrbustcpClientThread ****************************}

procedure TJrbustcpClientThread.Execute;
var
  tm: Cardinal;
begin
  repeat
    tm := GetTickCount;

    try
      parent.setState(STATE_WRITING);
      if not parent.Write then
        Break;

      parent.setState(STATE_READING);
      if not parent.Read then
        Break;
    except
      Break;
    end;

    parent.setState(STATE_SLEEPING);
    while ((GetTickCount - tm) < parent.FPeriod) and (not Terminated) do
      sleep(1);

  until Terminated;

  parent.setState(STATE_TERMINATED);
end;




function TJrbustcpClient.showSettingsDialog: Boolean;
begin
  with TJrbustcpClientPropForm.Create(nil) do
  begin
    clnt := Self;
    result := ShowModal = mrOk;
    Free;
  end;
end;

procedure TJrbustcpClient.setFlag(flag: Integer; value: boolean);
begin
  FFlags := (FFlags and not flag) + iif(value, flag, 0);
end;

procedure TJrbustcpClient.setState(state: integer);
begin
  FState := state;
  FStateDt := Now;
end;

function TJrbustcpClient.getState: string;
var
  s: string;
begin
  case FState of
    STATE_CREATED: s := 'CREATED';
    STATE_WRITING: s := 'WRITING';
    STATE_READING: s := 'READING';
    STATE_SLEEPING: s := 'SLEEPING';
    STATE_TERMINATED: s := 'TERMINATED';
  else
    s := '?';
  end;
  Result := DateTimeToStr(FStateDt) + ': ' + s;
end;

end.
