Sordie.co.uk

libsassy/libSassy.Sockets.pas

Raw

{(
 )) libSassy.Sockets
((    Winsock client/server library
 ))
((  Copyright  Sordie Aranka Solomon-Smith 2015-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.Sockets;

interface

uses
  Winapi.Windows,
  Winapi.WinSock,

  libSassy.DateTime,
  libSassy.Log,
  libSassy.Arrays,
  libSassy.Integers,
  libSassy.Streams,
  libSassy.Strings,
  libSassy.Threads;

type
{$REGION 'TTCPSocket'}
  TTCPSocket = class(TStream)
  private
    fSocket: TSocket;

    fLogObject: TLog;
    fLogPrefix: String;
  public
    Buffer: AnsiString;

    class constructor Create;

    constructor Create(const ASocket: TSocket = 0);
    destructor  Destroy; override;

    procedure Close;

    function Bind   (const Port: Word; const Host: String = '0.0.0.0'):   Integer;
    function Connect(const Port: Word; const Host: String = 'localhost'): Integer;
    function Listen (const BackLog: Integer = 1): Integer; inline;
    function Accept (var SockAddr: TSockAddr): TTCPSocket;

    function InternalRead (var   Data; const Size: Int64): Int64; override;
    function InternalWrite(const Data; const Size: Int64): Int64; override;

    procedure ClearBuffer;

    function ReadAll     (const Timeout: Extended = 0): AnsiString;
    function ReadToBuffer(const Timeout: Extended = 0): Integer;

    function CheckRead: Boolean;
    procedure SetBlocking(const Blocking: Boolean);

    property Socket: TSocket read fSocket;

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

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

{$REGION 'TTCPServer'}
  TTCPSession      = class;
  TTCPSessionClass = class of TTCPSession;

  TTCPServer = class(TThread)
  private
    fSocket: TTCPSocket;

    fSessions: TArray<TTCPSession>;

    fPort: Word;
    fBind: String;

    fSessionClass: TTCPSessionClass;

    fConnectionThrottle: Extended;
    fSessionThrottle:    Extended;

    fMaxConnections:      Integer;
    fMaxConnectionsPerIP: Integer;

    fBlockedIPs: TIntegers;

    fLogObject: TLog;
    fLogPrefix: String;

    fBytesIn:  Int64;
    fBytesOut: Int64;
  public
    constructor Create(const ASessionClass: TTCPSessionClass = nil);
    destructor  Destroy; override;

    procedure ClearSessions;

    function  OnStart: Boolean; override;
    procedure OnStop;           override;

    function OnConnect(const ASocket: TTCPSocket; const ASockAddr: TSockAddr): Boolean; virtual;

    function Execute: Boolean; override;

    property Port: Word   read fPort write fPort;
    property Bind: String read fBind write fBind;

    property Socket: TTCPSocket read fSocket;

    property Sessions:     TArray<TTCPSession> read fSessions;
    property SessionClass: TTCPSessionClass    read fSessionClass write fSessionClass;

    property ConnectionThrottle: Extended read fConnectionThrottle write fConnectionThrottle;
    property SessionThrottle:    Extended read fSessionThrottle    write fSessionThrottle;

    property MaxConnections:      Integer read fMaxConnections      write fMaxConnections;
    property MaxConnectionsPerIP: Integer read fMaxConnectionsPerIP write fMaxConnectionsPerIP;

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

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

    procedure Log(Any: array of const);

    property BytesIn:  Int64 read fBytesIn;
    property BytesOut: Int64 read fBytesOut;
  end;
{$ENDREGION}

{$REGION 'TTCPSession'}
  TTCPSession = class(TThread)
  private
    fSocket: TTCPSocket;
    fServer: TTCPServer;

    fIPv4Int: Integer;
    fIPv4Str: String;

    fLogObject: TLog;
    fLogPrefix: String;

    procedure OnSocketRead (const Size: Int64);
    procedure OnSocketWrite(const Size: Int64);
  public
    constructor Create(const AServer: TTCPServer; const ASocket: TTCPSocket; const ASockAddr: TSockAddr); virtual;
    destructor  Destroy; override;

    procedure OnCreate;  virtual;
    procedure OnDestroy; virtual;

    function Execute: Boolean; override;

    procedure Disconnect;

    property Socket: TTCPSocket read fSocket;
    property Server: TTCPServer read fServer;

    property IPv4Int: Integer read fIPv4Int;
    property IPv4Str: String  read fIPv4Str;

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

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

{$REGION 'Socket functions'}
function GetIPv4FromHost(const HostName: String; var IPv4: String): Boolean;
{$ENDREGION}

implementation

{$REGION 'Socket functions'}
function GetIPv4FromHost;
var
  HEnt: PHostEnt;
  i:    Integer;
begin
  IPv4 := '';

  HEnt := WinApi.WinSock.gethostbyname(PAnsiChar(AnsiString(HostName)));
  if HEnt = nil then exit(False);

  for i := 0 to HEnt^.h_length - 1 do
    IPv4 := IPv4 + String.Int(Ord(HEnt^.h_addr_list^[i])) + '.';

  SetLength(IPv4, Length(IPv4) - 1);

  Result := True;
end;
{$ENDREGION}

{$REGION 'TTCPSocket'}
class constructor TTCPSocket.Create;
var
  WSAData: TWSAData;
begin
  WSAStartup(MakeLong(2, 2), WSAData);
end;

constructor TTCPSocket.Create;
begin
  inherited Create;

  fLogObject := nil;
  fLogPrefix := ClassName;

  if ASocket = 0 then
    fSocket := WinApi.WinSock.socket(PF_INET, SOCK_STREAM, IPPROTO_TCP)
  else
    fSocket := ASocket;

  ClearBuffer;
end;

destructor TTCPSocket.Destroy;
begin
  Close;

  inherited;
end;

procedure TTCPSocket.Close;
begin
  WinApi.WinSock.closesocket(fSocket);
  fSocket := 0;
end;

function TTCPSocket.Bind;
var
  IPv4:   String;
  AddrIn: TSockAddrIn;
begin
  if not GetIPv4FromHost(Host, IPv4) then
    exit(WSAEHOSTUNREACH);

  FillChar(AddrIn, sizeof(AddrIn), 0);

  AddrIn.sin_family      := AF_INET;
  AddrIn.sin_addr.S_addr := inet_addr(PAnsiChar(AnsiString(IPv4)));
  AddrIn.sin_port        := htons(Port);

  Result := WinApi.WinSock.bind(fSocket, AddrIn, sizeof(AddrIn));

  Log(['Bind ', Host, ':', Port, ' (', Result, ')']);
end;

function TTCPSocket.Connect;
var
  IPv4:   String;
  AddrIn: TSockAddrIn;
begin
  if not GetIPv4FromHost(Host, IPv4) then
    exit(WSAEHOSTUNREACH);

  FillChar(AddrIn, sizeof(AddrIn), 0);

  AddrIn.sin_family      := AF_INET;
  AddrIn.sin_addr.S_addr := inet_addr(PAnsiChar(AnsiString(IPv4)));
  AddrIn.sin_port        := htons(Port);

  Result := WinApi.WinSock.connect(fSocket, AddrIn, sizeof(AddrIn));
  Log(['Connect ', Host, ':', Port, ' (', Result, ')']);
end;

function TTCPSocket.Listen;
begin
  Result := WinApi.WinSock.listen(fSocket, BackLog);
  Log(['Listening... (', Result, ')']);
end;

function TTCPSocket.Accept;
var
  FDSet:    TFDSet;
  SockSize: Integer;
  InSocket: TSocket;
begin
  FDSet.fd_count    := 1;
  FDSet.fd_array[0] := fSocket;

  if WinApi.WinSock.select(0, @FDSet, nil, nil, nil) <> 1 then exit(nil);

  SockSize := sizeof(SockAddr);
  InSocket := WinApi.WinSock.accept(fSocket, @SockAddr, @SockSize);

  if InSocket <> 0 then
    Result := TTCPSocket.Create(InSocket)
  else
    Result := nil;
end;

function TTCPSocket.InternalRead;
var
  i: Integer;
begin
  if WinApi.WinSock.ioctlsocket(fSocket, FIONREAD, i) <> 0 then exit(0);
  Result := WinApi.WinSock.recv(fSocket, Data, Size, 0);
end;

function TTCPSocket.InternalWrite;
begin
  Result := WinApi.WinSock.send(fSocket, Data, Size, 0);
end;

procedure TTCPSocket.ClearBuffer;
begin
  Buffer := '';
end;

function TTCPSocket.ReadAll;
  function TryReadAll: AnsiString;
  const
    BufSize = 1024;
  var
    Buf:  AnsiString;
    Len:  Int64;
  begin
    SetLength(Buf, BufSize);

    Result := '';

    repeat
      Len := Read(Buf[1], BufSize);
      if Len <= 0 then break;

      Result := Result + copy(Buf, 1, Len);
    until False;
  end;
var
  Expire: Extended;
begin
  Expire := TickService.Seconds + Timeout;

  repeat
    Result := TryReadAll;
    if Length(Result) > 0 then exit;
  until TickService.Seconds >= Expire;
end;

function TTCPSocket.ReadToBuffer;
var
  Buf: AnsiString;
begin
  Buf    := ReadAll(Timeout);
  Result := Length(Buf);
  Buffer := Buffer + Buf;
end;

function TTCPSocket.CheckRead;
begin
  Result := (fSocket <> 0) and (WinApi.WinSock.recv(fSocket, nil^, 0, MSG_OOB) <> 0);
end;

procedure TTCPSocket.SetBlocking;
var
  b: Integer;
begin
  if Blocking then b := 0 else b := 1;

  WinApi.WinSock.ioctlsocket(fSocket, FIONBIO, b)
end;

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

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

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

  fLogObject := nil;
  fLogPrefix := ClassName;

  fSessions := TArray<TTCPSession>.Create;

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

  if ASessionClass = nil then
    fSessionClass := TTCPSession
  else
    fSessionClass := ASessionClass;

  fPort := 8081;
  fBind := '0.0.0.0';

  fConnectionThrottle := 0.1;
  fSessionThrottle    := 0.001;

  fMaxConnections      := 30;
  fMaxConnectionsPerIP := 2;
end;

destructor TTCPServer.Destroy;
begin
  ClearSessions;
  fSessions.Free;
  fBlockedIPs.Free;

  inherited;
end;

procedure TTCPServer.ClearSessions;
var
  i: Integer;
begin
  CriticalSection.Enter;

  try
    for i := Sessions.Count - 1 downto 0 do
      Sessions[i].Free;
  finally
    CriticalSection.Leave;
  end;
end;

function TTCPServer.OnStart;
begin
  fSocket := TTCPSocket.Create;

  fSocket.fLogObject := fLogObject;
  fSocket.fLogPrefix := fLogPrefix;

  if fSocket.Bind(fPort, fBind) <> 0 then exit(False);
  if fSocket.Listen <> 0 then exit(False);

  fBytesIn  := 0;
  fBytesOut := 0;

  Result := inherited;
end;

procedure TTCPServer.OnStop;
begin
  ClearSessions;

  fSocket.Free;

  inherited;
end;

function TTCPServer.OnConnect;
begin
  Result := True;
end;

function TTCPServer.Execute;
var
  i:        Integer;
  InSocket: TTCPSocket;
  Session:  TTCPSession;
  SockAddr: TSockAddr;
begin
  Result := True;

  TickService.Sleep(fConnectionThrottle);

  if Sessions.Count >= MaxConnections then exit;

  InSocket := fSocket.Accept(SockAddr);
  if InSocket = nil then exit;

  if fBlockedIPs.Exists(SockAddr.sin_addr.S_addr) then
  begin
    InSocket.Free;
    exit;
  end;

  CriticalSection.Enter;
  try
    i := 0;

    for Session in Sessions do
      if Session.IPv4Int = SockAddr.sin_addr.S_addr then
      begin
        inc(i);

        if i = MaxConnectionsPerIP then
        begin
          InSocket.Free;
          exit;
        end;
      end;
  finally
    CriticalSection.Leave;
  end;

  if not OnConnect(InSocket, SockAddr) then
  begin
    InSocket.Free;
    exit;
  end;

  Session := TTCPSession(fSessionClass.NewInstance);
  Session.Create(Self, InSocket, SockAddr);
  Session.FreeOnStop := True;

  Session.fLogObject := fLogObject;
end;

function TTCPServer.SessionExecute;
begin
  Result := True;
end;

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

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

{$REGION 'TTCPSession'}
procedure TTCPSession.OnSocketRead;
begin
  if Size > 0 then
    InterlockedCompareExchange64(fServer.fBytesIn, fServer.fBytesIn + Size, fServer.fBytesIn);
end;

procedure TTCPSession.OnSocketWrite;
begin
  if Size > 0 then
    InterlockedCompareExchange64(fServer.fBytesOut, fServer.fBytesOut + Size, fServer.fBytesOut);
end;

constructor TTCPSession.Create;
begin
  inherited Create;

  fServer    := AServer;
  fSocket    := ASocket;
  FreeOnStop := True;

  fLogObject         := fServer.fLogObject;
  fSocket.fLogObject := fLogObject;

  fIPv4Str := String(inet_ntoa(ASockAddr.sin_addr));
  fIPv4Int := ASockAddr.sin_addr.S_addr;

  fLogPrefix         := fIPv4Str;
  fSocket.fLogPrefix := fIPv4Str;

  fSocket.SetBlocking(False);

  fSocket.OnRead  := OnSocketRead;
  fSocket.OnWrite := OnSocketWrite;

  fServer.CriticalSection.Section(procedure
  begin
    fServer.fSessions.Add(Self);
  end);

  Log(['Session started']);

  OnCreate;

  Start;
end;

destructor TTCPSession.Destroy;
begin
  OnDestroy;

  fServer.CriticalSection.Section(procedure
  var
    i: Integer;
  begin
    for i := fServer.fSessions.Count - 1 downto 0 do
      if fServer.fSessions[i] = Self then
      begin
        fServer.fSessions.Delete(i);
        break;
      end;
  end);

  Log(['Session ended']);

  fSocket.Free;

  inherited;
end;

procedure TTCPSession.OnCreate;
begin

end;

procedure TTCPSession.OnDestroy;
begin

end;

function TTCPSession.Execute;
begin
  if not fSocket.CheckRead then exit(False);

  TickService.Sleep(fServer.fSessionThrottle);

  Result := fServer.SessionExecute(Self);
end;

procedure TTCPSession.Disconnect;
begin
  Socket.Close;
end;

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

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

end.