//////////////////////////////////////////////////
//  Copyright © 1998-2014 Devart. All right reserved.
//////////////////////////////////////////////////

{$IFNDEF CLR}
{$I Dac.inc}
unit CRVioTcp;
{$ENDIF}

interface

uses
  Classes, SysUtils,
{$IFNDEF CLR}
  CLRClasses,
{$ENDIF}
{$IFDEF MSWINDOWS}
  {$IFNDEF FPC}
  {$IFNDEF BCB}
  {$NOINCLUDE winsock}
  {$HPPEMIT '#include <winsock2.h>'}
  {$ENDIF}
  {$ENDIF}
  WinSock,
{$ENDIF}
{$IFDEF UNIX}
  sockets, baseunix, unix, netdb,
{$ENDIF}
  CRTypes, CRVio;

const
  LOCAL_HOST = 'localhost';
  DefaultTimeOut = 30;

type
  SocketException = class(Exception);

  TCRVioTcp = class(TCRVio)
  private
  protected
    FHostname: string;
    FPort: integer;
    FConnectionTimeout: integer;
    FSendTimeout: integer;
    FReceiveTimeout: integer;
    FIPVersion: TIPVersion;

    FSd: NativeInt;

    procedure SetHost(const Value: string);
    procedure SetPort(const Value: integer);
    procedure SetIPVersion(const Value: TIPVersion);
    function GetTimeout: integer; override;
    procedure SetTimeout(Value: integer); override;
    procedure SetConnectionTimeout(const Value: integer);
    procedure SetSendTimeout(const Value: integer);
    procedure SetReceiveTimeout(const Value: integer);
    function InternalConnect: boolean;

    procedure Init;

  public
    constructor Create; overload;
    constructor Create(const hostname: string; const port: integer; IPVersion: TIPVersion = ivIPv4); overload;

    function TryConnect: Boolean; override;
    procedure Connect; override;
    procedure Close; override;

    function ReadNoWait({$IFDEF CLR}var{performance opt}{$ENDIF} buffer: TValueArr; offset, count: integer): integer; override;
    function WriteNoWait(const{performance opt} buffer: TValueArr; offset, count: integer): integer; override;
    function Write(const buffer: TValueArr; offset, count: integer): integer; override;
    function WaitForData(Timeout: integer = -1): boolean; override;
    function IsActive: boolean;

    function GetSocket: longint; virtual;
    property ConnectionTimeout: integer read FConnectionTimeout write SetConnectionTimeout;
    property SendTimeout: integer read FSendTimeout write SetSendTimeout;
    property ReceiveTimeout: integer read FReceiveTimeout write SetReceiveTimeout;
    property Host: string read FHostname write SetHost;
    property Port: integer read FPort write SetPort;
    property IPVersion: TIPVersion read FIPVersion write SetIPVersion;
  end;

  TConnector = class(TThread)
  private
    {$IFDEF AUTOREFCOUNT}[weak]{$ENDIF}
    FVio: TCRVioTcp;
  protected
    procedure Execute; override;
  public
    constructor Create(Vio: TCRVioTcp);
  end;

const
  {$EXTERNALSYM SD_SEND}
  SD_SEND = 1;
  {$EXTERNALSYM SD_BOTH}
  SD_BOTH = 2;
{$IFNDEF MSWINDOWS}
  SOCKET_ERROR = -1;
  {$EXTERNALSYM SOCKET_ERROR}
{$ENDIF}

implementation

uses
{$IFDEF MSWINDOWS}
  Windows, SyncObjs,
{$ENDIF}
{$IFDEF POSIX}
  Posix.ArpaInet, Posix.Errno, Posix.Fcntl,
  Posix.NetDB, Posix.NetinetIn, Posix.NetinetTCP,
  Posix.SysSocket, Posix.UniStd,
  Posix.SysTime, Posix.SysSelect,
{$ENDIF}
  CRFunctions;

{$I CRSocketImpl.inc}

{ TCRVioTcp }

constructor TCRVioTcp.Create;
begin
  inherited Create;

  FHostname := '';
  FPort := 0;
  FIPVersion := ivIPv4;

  Init;
end;

constructor TCRVioTcp.Create(const hostname: string; const port: integer; IPVersion: TIPVersion = ivIPv4);
begin
  inherited Create;

  FHostname := hostname;
  FPort := port;
  FIPVersion := IPVersion;

  Init;
end;

procedure TCRVioTcp.Init;
begin
  FSd := SOCKET_ERROR;
  FConnectionTimeout := 0;
  FReceiveTimeout := DefaultTimeOut;
  FSendTimeout := 0;
end;

procedure TCRVioTcp.SetHost(const Value: string);
begin
  if IsActive then begin
    FLastErrorCode := 0;
    FLastError := 'Cannot change host for the active connection';
    raise SocketException.Create(FLastError);
  end
  else
    FHostname := Value;
end;

procedure TCRVioTcp.SetPort(const Value: integer);
begin
  if IsActive then begin
    FLastErrorCode := 0;
    FLastError := 'Cannot change port for the active connection';
    raise SocketException.Create(FLastError);
  end
  else
    FPort := Value;
end;

procedure TCRVioTcp.SetIPVersion(const Value: TIPVersion);
begin
  if IsActive then begin
    FLastErrorCode := 0;
    FLastError := 'Cannot change TCP/IP version for the active connection';
    raise SocketException.Create(FLastError);
  end
  else
    FIPVersion := Value;
end;

function TCRVioTcp.GetTimeout: integer;
begin
  Result := FReceiveTimeout;
end;

procedure TCRVioTcp.SetTimeout(Value: integer);
begin
  SetReceiveTimeout(Value);
  SetConnectionTimeout(Value);
end;

procedure TCRVioTcp.SetConnectionTimeout(const Value: integer);
begin
  FConnectionTimeout := Value;
end;

procedure TCRVioTcp.SetSendTimeout(const Value: integer);
begin
  if Value <> FSendTimeout then begin
    FSendTimeout := Value;
    Set_SendTimeout(FSd, FSendTimeout);
  end;
end;

procedure TCRVioTcp.SetReceiveTimeout(const Value: integer);
begin
  if Value <> FReceiveTimeout then begin
    FReceiveTimeout := Value;
    Set_ReceiveTimeout(FSd, FReceiveTimeout);
  end;
end;

function TCRVioTcp.InternalConnect: boolean;
var
  HostAddrInfo: PAddrInfo;
  RetVal: integer;
begin
  Result := False;

  RetVal := GetHostAddrInfo(FHostname, FIPVersion, HostAddrInfo);
  try
    if RetVal <> 0 then begin
      FLastErrorCode := GetSocketError;
      FLastError := Format('Unknown host ''%s''.'#$D#$A'Socket Error Code: %d($%X)', [FHostname, LastErrorCode, LastErrorCode]);
      exit;
    end;

    Assert(HostAddrInfo <> nil);
    FSd := SocketCreate(HostAddrInfo.ai_addr);
    if FSd = SOCKET_ERROR then begin
      FLastErrorCode := GetSocketError;
      FLastError := Format('Cannot create TCP/IP socket:'#$D#$A'%s.'#$D#$A'Socket Error Code: %d($%X)', [SysErrorMessage(FLastErrorCode), FLastErrorCode, FLastErrorCode]);
      exit;
    end;

    {$IFDEF POSIX}Psockaddr_in{$ENDIF}(HostAddrInfo.ai_addr).sin_port := htons(FPort);

  {$IFDEF UNIX}
    if (fpconnect(FSd, HostAddrInfo.ai_addr, HostAddrInfo.ai_addrlen) < 0)
  {$ENDIF}
  {$IFDEF POSIX}
    if (Posix.SysSocket.connect(FSd, HostAddrInfo.ai_addr^, HostAddrInfo.ai_addrlen) < 0)
  {$ENDIF}
  {$IFDEF MSWINDOWS}
    if (WinSock.connect(FSd, HostAddrInfo.ai_addr^, HostAddrInfo.ai_addrlen) < 0)
      and (WSAGetLastError <> WSAEWOULDBLOCK)
  {$ELSE}
      {and ??? errno = EWOUDLBLOCK}
  {$ENDIF}
    then begin
      FLastErrorCode := GetSocketError;
      FLastError := Format('Cannot connect to server on host ''%s'':'#$D#$A'%s.'#$D#$A'Socket Error Code: %d($%X)', [FHostname, SysErrorMessage(FLastErrorCode), FLastErrorCode, FLastErrorCode]);
      exit;
    end;

    Result := True;
  finally
    if HostAddrInfo <> nil then
    {$IFDEF MSWINDOWS}
      if not IsAddrInfoSupported then
        ApiFreeAddrInfo(HostAddrInfo)
      else
    {$ENDIF}
      freeaddrinfo(HostAddrInfo{$IFDEF POSIX}^{$ENDIF});
  end;
end;

function TCRVioTcp.TryConnect: Boolean;
var
{$IFDEF MSWINDOWS}
  Connector: TConnector;
  Res: integer;
{$ENDIF}
  OldTimeout: integer;
begin
  Assert(Fsd = SOCKET_ERROR);

  Result := inherited TryConnect;

  FLastError := '';
  FLastErrorCode := 0;
  if FHostname = '' then
    FHostname := LOCAL_HOST;

  try
  {$IFDEF MSWINDOWS}
    Res := Startup;
    if Res <> 0 then begin
      FLastErrorCode := Res;
      FLastError := Format('WSAStartup failed.'#$D#$A'Socket Error Code: %d', [Res]);
      exit;
    end;
    LoadWS2_32Lib; // load WSAIoctl function

    if FConnectionTimeout > 0 then begin
      Connector := TConnector.Create(Self);
      try
        if WaitForSingleObject(Connector.Handle, DWORD(FConnectionTimeout) * 1000) <> WAIT_OBJECT_0 then begin
          TerminateThread(Connector.Handle, 0);
          FLastError := Format('Cannot connect to server on host ''%s'': Connection timed out', [FHostname]);
        end
        else
          Result := FLastError = '';
      finally
        Connector.Free;
      end;
    end
    else
  {$ENDIF}
      Result := InternalConnect;

    if not Result then
      exit;

    try
      SocketFastsend(FSd);

      // Force to set timeout
      OldTimeout := FReceiveTimeout;
      try
        FReceiveTimeout := -1;
        SetReceiveTimeout(OldTimeout);
      finally
        FReceiveTimeout := OldTimeout;
      end;

      OldTimeout := FReceiveTimeout;
      try
        FSendTimeout := -1;
        SetSendTimeout(OldTimeout);
      finally
        FSendTimeout := OldTimeout;
      end;
    except
      Result := False;
      raise;
    end;

  finally
    if not Result then begin
      SocketClose(FSd);
      FSd := SOCKET_ERROR;
    end;
  end;
end;

procedure TCRVioTcp.Connect;
begin
  if not TryConnect then
    if FLastError <> '' then
      raise SocketException.Create(FLastError)
    else
      raise SocketException.Create('Unknown socket error');
end;

procedure TCRVioTcp.Close;
begin
  SocketShutdown(FSd, SD_BOTH);
  SocketClose(FSd);
  FSd := SOCKET_ERROR;
end;

function TCRVioTcp.ReadNoWait({$IFDEF CLR}var{performance opt}{$ENDIF} buffer: TValueArr; offset, count: integer): integer;
  function InernalReceive(Loop: integer): integer;
  begin
    Result := recv(FSd, buffer[offset], count, 0);

    if Result = SOCKET_ERROR then begin
    {$IFDEF UNIX}
      if (GetSocketError = ESysEINTR) and (Loop > 0) then begin
        sleep(50);
        Result := InernalReceive(Loop - 1);
      end
      else
    {$ENDIF}
      begin
        FLastErrorCode := GetSocketError;
        FLastError := Format('Error on data reading from the connection:'#$D#$A'%s.'#$D#$A'Socket Error Code: %d($%X)', [SysErrorMessage(FLastErrorCode), FLastErrorCode, FLastErrorCode]);
        Result := 0; // silent error handling
      end;
    end;
  end;

begin
  FLastError := '';
  FLastErrorCode := 0;
  Result := InernalReceive(3);
end;

function TCRVioTcp.WriteNoWait(const{performance opt} buffer: TValueArr; offset, count: integer): integer;
begin
  FLastError := '';
  FLastErrorCode := 0;
  Result := send(FSd, buffer[offset], count, 0);
  if Result = SOCKET_ERROR then begin
    FLastErrorCode := GetSocketError;
    FLastError := Format('Error on data writing to the connection:'#$D#$A'%s.'#$D#$A'Socket Error Code: %d($%X)', [SysErrorMessage(FLastErrorCode), FLastErrorCode, FLastErrorCode]);
    Result := 0; // silent error handling
  end;
end;

function TCRVioTcp.Write(const buffer: TValueArr; offset, count: integer): integer;
begin
  if FSd = SOCKET_ERROR then begin
    FLastErrorCode := 0;
    FLastError := 'Error on data writing to the connection: Invalid socket';
    Result := 0;
  end
  else
    Result := inherited Write(buffer, offset, count);
end;

function TCRVioTcp.WaitForData(Timeout: integer = -1): boolean;
begin
  FLastError := '';
  FLastErrorCode := 0;
  Result := SocketWaitForData(FSd, Timeout * 1000, FLastErrorCode);
  if FLastErrorCode <> 0 then begin
    FLastError := Format('Error on data waiting from the connection:'#$D#$A'%s.'#$D#$A'Socket Error Code: %d($%X)', [SysErrorMessage(FLastErrorCode), FLastErrorCode, FLastErrorCode]);
    raise SocketException.Create(FLastError);
  end;
end;

function TCRVioTcp.IsActive: boolean;
begin
  Result := FSd <> SOCKET_ERROR;
end;

function TCRVioTcp.GetSocket: longint;
begin
  Result := FSd;
end;

{ TConnector }

constructor TConnector.Create(Vio: TCRVioTcp);
begin
  inherited Create(True);

  FVio := Vio;
  Resume;
end;

procedure TConnector.Execute;
begin
  FVio.InternalConnect;
end;

{$IFDEF MSWINDOWS}
initialization
  hLockWsaData := TCriticalSection.Create;
  ZeroMemory(@WsaData, SizeOf(WsaData));
{$ENDIF}

{$IFDEF MSWINDOWS}
finalization
  Cleanup;
  hLockWsaData.Free;
  FreeWS2_32Lib;
{$ENDIF}

end.

