Sordie.co.uk

libsassy/libSassy.Protocol_old.pas

Raw

{(
 )) libSassy.Protocol
((    Base protocol for client/server applications
 ))
((  Copyright  Sordie Aranka Solomon-Smith 2016
 ))
((  This work is made available under the terms of the Creative Commons
 )) Attribution-NonCommercial-ShareAlike 3.0 Unported license
((  http://creativecommons.org/licenses/by-nc-sa/3.0/
 )}

unit libSassy.Protocol_old;

interface

uses
  libSassy.Interfaces,
  libSassy.Sockets,
  libSassy.Arrays,
  libSassy.DateTime,
  libSassy.Integers,
  libSassy.Strings,
  libSassy.Hash,
  libSassy.Random,
  libSassy.Log;

const
{$REGION 'Packet families'}
  PacketFamilyProtocol = 255;
{$ENDREGION}

{$REGION 'Packet actions'}
  PacketActionReply      = 1;
  PacketActionHeartbeat  = 254;
  PacketActionInitialize = 255;
{$ENDREGION}

type
{$REGION 'TPacket'}
  TPacket = record
    Family:   Integer;
    Action:   Byte;
    Sequence: Byte;
    CRC:      Cardinal;
    Data:     AnsiString;

    procedure Reset(const PacketFamily: Byte; const PacketAction: Byte);
    procedure Clear;

    procedure CRCUpdate;
    function  CRCMatch: Boolean;

    class procedure Cipher(var Buffer: AnsiString; const Key: Cardinal); static;

    procedure AddByte (const a: Byte);     inline;
    procedure AddWord (const a: Word);     inline;
    procedure AddDWord(const a: Cardinal); inline;

    procedure AddBreakString(const a: String); inline;
    procedure AddString     (const a: String);

    procedure AddBreakAnsiString(const a: AnsiString); inline;
    procedure AddAnsiString     (const a: AnsiString); inline;

    procedure AddData(const D; const Size: Integer);

    function GetByte:  Byte;
    function GetWord:  Word;
    function GetDWord: Cardinal;

    function GetBreakString: String;
    function GetString(const Len: Integer = -1):String;

    function GetBreakAnsiString: AnsiString;
    function GetAnsiString(const Len: Integer = -1): AnsiString;

    function GetData(var D; const Size: Integer): Integer;

    function Receive(Socket: TTCPSocket; const Key: Cardinal): Boolean;
    function Send   (Socket: TTCPSocket; const Key: Cardinal): Boolean;
  end;
{$ENDREGION}

{$REGION 'TServer'}
  TServer = class(TTCPServer)
  private
    fIDPool: TIntegers;

    fPacketTimeout: Extended;
    fHeartbeatTime: Extended;
  public
    constructor Create;
    destructor  Destroy; override;

    function SessionExecute(Session: TTCPSession): Boolean; override;

    property IDPool: TIntegers read fIDPool;

    property PacketTimeout: Extended read fPacketTimeout write fPacketTimeout;
    property HeartbeatTime: Extended read fHeartbeatTime write fHeartbeatTime;
  end;
{$ENDREGION}

{$REGION 'TSession'}
  TSession = class(TTCPSession)
  private
    fServer: TServer;
    fID:     Integer;

    fInitialized: Boolean;

    fPacketTimeout: TTimer;
    fHeartbeat:     TTimer;

    fSendKey:    Cardinal;
    fReceiveKey: Cardinal;
    fSequence:   TRandom;

    fReply: TPacket;

    procedure SetKey(Index: Integer; Value: Cardinal);
  public
    procedure OnCreate;  override;
    procedure OnDestroy; override;

    function Heartbeat: Boolean;

    function Send(Packet: TPacket): Boolean; inline;

    procedure DefaultHandler (var Param); override;
    procedure UnhandledAction(var Packet: TPacket);

    procedure HandleProtocol(var Packet: TPacket); message PacketFamilyProtocol;

    property Server: TServer read fServer;
    property ID:     Integer read fID;

    property Initialized: Boolean read fInitialized write fInitialized;

    property SendKey:    Cardinal index 0 read fSendKey     write SetKey;
    property ReceiveKey: Cardinal index 1 read fReceiveKey  write SetKey;
  end;
{$ENDREGION}

{$REGION 'TClient'}
  TClient = class(TInterface)
  private
    fSocket: TTCPSocket;

    fHost: String;
    fPort: Word;

    fID: Integer;

    fSendKey:    Cardinal;
    fReceiveKey: Cardinal;
    fSequence:   TRandom;

    fReply: TPacket;

    fLogObject: TLog;
    fLogPrefix: String;
  public
    constructor Create;
    destructor  Destroy; override;

    function Connect:    Boolean;
    function Disconnect: Boolean;

    function Send(Packet: TPacket): Boolean; inline;

    function Execute: Boolean;

    procedure DefaultHandler (var Param); override;
    procedure UnhandledAction(var Packet: TPacket);

    procedure HandleProtocol(var Packet: TPacket); message PacketFamilyProtocol;

    property Socket: TTCPSocket read fSocket;

    property Host: String read fHost write fHost;
    property Port: Word   read fPort write fPort;

    property ID: Integer read fID;

    property SendKey:    Cardinal read fSendKey;
    property ReceiveKey: Cardinal read fReceiveKey;

    property LogObject: TLog   read fLogObject write fLogObject;
    property LogPrefix: String read fLogPrefix write fLogPrefix;

    procedure Log(Any: array of const);
  end;
{$ENDREGION}

implementation

{$REGION 'TPacket'}
procedure TPacket.Reset(const PacketFamily: Byte; const PacketAction: Byte);
begin
  Family := PacketFamily;
  Action := PacketAction;

  Clear;
end;

procedure TPacket.Clear;
begin
  Data := '';
  CRC  := 0;
end;

procedure TPacket.CRCUpdate;
begin
  CRC := String.Base(TCRC32.HashAnsiStr(AnsiChar(Family) + AnsiChar(Action) + AnsiChar(Sequence) + Data), 16);
end;

function TPacket.CRCMatch;
begin
  Result := String.Base(TCRC32.HashAnsiStr(AnsiChar(Family) + AnsiChar(Action) + AnsiChar(Sequence) + Data), 16) = CRC;
end;

class procedure TPacket.Cipher;
var
  i:   Integer;
  Cip: TRandom;
begin
  Cip.Seed := Key;

  for i := 1 to Length(Buffer) do
    Buffer[i] := AnsiChar(Ord(Buffer[i]) xor Byte(Cip.Next(256)));
end;

procedure TPacket.AddByte;
begin
  Data := Data +
          AnsiChar(a);
end;

procedure TPacket.AddWord;
begin
  Data := Data +
          AnsiChar((a shr 8) and $FF) +
          AnsiChar( a        and $FF);
end;

procedure TPacket.AddDWord;
begin
  Data := Data +
          AnsiChar((a shr 24) and $FF) +
          AnsiChar((a shr 16) and $FF) +
          AnsiChar((a shr  8) and $FF) +
          AnsiChar( a         and $FF);
end;

procedure TPacket.AddBreakString;
begin
  AddString(a + #0);
end;

procedure TPacket.AddString;
var
  Buf: AnsiString;
begin
  SetLength(Buf, Length(a) * SizeOf(Char));
  Move(a[1], Buf[1], Length(Buf));

  Data := Data + Buf;
end;

procedure TPacket.AddBreakAnsiString;
begin
  AddAnsiString(a + AnsiChar(#0));
end;

procedure TPacket.AddAnsiString;
begin
  Data := Data + a;
end;

procedure TPacket.AddData;
var
  Buf: AnsiString;
begin
  SetLength(Buf, Size);
  Move(D, Buf[1], Length(Buf));

  Data := Data + Buf;
end;

function TPacket.GetByte;
begin
  if Length(Data) = 0 then exit(0);

  Result := Ord(Data[1]);
  Data   := Copy(Data, 2, Length(Data));
end;

function TPacket.GetWord;
begin
  if Length(Data) = 0 then exit(0);
  if Length(Data) = 1 then exit(GetByte);

  Result := (Ord(Data[1]) shl 8) or Ord(Data[2]);
  Data   := Copy(Data, 3, Length(Data));
end;

function TPacket.GetDWord;
begin
  if Length(Data) = 0 then exit(0);
  if Length(Data) = 1 then exit(GetByte);
  if Length(Data) = 2 then exit(GetWord);

  if Length(Data) = 3 then
  begin
    Result := (Ord(Data[1]) shl 16) or
              (Ord(Data[2]) shl  8) or
               Ord(Data[3]);

    Data := Copy(Data, 4, Length(Data));
  end
  else
  begin
    Result := (Ord(Data[1]) shl 24) or
              (Ord(Data[2]) shl 16) or
              (Ord(Data[3]) shl 8)  or
               Ord(Data[4]);

    Data := Copy(Data, 5, Length(Data));
  end;
end;

function TPacket.GetBreakString;
var
  i: Integer;
begin
  for i := 1 to Length(Data) div SizeOf(Char) do
    if PChar(@Data[1])[i] = #0 then break;

  SetLength(Result, i);
  System.Move(Data[1], Result[1], Length(Result) * SizeOf(Char));

  Data := Copy(Data, ((Result.Length + 1) * SizeOf(Char)) + 1, Length(Data));
end;

function TPacket.GetString;
begin
  if (Len = -1) or (Len >= (Length(Data) div SizeOf(Char))) then
  begin
    SetLength(Result, Length(Data) div SizeOf(Char));
    System.Move(Data[1], Result[1], Result.Length * SizeOf(Char));
    Data := '';
  end
  else
  begin
    SetLength(Result, Len);
    System.Move(Data[1], Result[1], Result.Length * SizeOf(Char));
    Data := Copy(Data, Len * SizeOf(Char), Length(Data));
  end;
end;

function TPacket.GetBreakAnsiString;
var
  i: Integer;
begin
  for i := 1 to length(Data) do
    if Data[i] = #0 then break;

  Result := Copy(Data, 1, i - 1);
  Data   := Copy(Data, i + 1, Length(Data));
end;

function TPacket.GetAnsiString;
begin
  if Len = -1 then
  begin
    Result := Data;
    Data   := '';
  end
  else
  begin
    Result := Copy(Data, 1, Len);
    Data   := Copy(Data, Len + 1, Length(Data));
  end;
end;

function TPacket.GetData;
begin
  if Size > Length(Data) then Result := Length(Data) else Result := Size;
  System.Move(Data[1], D, Result);
  Data := copy(Data, Result + 1, Length(Data));
end;

function TPacket.Receive;
var
  i: Cardinal;
begin
  Socket.ReadToBuffer(500);

  if Length(Socket.Buffer) < 11 then Exit(False);

  i :=  Ord(Socket.Buffer[1]) or
       (Ord(Socket.Buffer[2]) shl  8) or
       (Ord(Socket.Buffer[3]) shl 16) or
       (Ord(Socket.Buffer[4]) shl 24);

  if Cardinal(Length(Socket.Buffer)) < i + 11 then Exit(False);

  CRC :=  Ord(Socket.Buffer[5])         or
         (Ord(Socket.Buffer[6]) shl  8) or
         (Ord(Socket.Buffer[7]) shl 16) or
         (Ord(Socket.Buffer[8]) shl 24);


  Family   := Ord(Socket.Buffer[9]);
  Action   := Ord(Socket.Buffer[10]);
  Sequence := Ord(Socket.Buffer[11]);
  Data     := Copy(Socket.Buffer, 12, i);

  Socket.Buffer := Copy(Socket.Buffer, i + 12, Length(Socket.Buffer));

  if Family <> PacketFamilyProtocol then Cipher(Data, Key);

  Result := True;
end;

function TPacket.Send;
var
  Buffer: AnsiString;
  Len:    Cardinal;
begin
  Len    := Length(Data);
  Buffer := Data;

  CRCUpdate;

  if Family <> PacketFamilyProtocol then Cipher(Buffer, Key);

  Buffer := AnsiChar( Len         and $FF) +
            AnsiChar((Len shr 8)  and $FF) +
            AnsiChar((Len shr 16) and $FF) +
            AnsiChar((Len shr 24) and $FF) +

            AnsiChar( CRC         and $FF) +
            AnsiChar((CRC shr  8) and $FF) +
            AnsiChar((CRC shr 16) and $FF) +
            AnsiChar((CRC shr 24) and $FF) +

            AnsiChar(Family) +
            AnsiChar(Action) +

            Buffer;

  Result := Socket.Write(Buffer[1], Length(Buffer)) = Length(Buffer);
end;
{$ENDREGION}

{$REGION 'TServer'}
constructor TServer.Create;
begin
  inherited Create(TSession);

  fIDPool := TIntegers.Create;
  fIDPool.AllowDuplicates := False;
end;

destructor TServer.Destroy;
begin
  inherited;

  fIDPool.Free;
end;

function TServer.SessionExecute;
var
  Packet:    TPacket;
  SeqClient: Word;
  SeqServer: Word;
begin
  with Session as TSession do
  begin
    if fPacketTimeout.Expired(Server.fPacketTimeout) then
    begin
      Exit(False);
    end;

    if fHeartbeat.Expired(Server.fHeartbeatTime) then
      Heartbeat;

    if not Packet.Receive(Socket, ReceiveKey) then Exit(True);
    fPacketTimeout.Reset;

    if not Packet.CRCMatch then
    begin
      Exit(False);
    end;

    if Packet.Family <> PacketFamilyProtocol then
    begin
      if not Initialized then
      begin
        Exit(False);
      end;

      SeqClient := Packet.GetWord;
      SeqServer := Word(fSequence.Next($FFFF));

      if SeqClient <> SeqServer then
      begin
        Exit(False);
      end;
    end;

    fReply.Reset(Packet.Family, PacketActionReply);

    Dispatch(Packet);

    Result := Initialized;
  end;
end;
{$ENDREGION}

{$REGION 'TSession'}
procedure TSession.SetKey(Index: Integer; Value: Cardinal);
begin
  case Index of
    0: fSendKey    := Value;
    1: fReceiveKey := Value;
  end;

  Heartbeat;
end;

procedure TSession.OnCreate;
begin
  fServer      := TServer(inherited Server);
  fID          := Server.fIDPool.AllocUID;
  fInitialized := False;

  fPacketTimeout.Reset;
  fHeartbeat.Reset;

  fSendKey    := 0;
  fReceiveKey := 0;
end;

procedure TSession.OnDestroy;
begin
  Server.fIDPool.FreeUID(fID);
end;

function TSession.Heartbeat;
var
  Packet: TPacket;
begin
  if not Initialized then Exit(False);
  if Length(Socket.Buffer) > 0 then Exit(False);

  Packet.Reset(PacketFamilyProtocol, PacketActionHeartbeat);

  Packet.AddDWord(fSendKey);
  Packet.AddDWord(fReceiveKey);

  fSequence.Randomize;
  Packet.AddDWord(fSequence.Seed);

  Result := Send(Packet);

  if Result then
    fHeartbeat.Reset;
end;

function TSession.Send;
begin
  Result := Packet.Send(Socket, fSendKey)
end;

procedure TSession.DefaultHandler;
begin
  Log(['Unhandled packet family ', TPacket(Param).Family]);
end;

procedure TSession.UnhandledAction;
begin
  Log(['Unhandled packet action ', Packet.Family, '-', Packet.Action]);
end;

procedure TSession.HandleProtocol;
  procedure HandleProtocolHeartbeat;
  begin

  end;

  procedure HandleProtocolInitialize;
  begin
    fHeartbeat.Reset;
    Initialized := True;
  end;
begin
  case Packet.Action of
    PacketActionHeartbeat:  HandleProtocolHeartbeat;
    PacketActionInitialize: HandleProtocolInitialize;
  else
    UnhandledAction(Packet);
  end;
end;
{$ENDREGION}

{$REGION 'TClient'}
constructor TClient.Create;
begin
  inherited;

  fLogObject := nil;
  fLogPrefix := ClassName;

  fSocket := TTCPSocket.Create;
  Disconnect;
end;

destructor TClient.Destroy;
begin
  Disconnect;
  fSocket.Free;

  inherited;
end;

function TClient.Connect;
begin
  Disconnect;
  Log(['Connecting to ', fHost, ':', fPort, '...']);
  Result := fSocket.Connect(fPort, fHost) = 0;
  Log(['Connection ', Result]);
end;

function TClient.Disconnect;
begin
  if fSocket.Socket = 0 then Exit(True);

  Log(['Disconnecting']);
  fSocket.Close;
  fID := -1;
  Result := fSocket.Socket = 0;
end;

function TClient.Send;
begin
  Result := Packet.Send(Socket, fSendKey)
end;

procedure TClient.DefaultHandler;
begin
  Log(['Unhandled packet family ', TPacket(Param).Family]);
end;

procedure TClient.UnhandledAction;
begin
  Log(['Unhandled packet action ', Packet.Family, '-', Packet.Action]);
end;

function TClient.Execute;
var
  Packet: TPacket;
begin
  Result := True;

  if not Packet.Receive(Socket, ReceiveKey) then Exit(True);

  fReply.Reset(Packet.Family, PacketActionReply);
  Dispatch(Packet);
end;

procedure TClient.HandleProtocol;
  procedure HandleProtocolHeartbeat;
  begin
    fReceiveKey := Packet.GetDWord;
    fSendKey    := Packet.GetDWord;

    fSequence.Seed := Packet.GetDWord;
  end;

  procedure HandleProtocolInitialize;
  begin

  end;
begin
  case Packet.Action of
    PacketActionHeartbeat:  HandleProtocolHeartbeat;
    PacketActionInitialize: HandleProtocolInitialize;
  else
    UnhandledAction(Packet);
  end;
end;

procedure TClient.Log;
begin
  if fLogObject = nil then exit;

  fLogObject.Log(Any, fLogPrefix);
end;
{$ENDREGION}

end.