Sordie.co.uk

libsassy/libSassy.Protocol.pas

Raw

{(
)) libSassy.Protocol
((    Base protocol for client/server applications
))
((  Copyright  Sordie Aranka Solomon-Smith 2016-2017
))
((  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;

interface

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

const
{$REGION 'Packet families'}
  PacketFamilyProtocol = 1;
  PacketFamilyAccount  = 2;
{$ENDREGION}

{$REGION 'Packet actions'}
  PacketActionReply   = 1;
  PacketActionRequest = 2;
  PacketActionOpen    = 3;
  PacketActionClose   = 4;
  PacketActionNew     = 5;
  PacketActionDelete  = 6;
  PacketActionRefresh = 7;
  PacketActionUpdate  = 8;
{$ENDREGION}

{$REGION 'Packet replies'}
  PacketReplyOK          = 1;
  PacketReplyFailed      = 2;
  PacketReplyExists      = 3;
  PacketReplyDoesntExist = 4;
  PacketReplyMatch       = 5;
  PacketReplyMismatch    = 6;
  PacketReplyValid       = 7;
  PacketReplyInvalid     = 8;
{$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'}
  TSession = class;
  TSessionClass = class of TSession;

  TServer = class(TTCPServer)
  private
    fIDPool: TIntegers;

    fPacketTimeout: Extended;
    fHeartbeatTime: Extended;

    fInvalidSequenceMax: Integer;

    fSessionClass: TSessionClass;

    fServerID: String;
  public
    constructor Create(const ASessionClass: TSessionClass = nil);
    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;

    property InvalidSequenceMax: Integer read fInvalidSequenceMax write fInvalidSequenceMax;

    property ServerID: String read fServerID;
  end;
{$ENDREGION}

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

    fInitialized: Boolean;

    fPacketTimeout: TStopwatch;
    fHeartbeat:     TStopwatch;

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

    fInvalidSequenceCount: Integer;

    fClientID: String;
    fUID:      String;

    procedure SetKey(Index: Integer; Value: Cardinal);
  public
    Reply: TPacket;

    procedure OnCreate; override;
    procedure OnDestroy; override;

    procedure Initialize;

    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 ClientID: String read fClientID;
    property UID:      String read fUID;

    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;

    fPacketTimer:   TStopwatch;
    fPacketTimeout: Extended;

    fClientID: String;
    fServerID: String;

    fLogObject: TLog;
    fLogPrefix: String;

    fInitialized: Boolean;
  public
    Reply: TPacket;

    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 Initialize;

    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 PacketTimeout: Extended read fPacketTimeout write fPacketTimeout;

    property Initialized: Boolean read fInitialized;

    property ClientID: String read fClientID;
    property ServerID: String read fServerID;

    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;

  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(Byte(Family))
          + AnsiChar(Action)

          + AnsiChar(Sequence)

          + Buffer;

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

{$REGION 'TServer'}
constructor TServer.Create;
begin
  if ASessionClass = nil then
    fSessionClass := TSession
  else
    fSessionClass := ASessionClass;

  inherited Create(fSessionClass);

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

  fHeartbeatTime := 10;
  fPacketTimeout := 30;

  fInvalidSequenceMax := 10;

  fServerID := ClassName;
end;

destructor TServer.Destroy;
begin
  inherited;

  fIDPool.Free;
end;

function TServer.SessionExecute;
var
  Packet: TPacket;
  Seq: Byte;
begin
  with Session as TSession do
  begin
    if fPacketTimeout.Expired(Server.fPacketTimeout) then
    begin
      Log(['Packet timed out']);
      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
      Log(['Packet CRC mismatch']);
      Exit(False);
    end;

    Seq := fSequence.Next($FF);

    if Packet.Sequence <> Seq then
    begin
      inc(fInvalidSequenceCount);

      if fInvalidSequenceCount >= fInvalidSequenceMax then
      begin
        Log(['Max packets out of sequence']);
        Exit(False);
      end;

      if Packet.Family <> PacketFamilyProtocol then
        Heartbeat;
    end
    else
      fInvalidSequenceCount := 0;

    Reply.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:
    begin
      fSendKey := Value;
      Log(['Send key updated: ', Value]);
    end;

    1:
    begin
      fReceiveKey := Value;
      Log(['Receive key updated: ', Value]);
    end;
  end;

  Heartbeat;
end;

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

  fPacketTimeout.Reset;
  fHeartbeat.Reset;

  fInvalidSequenceCount := 0;

  Initialize;
end;

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

procedure TSession.Initialize;
var
  Packet: TPacket;
begin
  Packet.Reset(PacketFamilyProtocol, PacketActionOpen);

  fSendKey    := $11;
  fReceiveKey := $22;

  fClientID := '';
  fUID      := '';

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

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

  Packet.AddBreakString(fServer.fServerID);

  Send(Packet);

  fInitialized := True;
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, PacketActionRefresh);

  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 HandleProtocolOpen;
  begin
    fClientID := Packet.GetBreakString;
    fUID      := Packet.GetBreakString;

    Log(['Initialized. ClientID:', fClientID, ' UID:', fUID]);

    fInitialized := True;
  end;
  procedure HandleProtocolRefresh;
  begin
    // TODO: Calculate latency
  end;
begin
  case Packet.Action of
    PacketActionOpen:    HandleProtocolOpen;
    PacketActionRefresh: HandleProtocolRefresh;
  else
    UnhandledAction(Packet);
  end;
end;
{$ENDREGION}

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

  fLogObject := nil;
  fLogPrefix := ClassName;

  fPacketTimeout := 30;

  fClientID := ClassName;
  fServerID := '';

  fSocket := nil;
  Disconnect;
end;

destructor TClient.Destroy;
begin
  Disconnect;

  inherited;
end;

function TClient.Connect;
begin
  Disconnect;

  Log(['Connecting to ', fHost, ':', fPort, '...']);
  fSocket := TTCPSocket.Create;
  Result := fSocket.Connect(fPort, fHost) = 0;

  Log(['Connection ', Result]);
  if Result then
    fSocket.SetBlocking(False);

  fPacketTimer.Reset;
end;

function TClient.Disconnect;
begin
  if fSocket <> nil then
  begin
    Log(['Disconnecting']);

    fSocket.Free;
    fSocket := nil;
  end;

  fID := -1;
  fInitialized := False;

  Result := True;
end;

function TClient.Send;
begin
  Packet.Sequence := fSequence.Next($FF);
  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
  if (Socket = nil) or (not Socket.CheckRead) then
  begin
    Log(['Server connection closed']);
    fInitialized := False;
    Exit(False);
  end;

  if fPacketTimer.Expired(fPacketTimeout) then
  begin
    Log(['Packet timed out']);
    fInitialized := False;
    Exit(False);
  end;

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

  if not Packet.CRCMatch then
  begin
    Log(['Packet CRC mismatch']);
    fInitialized := False;
    Exit(False);
  end;

  Reply.Reset(Packet.Family, PacketActionReply);
  Dispatch(Packet);

  Result := (Socket.Socket <> 0) and fInitialized;
end;

procedure TClient.Initialize;
var
  Packet: TPacket;
begin
  Packet.Reset(PacketFamilyProtocol, PacketActionOpen);

  Packet.AddBreakString(fClientID);
  Packet.AddBreakString(libSassy.System.HDDID);

  fInitialized := Send(Packet);
end;

procedure TClient.HandleProtocol;
  procedure HandleProtocolOpen;
  begin
    fReceiveKey := Packet.GetDWord;
    fSendKey := Packet.GetDWord;
    fSequence.Seed := Packet.GetDWord;

    fServerID := Packet.GetBreakString;

    Log(['Initialized. Server:', fServerID]);

    Initialize;
  end;
  procedure HandleProtocolClose;
  begin
    Disconnect;
  end;
  procedure HandleProtocolRefresh;
  begin
    fReceiveKey := Packet.GetDWord;
    fSendKey := Packet.GetDWord;

    fSequence.Seed := Packet.GetDWord;

    Reply.Reset(PacketFamilyProtocol, PacketActionRefresh);
    Send(Reply);
  end;
begin
  case Packet.Action of
    PacketActionOpen:    HandleProtocolOpen;
    PacketActionClose:   HandleProtocolClose;
    PacketActionRefresh: HandleProtocolRefresh;
  else
    UnhandledAction(Packet);
  end;
end;

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

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

end.