{ +-------------------------------------------------------------+ }
{ |                                                             | }
{ |   GM-Software                                               | }
{ |   ===========                                               | }
{ |                                                             | }
{ |   Project: All Projects                                     | }
{ |                                                             | }
{ |   Description: Socket connections.                          | }
{ |                                                             | }
{ |                                                             | }
{ |   Copyright (C) - 2012 - Gerrit Moeller.                    | }
{ |                                                             | }
{ |   Source code dstributed under MIT license.                 | }
{ |                                                             | }
{ |   See: https://www.gm-software.de                           | }
{ |                                                             | }
{ +-------------------------------------------------------------+ }

{$INCLUDE GMCompilerSettings.inc}

unit GMSockets;

interface

uses {$IFDEF JEDIAPI}{$IFNDEF FPC}jwaWinType,{$ENDIF}{$ENDIF}
     GMActiveX, GMStrDef, GMIntf, GMCommon, GMSocketAPI;

type
    
  TGMSocketAddressFamily = (afUnspecified, afInet4, afINet6, afIPX, afAppleTalk, afNetBios, afIrDA, afBluetooth);
  TGMIPAddressFamily = afUnspecified .. afINet6;
  TGMSocketKind = (skRaw, skStream, skDatagram, skReliableDatagram, skSeqencedPacket);
  TGMSocketProtocol = (spICMP, spIGMP, spRFCOMM, spTCP, spUDP, spICMPv6, spReliableMulticast);
  TSockOperation = (ioSend, ioReceive, ioAccept);
  

const

  cBroadcastIPAddr = '255.255.255.255';
//cDfltCheckCanceledIntervalMilliseconds = 300;

  cLocalHost = 'localhost';

  FACILITY_GM_SOCKET = 2011;

  cStrmSizeUnlimited = -1;


type

//TGMTlsAttribute = (tsaUseTls);
//TGMTlsAttributes = set of TGMTlsAttribute;

  TGMSocketAddress = class;

  IGMSocketAddress = interface(IUnknown)
    ['{EFF4550C-1CA6-4769-BB46-9D6249B08BF9}']
    function Obj: TGMSocketAddress;
  end;


  IGMSocketIO = interface(IUnknown)
    ['{0F38ED51-D59B-4917-AE33-F1329E2563DE}']
    function SendData(const AData: Pointer; const ADataSize: LongInt): LongInt; stdcall;
    function ReceiveData(const AData: Pointer; const ADataSize: LongInt): LongInt; stdcall;
//  function IsDataAvailable: Boolean; stdcall;
  end;


  IGMSocket = interface(IGMSocketIO)
    ['{4D9C657F-8E40-4BD3-80B2-B84644D3FEC4}']
    procedure Connect(const AHost: TGMString; const APort: TGMString); stdcall;
    procedure Connect2(const AAddress: IGMSocketAddress); stdcall;
    procedure Bind(const APort: TGMString; const AHost: TGMString = ''); stdcall;
    procedure Bind2(const AAddress: IGMSocketAddress); stdcall;
    procedure Listen(const AMaxConnectionQueueLen: LongInt = SOMAXCONN); stdcall;
    procedure AcceptAndTakeOver; stdcall;
    function Accept: IGMSocket; stdcall;
    function Socket: TSocket; stdcall;
    function GetAskCanceled: IUnknown; stdcall;
//  function Obj: TGMSocket;
    function LocalAddress: IGMSocketAddress; stdcall;
    function RemoteAddress: IGMSocketAddress; stdcall;
  end;


  IGMCheckNonBlockingErrorCode = interface(IUnknown)
    ['{0F511780-389A-471C-AA44-1DBA6DFDE0AD}']
    function CheckNonBlockingErrorCode(const AIOErrorCode: LongInt; const AOperation: TSockOperation;
                                       const ASuccesCodes: array of PtrInt; const ASocketAPIRoutineName: TGMString): TSocket;
  end;


  TGMSocketAddress = class(TGMRefCountedObj, IGMSocketAddress, IGMGetText)
   protected
    FHost, FResolvedHost, FPort: TGMString;
    procedure ResolveAddress(const ASocket: IGMSocket; const AHost: TGMString; const APort: TGMString); virtual; abstract;
    procedure SetupFromData; virtual; abstract;

   public
    constructor Create(const ASocket: IGMSocket; const AHost: TGMString; const APort: TGMString; const ARefLifeTime: Boolean = True); reintroduce; overload; virtual;
    constructor CreateLocal(const ASocket: IGMSocket; const ARefLifeTime: Boolean = True);
    constructor CreateRemote(const ASocket: IGMSocket; const ARefLifeTime: Boolean = True);
//  constructor CreateLocal(const ASocket: IGMSocket; const ARefLifeTime: Boolean = True);
//  constructor CreateRemote(const ASocket: IGMSocket; const ARefLifeTime: Boolean = True);
    function Obj: TGMSocketAddress;
    function AddrData: Pointer; virtual; abstract;
    function AddrDataSize: LongInt; virtual; abstract;
    function AddrBufferSize: LongInt; virtual; abstract;
    function GetText: TGMString; virtual; stdcall; abstract;
    property Host: TGMString read FHost;
    property ResolvedHost: TGMString read FResolvedHost;
    property Port: TGMString read FPort;
  end;

  TGMSocketAddressClass = class of TGMSocketAddress;

  PGMIPAddrUnion = ^TGMIPAddrUnion;
  TGMIPAddrUnion = packed record
   case AddressFamily: u_short of
    AF_INET: (IP4Port: u_short;
              IP4Addr: TInAddr;
              IP4Zero: array[0..7] of byte);
    AF_INET6: (IP6Port:     u_short;
               IP6Flowinfo: u_long;
               IP6Addr:     TInAddr6;
               IP6Scope_id: u_long);
  end;


  TGMIPSocketAddress = class(TGMSocketAddress)
   protected
    FIPAddress: TGMIPAddrUnion;
    procedure ResolveAddress(const ASocket: IGMSocket; const AHost: TGMString; const APort: TGMString); override;
    procedure SetupFromData; override;
    
   public
    constructor CreateFromIPAddress(const AIPAddress: TGMIPAddrUnion; const ARefLifeTime: Boolean = True);
    function AddrData: Pointer; override;
    function AddrDataSize: LongInt; override;
    function AddrBufferSize: LongInt; override;
    function IPAddress: PGMIPAddrUnion;
    function GetText: TGMString; override;
  end;


  TGMSocket = class(TGMRefCountedObj, IGMSocketIO, IGMSocket, IGMCheckNonBlockingErrorCode)
   protected
    //FConnected: Boolean;
    FCheckCanceledIntervalMilliseconds: LongInt;
    FBlocking: Boolean;
    FSocket: TSocket;
    FAddressFamily: TGMSocketAddressFamily;
    FSocketKind: TGMSocketKind;
    FProtocol: TGMSocketProtocol;
    FLocalAddress, FRemoteAddress: IGMSocketAddress;

    function SocketAddrCreateClass: TGMSocketAddressClass; virtual;
    function AcceptConnection: TSocket;
    procedure CheckCanceled;

   public
    FAskCanceled: IGMGetOperationCanceled;

    constructor Create(const ARefLifeTime: Boolean = True); overload; override;
    constructor Create(const AAddressFamily: TGMSocketAddressFamily; const ASocketKind: TGMSocketKind;
                       const ASocketProtocol: TGMSocketProtocol; const AAskCanceled: IUnknown = nil;
                       const ASocket: TSocket = INVALID_SOCKET;
                       const ARefLifeTime: Boolean = True); reintroduce; overload;

    destructor Destroy; override;
    function GetAskCanceled: IUnknown; stdcall;
//  function IsDataAvailable: Boolean; stdcall;
//  function Obj: TGMSocket;
//  procedure ReleaseReferences; stdcall;
    function CheckNonBlockingErrorCode(const AIOErrorCode: LongInt; const AOperation: TSockOperation;
                                       const ASuccesCodes: array of PtrInt; const ASocketAPIRoutineName: TGMString): TSocket;

//  procedure Bind(const AHost: TGMString; const APort: LongInt);
    procedure Connect(const AHost: TGMString; const APort: TGMString); stdcall;
    procedure Connect2(const AAddress: IGMSocketAddress); stdcall;
    procedure Bind(const APort: TGMString; const AHost: TGMString = ''); stdcall;
    procedure Bind2(const AAddress: IGMSocketAddress);  stdcall;
    procedure Listen(const AMaxConnectionQueueLen: LongInt = SOMAXCONN); stdcall;
    procedure AcceptAndTakeOver; stdcall;
    function Accept: IGMSocket; stdcall;

    function SendData(const AData: Pointer; const ADataSize: LongInt): LongInt; stdcall;
    function ReceiveData(const AData: Pointer; const ADataSize: LongInt): LongInt; stdcall;

    function LocalAddress: IGMSocketAddress; stdcall;
    function RemoteAddress: IGMSocketAddress; stdcall;
    function Socket: TSocket; stdcall;

//  function SendAnsiStringContents(const AData: AnsiString): LongInt;
//  function SendStreamContents(const AStream: IStream): LongInt;

//  property Socket: TSocket read FSocket;
    property AddressFamily: TGMSocketAddressFamily read FAddressFamily;
  end;


  TGMTcpSocket = class(TGMSocket)
   protected
    //FPreferIp4: Boolean;
    function SocketAddrCreateClass: TGMSocketAddressClass; override;
   public
    constructor Create(const AIPAdressFamily: TGMIPAddressFamily; //const APreferIp4: Boolean;
                       const AAskCanceled: IUnknown = nil; const ARefLifeTime: Boolean = True); reintroduce; overload;
  end;


  IGMSetContentSize = interface(IUnknown)
    ['{6BC78ADE-B5EA-4AEF-BA76-DD90B3124998}']
    function SetReadContentSize(const AValue: Int64): Int64; stdcall;
    function SetWriteContentSize(const AValue: Int64): Int64; stdcall;
  end;


  TGMSocketStream = class(TGMSequentialIStream, IGMSetContentSize)
   protected
    FPendingData: AnsiString;
    FSocket: IGMSocketIO;
    FReadSize, FReadConsumed, FWriteSize, FWriteUsed: Int64; // <- cannot use FSize because it will be modified in inherited read method
    procedure InternalRead(pv: Pointer; cb: LongWord; var pcbRead: LongWord); override;
    procedure InternalWrite(pv: Pointer; cb: LongWord; var pcbWritten: LongWord); override;
   public
    constructor Create(const ARefLifeTime: Boolean = True); overload; override;
    constructor Create(const ASocket: IGMSocketIO; const AMode: LongWord = STGM_READ or STGM_WRITE; const AName: UnicodeString = ''; const ARefLifeTime: Boolean = True); reintroduce; overload;
    function SetReadContentSize(const AValue: Int64): Int64; stdcall;
    function SetWriteContentSize(const AValue: Int64): Int64; stdcall;
    property Socket: IGMSocketIO read FSocket;
  end;


  EGMSocketError = class(EGMException, IGMGetHRCode)
   protected
    FErrorCode: LongInt;
   public
    constructor SocketError(const ASocketErrorCode: LongInt; const ACaller: TObject; const ACallingName: TGMString);
    function GetHRCode: HResult; stdcall;
  end;


//procedure InitializeSocketLibrary;

function GMIPAddrUnionDataSize(const AIPAddress: TGMIPAddrUnion): LongInt;

function BuildSocketErrorMsg(const ASocketErrorCode: LongInt): TGMString;
function GMCheckSocketCode(const ASocketErrorCode: LongInt; const ASuccesCodes: array of PtrInt; const ACaller: TObject; const ACallingName: TGMString): LongInt;

function GMSocketHrResult(const ASocketerrorCode: LongInt): HResult;

function GMIsSocketReConnectErrorCode(const AErrorCode: HResult): Boolean;

//function GMTlsAttributesFromLongWord(const AValue: Longword): TGMTlsAttributes;
//function GMTlsAttributesToLongWord(const AValue: TGMTlsAttributes): Longword;

procedure GMSetReadContentSize(const AIntf: IUnknown; const ASize: Int64);
procedure GMSetWriteContentSize(const AIntf: IUnknown; const ASize: Int64);


const

  cGMSocketAddressFamilies: array [TGMSocketAddressFamily] of LongInt =
    (AF_UNSPEC, AF_INET, AF_INET6, AF_IPX, AF_APPLETALK, AF_NETBIOS, AF_IRDA, AF_BTH);

  cGMSocketKinds: array [TGMSocketKind] of LongInt =
    (SOCK_RAW, SOCK_STREAM, SOCK_DGRAM, SOCK_RDM, SOCK_SEQPACKET);

  cGMSocketProtocols: array [TGMSocketProtocol] of LongInt =
    (IPPROTO_ICMP, IPPROTO_IGMP, BTHPROTO_RFCOMM, IPPROTO_TCP, IPPROTO_UDP, IPPROTO_ICMPV6, IPPROTO_RM);


var

  vDfltInetAddrFamily: TGMSocketAddressFamily = afInet4;


implementation


resourcestring

  RStrSocketErrorFmt = 'Socket error (%d): %s';
  RStrTheSocket = 'The Socket';
  RStrInvalidIODirectionFmt = 'Invalid socket I/O direction: %d';
  RStrTheAddressArgument = 'The address argument';

  RStrHostResolvedToFmt = 'Hostname "%s" resolved to: %s';
  RStrConnectingSocketFmt = 'Connecting socket to address: %s';
  RStrBindingSocketFmt = 'Binding socket to address: %s';
  RStrConnectionAcceptedFrom = 'Connection accepted from: ';
  RStrSocketConnectionClosed = 'Socket connection closed';

//RStrIPAddressFmt = 'IP4-Address: %d.%d.%d.%d, Port: %d';
//RStrBindToAddrFmt = 'Binding socket to address: %s';
//RStrHostResolvedFmt = 'Host "%s" resolved to: %s';
//RStrConnectToAddrFmt = 'Connecting socket to address: %s';


var

  vCSSoketLibrary: IGMCriticalSection = nil;
  vSocketLibInitialized: Boolean = False;


{ ------------------------- }
{ ---- Global Routines ---- }
{ ------------------------- }

function GMSocketHrResult(const ASocketerrorCode: LongInt): HResult;
begin
  Result := cCustomHrError or (FACILITY_GM_SOCKET shl 16) or ASocketerrorCode;
end;

function BuildSocketErrorMsg(const ASocketErrorCode: LongInt): TGMString;
begin
  Result := GMFormat(RStrSocketErrorFmt, [ASocketErrorCode, SocketErrorMsgFromCode(ASocketErrorCode)]);
end;

function GMCheckSocketCode(const ASocketErrorCode: LongInt; const ASuccesCodes: array of PtrInt; const ACaller: TObject; const ACallingName: TGMString): LongInt;
begin
  if (ASocketErrorCode <> WSANOERROR) and ((Length(ASuccesCodes) <= 0) or not GMIsOneOfCodes(ASocketErrorCode, ASuccesCodes)) then
   raise EGMSocketError.SocketError(ASocketErrorCode, ACaller, ACallingName)
  else
   Result := ASocketErrorCode;
end;

function GMIsSocketReConnectErrorCode(const AErrorCode: HResult): Boolean;
begin
  Result := (AErrorCode = GMSocketHrResult(WSAECONNRESET)) or (AErrorCode = GMSocketHrResult(WSAECONNABORTED));
end;

procedure EnterSocketLibraryCS;
begin
  if vCSSoketLibrary <> nil then vCSSoketLibrary.EnterCriticalSection;
end;

procedure LeaveSocketLibraryCS;
begin
   if vCSSoketLibrary <> nil then vCSSoketLibrary.LeaveCriticalSection;
end;

procedure InitializeSocketLibrary;
var WSAStartupData: TWSAData;
begin
  EnterSocketLibraryCS;
  try
   if vSocketLibInitialized then Exit;
   GMCheckSocketCode(WSAStartUp(cWinsockVersion202, WSAStartupData), [], nil, 'InitializeSocketLibrary');
   vSocketLibInitialized := True;
  finally
   LeaveSocketLibraryCS;
  end;
end;

procedure FinalizeSocketLibrary;
begin
  EnterSocketLibraryCS;
  try
   if not vSocketLibInitialized then Exit;
   WSACleanup;
   vSocketLibInitialized := False;
  finally
   LeaveSocketLibraryCS;
  end;
end;

//function GMTlsAttributesToLongWord(const AValue: TGMTlsAttributes): Longword;
//var i: TGMTlsAttribute;
//begin
//Result := 0;
//for i:=Low(i) to High(i) do if i in AValue then Result := Result or (1 shl Ord(i));
//end;
//
//function GMTlsAttributesFromLongWord(const AValue: Longword): TGMTlsAttributes;
//var i: TGMTlsAttribute;
//begin
//Result := [];
//for i:=Low(i) to High(i) do if AValue and (1 shl Ord(i)) <> 0 then Include(Result, i);
//end;

procedure GMSetReadContentSize(const AIntf: IUnknown; const ASize: Int64);
var setSize: IGMSetContentSize;
begin
  if GMQueryInterface(AIntf, IGMSetContentSize, setSize) then setSize.SetReadContentSize(ASize);
end;

procedure GMSetWriteContentSize(const AIntf: IUnknown; const ASize: Int64);
var setSize: IGMSetContentSize;
begin
  if GMQueryInterface(AIntf, IGMSetContentSize, setSize) then setSize.SetWriteContentSize(ASize);
end;

function GMIPAddrUnionDataSize(const AIPAddress: TGMIPAddrUnion): LongInt;
begin
  case AIPAddress.AddressFamily of
   AF_INET: Result := SizeOf(TSockAddrIn);
   AF_INET6: Result := SizeOf(TSockAddrIn6);
   else Result := 0;
  end;
end;

function IPAddrUnionAsString(const AAddressUnion: TGMIPAddrUnion; const AShowPort: Boolean = True): TGMString;
begin
  case AAddressUnion.AddressFamily of
   AF_INET: begin
             Result := GMFormat('%d.%d.%d.%d',  // 'IP4-Address: %d.%d.%d.%d',
                                [AAddressUnion.IP4Addr.s_b_Arr.s_bArr[0], AAddressUnion.IP4Addr.s_b_Arr.s_bArr[1],
                                 AAddressUnion.IP4Addr.s_b_Arr.s_bArr[2], AAddressUnion.IP4Addr.s_b_Arr.s_bArr[3]]);
             if AShowPort then Result := Result + GMFormat(', Port: %d', [GMSocketAPI.ntohs(AAddressUnion.IP4Port)]);
            end;
   else Result := '';
  end;
end;

function TimeVal(const ASeconds, AMicroSeconds: LongInt): TTimeVal;
begin
  Result.tv_sec := ASeconds;
  Result.tv_usec := AMicroSeconds;
end;

function TimeValFromMilliseconds(const AMilliSeconds: LongInt): TTimeVal;
begin
  Result := TimeVal(AMilliSeconds div 1000, (AMilliSeconds mod 1000) * 1000); // <- u-seconds NOT milli-seconds!
end;

function AssignFDSet(const ASockets: array of TSocket): TFDSet;
var i: LongInt;
begin
  //FillChar(Result, SizeOf(Result), 0);
  FD_Zero(Result);
  for i:=Low(ASockets) to High(ASockets) do FD_Set(ASockets[i], Result);
end;

function AssignIPAddrUnion(var AAddressUnion: TGMIPAddrUnion; const AHost, APort: AnsiString; const AFamily, ASockProtocol, ASockType: LongInt): LongInt;
type TPULong = ^u_long;
var protoEnt: PProtoEnt; servEnt: PServEnt; hostEnt: PHostEnt;
//r: LongInt;
//Hints1, Hints2: TAddrInfo;
//Sin1, Sin2: TGMIPAddrUnion;
//TwoPass: boolean;

//function GetAddr(const AHost, APort: AnsiString; Hints: TAddrInfo; var AAddressUnion: TGMIPAddrUnion): LongInt;
//var
//  Addr: PAddrInfo;
//begin
//  Addr := nil;
//  try
//    FillChar(AAddressUnion, Sizeof(AAddressUnion), 0);
//    if Hints.ai_socktype = SOCK_RAW then
//    begin
//      Hints.ai_socktype := 0;
//      Hints.ai_protocol := 0;
//      Result := synsock.GetAddrInfo(PAnsiChar(AHost), nil, @Hints, Addr);
//    end
//    else
//    begin
//      if (AHost = cAnyHost) or (AHost = c6AnyHost) then
//      begin
//        Hints.ai_flags := AI_PASSIVE;
//        Result := synsock.GetAddrInfo(nil, PAnsiChar(APort), @Hints, Addr);
//      end
//      else
//        if (AHost = cLocalhost) or (AHost = c6Localhost) then
//        begin
//          Result := synsock.GetAddrInfo(nil, PAnsiChar(APort), @Hints, Addr);
//        end
//        else
//        begin
//          Result := synsock.GetAddrInfo(PAnsiChar(AHost), PAnsiChar(APort), @Hints, Addr);
//        end;
//    end;
//    if Result = 0 then
//      if (Addr <> nil) then
//        Move(Addr^.ai_addr^, AAddressUnion, Addr^.ai_addrlen);
//  finally
//    if Assigned(Addr) then
//      synsock.FreeAddrInfo(Addr);
//  end;
//end;

begin
  Result := WSANOERROR;
  //FillChar(AAddressUnion, Sizeof(AAddressUnion), 0);
  AAddressUnion := Default(TGMIPAddrUnion);
  //if not IsNewApi(AFamily) then
  begin
   EnterSocketLibraryCS;
   try
    AAddressUnion.AddressFamily := AF_INET;
    protoEnt := GMSocketAPI.GetProtoByNumber(ASockProtocol);
    servEnt := nil;
    if (protoEnt <> nil) and (GMStrToInt(GMMakeDezInt(APort, -1)) = -1) then servEnt := GMSocketAPI.GetServByName(PAnsiChar(APort), protoEnt^.p_name);

    if servEnt = nil then
     AAddressUnion.IP4Port := GMSocketAPI.htons(GMStrToInt(GMMakeDezInt(APort, 0)))
    else
     AAddressUnion.IP4Port := servEnt^.s_port;

//  if (Length(AHost) = 0) or GMSameText(AHost, cLocalHost) then AAddressUnion.IP4Addr.s_addr := INADDR_ANY
//  else
    if AHost = cBroadcastIPAddr then AAddressUnion.IP4Addr.s_addr := INADDR_BROADCAST
    else
     begin
      AAddressUnion.IP4Addr.s_addr := GMSocketAPI.inet_addr(PAnsiChar(AHost));
      if AAddressUnion.IP4Addr.s_addr = u_long(INADDR_NONE) then
       begin
        hostEnt := GMSocketAPI.GetHostByName(PAnsiChar(AHost));
        Result := GMSocketAPI.WSAGetLastError;
        if hostEnt <> nil then AAddressUnion.IP4Addr.S_addr := u_long(TPULong(hostEnt^.h_addr_list^)^);
       end;
     end;
    finally
     LeaveSocketLibraryCS;
    end;
  end
//else
//begin
//  FillChar(Hints1, Sizeof(Hints1), 0);
//  FillChar(Hints2, Sizeof(Hints2), 0);
//  TwoPass := False;
//  if AFamily = AF_UNSPEC then
//  begin
//    if PreferIP4 then
//    begin
//      Hints1.ai_family := AF_INET;
//      Hints2.ai_family := AF_INET6;
//      TwoPass := True;
//    end
//    else
//    begin
//      Hints2.ai_family := AF_INET;
//      Hints1.ai_family := AF_INET6;
//      TwoPass := True;
//    end;
//  end
//  else
//    Hints1.ai_family := AFamily;
//
//  Hints1.ai_socktype := ASockType;
//  Hints1.ai_protocol := ASockProtocol;
//  Hints2.ai_socktype := Hints1.ai_socktype;
//  Hints2.ai_protocol := Hints1.ai_protocol;
//
//  r := GetAddr(AHost, APort, Hints1, Sin1);
//  Result := r;
//  AAddressUnion := sin1;
//  if r <> 0 then
//    if TwoPass then
//    begin
//      r := GetAddr(AHost, APort, Hints2, Sin2);
//      Result := r;
//      if r = 0 then
//        AAddressUnion := sin2;
//    end;
//end;
end;


{ ------------------------ }
{ ---- EGMSocketError ---- }
{ ------------------------ }

constructor EGMSocketError.SocketError(const ASocketErrorCode: LongInt; const ACaller: TObject; const ACallingName: TGMString);
begin
  FErrorCode := ASocketErrorCode;
  ObjError(BuildSocketErrorMsg(ASocketErrorCode), ACaller, ACallingName);
end;

function EGMSocketError.GetHRCode: HResult;
begin
  Result := GMSocketHrResult(FErrorCode);
end;


{ -------------------------- }
{ ---- TGMSocketAddress ---- }
{ -------------------------- }

constructor TGMSocketAddress.Create(const ASocket: IGMSocket; const AHost: TGMString; const APort: TGMString; const ARefLifeTime: Boolean);
begin
  inherited Create(ARefLifeTime);
  FHost := AHost;
  FPort := APort;
  ResolveAddress(ASocket, AHost, APort);
end;

constructor TGMSocketAddress.CreateLocal(const ASocket: IGMSocket; const ARefLifeTime: Boolean);
var dataSize: LongInt;
begin
  inherited Create(ARefLifeTime);
  if ASocket <> nil then
   begin
    dataSize := AddrBufferSize;
    if getsockname(ASocket.Socket, AddrData^, dataSize) <> WSANOERROR then
       GMCheckSocketCode(WSAGetLastError, [], Self, 'SocketAPI.getsockname');
    SetupFromData;
   end;
end;

constructor TGMSocketAddress.CreateRemote(const ASocket: IGMSocket; const ARefLifeTime: Boolean);
var dataSize: LongInt;
begin
  inherited Create(ARefLifeTime);
  if ASocket <> nil then
   begin
    dataSize := AddrBufferSize;
    if getpeername(ASocket.Socket, AddrData^, dataSize) <> WSANOERROR then
       GMCheckSocketCode(WSAGetLastError, [], Self, 'SocketAPI.getpeername');
    SetupFromData;
   end;
end;

function TGMSocketAddress.Obj: TGMSocketAddress;
begin
  Result := Self;
end;


{ ---------------------------- }
{ ---- TGMIPSocketAddress ---- }
{ ---------------------------- }

constructor TGMIPSocketAddress.CreateFromIPAddress(const AIPAddress: TGMIPAddrUnion; const ARefLifeTime: Boolean);
begin
  inherited Create(ARefLifeTime);
  FIPAddress := AIPAddress;
  FResolvedHost := IPAddrUnionAsString(FIPAddress, False);
end;

procedure TGMIPSocketAddress.ResolveAddress(const ASocket: IGMSocket; const AHost: TGMString; const APort: TGMString);
const cStrMethodName = 'TGMIPSocketAddress.ResolveAddress';
//var preferIp4: Boolean;
var Socket: TGMSocket;
begin
  GMCheckPointerAssigned(Pointer(ASocket), RStrTheSocket, Self, cStrMethodName);

  //preferIp4 := not (ASocket.Obj is TGMTcpSocket) or (ASocket.Obj as TGMTcpSocket).FPreferIp4;

  Socket := GMObjFromIntf(ASocket) as TGMSocket;
  GMCheckSocketCode(AssignIPAddrUnion(FIPAddress, AHost, APort,
           cGMSocketAddressFamilies[Socket.FAddressFamily],
           cGMSocketKinds[Socket.FSocketKind],
           cGMSocketProtocols[Socket.FProtocol]), [], Self, cStrMethodName); // preferIp4

  GMTrace(GMFormat(RStrHostResolvedToFmt, [AHost, GetText]), tpSocket);

  FResolvedHost := IPAddrUnionAsString(FIPAddress, False);
end;

function TGMIPSocketAddress.GetText: TGMString;
begin
  Result := IPAddrUnionAsString(FIPAddress);
end;

function TGMIPSocketAddress.AddrData: Pointer;
begin
  Result := @FIPAddress;
end;

function TGMIPSocketAddress.AddrDataSize: LongInt;
begin
  Result := GMIPAddrUnionDataSize(FIPAddress);
end;

function TGMIPSocketAddress.IPAddress: PGMIPAddrUnion;
begin
  Result := @FIPAddress;
end;

function TGMIPSocketAddress.AddrBufferSize: LongInt;
begin
  Result := SizeOf(FIPAddress);
end;

procedure TGMIPSocketAddress.SetupFromData;
begin
  FResolvedHost := IPAddrUnionAsString(FIPAddress, False);

  case FIPAddress.AddressFamily of
   AF_INET: FPort := GMIntToStr(GMSocketAPI.ntohs(FIPAddress.IP4Port));
   AF_INET6: FPort := GMIntToStr(GMSocketAPI.ntohs(FIPAddress.IP6Port));
// AF_INET: begin
//           FResolvedHost := GMFormat('%d.%d.%d.%d',
//                             [FIPAddress.IP4Addr.s_b_Arr.s_bArr[0], FIPAddress.IP4Addr.s_b_Arr.s_bArr[1],
//                              FIPAddress.IP4Addr.s_b_Arr.s_bArr[2], FIPAddress.IP4Addr.s_b_Arr.s_bArr[3]]);
//           FPort := GMIntToStr(GMSocketAPI.ntohs(FIPAddress.IP4Port));
//          end;
  end;
end;


{ ------------------- }
{ ---- TGMSocket ---- }
{ ------------------- }

constructor TGMSocket.Create(const ARefLifeTime: Boolean);
begin
  inherited Create(ARefLifeTime);
  FSocket := INVALID_SOCKET;
  FProtocol := spTCP;
  FBlocking := True;
  FCheckCanceledIntervalMilliseconds := cDfltUiResponseMS;
end;

constructor TGMSocket.Create(const AAddressFamily: TGMSocketAddressFamily; const ASocketKind: TGMSocketKind;
  const ASocketProtocol: TGMSocketProtocol; const AAskCanceled: IUnknown; const ASocket: TSocket; const ARefLifeTime: Boolean);
const cNonBlocking: array [Boolean] of LongInt = (0, 1); // cStrMethodName = 'TGMSocket.Create';
var ioCtrlVal: u_long;
begin
  Create(ARefLifeTime);
  FAddressFamily := AAddressFamily;
  FSocketKind := ASocketKind;
  FProtocol := ASocketProtocol;

  GMQueryInterface(AAskCanceled, IGMGetOperationCanceled, FAskCanceled);
  FBlocking := FAskCanceled = nil;

  InitializeSocketLibrary;

  FSocket := ASocket;
  if FSocket = INVALID_SOCKET then
   begin
    EnterSocketLibraryCS;
    try
     FSocket := GMSocketAPI.socket(cGMSocketAddressFamilies[AAddressFamily], cGMSocketKinds[ASocketKind], cGMSocketProtocols[ASocketProtocol]);
     if FSocket = INVALID_SOCKET then GMCheckSocketCode(WSAGetLastError, [], Self, 'SocketAPI.socket');
    finally
     LeaveSocketLibraryCS;
    end;
   end;

  ioCtrlVal := cNonBlocking[not FBlocking];
  if ioctlsocket(FSocket, FIONBIO, ioCtrlVal) <> WSANOERROR then GMCheckSocketCode(WSAGetLastError, [], Self, 'SocketAPI.ioctlsocket(FIONBIO)');
end;

destructor TGMSocket.Destroy;
var closeCode: Integer;
begin
  if FSocket <> INVALID_SOCKET then
   begin
    closeCode := GMSocketAPI.closeSocket(FSocket);
    if closeCode <> WSANOERROR then GMTrace(GMStringJoin('CloseSocket', ': ', SocketErrorMsgFromCode(closeCode)), tpSocket);
    FSocket := INVALID_SOCKET;
    GMTrace(GMStringJoin(RStrSocketConnectionClosed, ': ', GMStringJoin(GMGetIntfText(FLocalAddress), ' <--> ', GMGetIntfText(FRemoteAddress))), tpSocket);
   end;
  inherited Destroy;
end;

function TGMSocket.GetAskCanceled: IUnknown;
begin
  Result := FAskCanceled;
end;

//function TGMSocket.IsDataAvailable: Boolean;
//var data: Byte;
//begin
//Result := GMSocketApi.recv(Socket, data, SizeOf(data), MSG_PEEK) > 0;
//end;

//procedure TGMSocket.ReleaseReferences;
//begin
//FAskCanceled := nil;
//end;

function TGMSocket.Socket: TSocket;
begin
  Result := FSocket;
end;

//function TGMSocket.Obj: TGMSocket;
//begin
//Result := Self;
//end;

function TGMSocket.SocketAddrCreateClass: TGMSocketAddressClass;
begin
  Result := nil;
end;

procedure TGMSocket.CheckCanceled;
begin
  if (FAskCanceled <> nil) and FAskCanceled.OperationCanceled then raise EGMAbort.Create(RStrOperationCanceled);
end;

function TGMSocket.CheckNonBlockingErrorCode(const AIOErrorCode: LongInt; const AOperation: TSockOperation; const ASuccesCodes: array of PtrInt;
    const ASocketAPIRoutineName: TGMString): TSocket;
const cStrMethodName = 'CheckNonBlockingErrorCode';
var resultSz, selResult: LongInt; timeOut: TTimeVal; fdData, fdError: TFDSet;
begin
  Result := AIOErrorCode;
  if Result <> WSAEWOULDBLOCK then GMCheckSocketCode(AIOErrorCode, ASuccesCodes, Self, ASocketAPIRoutineName) else
   begin
    timeOut := TimeValFromMilliseconds(FCheckCanceledIntervalMilliseconds);
    //FillChar(fdData, SizeOf(fdData), 0);
    fdData := Default(TFDSet);
    //FillChar(fdError, SizeOf(fdError), 0);
    fdError := Default(TFDSet);
    repeat
     fdData := AssignFDSet([FSocket]);
     fdError := AssignFDSet([FSocket]);

     case AOperation of
      ioSend: selResult := GMSocketAPI.select(FSocket+1, nil, @fdData, @fdError, @timeOut);
      ioReceive, ioAccept: selResult := GMSocketAPI.select(FSocket+1, @fdData, nil, @fdError, @timeOut);
      else raise EGMException.ObjError(GMFormat(RStrInvalidIODirectionFmt, [Ord(AOperation)]), Self, cStrMethodName);
     end;

     case selResult of
      0: CheckCanceled; // <- Timeout occured, continue with loop
      SOCKET_ERROR: GMCheckSocketCode(WSAGetLastError, [], Self, 'SocketAPI.select'); // begin lastErr := WSAGetLastError; Break; end;
      else
       if FD_ISSET(FSocket, fdData) then
         case AOperation of
          ioAccept:
           begin
            Result := AcceptConnection;
            if Result = INVALID_SOCKET then GMCheckSocketCode(WSAGetLastError, [], Self, 'SocketAPI.accept');
            Break;
           end;
          else Result := WSANOERROR; Break;
         end else
       if FD_ISSET(FSocket, fdError) then
        begin
         resultSz := SizeOf(Result);
         if getsockopt(FSocket, SOL_SOCKET, SO_ERROR, Pointer(@Result), resultSz) <> WSANOERROR then
            GMCheckSocketCode(WSAGetLastError, [], Self, 'SocketAPI.getsockopt');
         if Result <> WSANOERROR then GMCheckSocketCode(Result, ASuccesCodes, Self, ASocketAPIRoutineName);
         Break;
        end;
     end;
    until False;
   end;
end;

function TGMSocket.LocalAddress: IGMSocketAddress;
begin
  if FLocalAddress = nil then FLocalAddress := SocketAddrCreateClass.CreateLocal(Self, True);
  Result := FLocalAddress;
end;

function TGMSocket.RemoteAddress: IGMSocketAddress;
begin
  if FRemoteAddress = nil then FRemoteAddress := SocketAddrCreateClass.CreateRemote(Self, True);
  Result := FRemoteAddress;
end;

procedure TGMSocket.Connect2(const AAddress: IGMSocketAddress);
const cStrMethodName = 'Connect';
begin
  GMCheckPointerAssigned(Pointer(AAddress), RStrTheAddressArgument, Self, cStrMethodName);
  FRemoteAddress := AAddress;
  GMTrace(GMFormat(RStrConnectingSocketFmt, [GMGetIntfText(AAddress)]), tpSocket);
  if GMSocketAPI.connect(FSocket, AAddress.Obj.AddrData^, AAddress.Obj.AddrDataSize) <> WSANOERROR then
     CheckNonBlockingErrorCode(WSAGetLastError, ioSend, [WSAEISCONN], 'SocketAPI.connect');
  //FConnected := True;
  CheckCanceled;
//dataSize := SizeOf(ourAddr);
//GMCheckSocketCode(getsockname(FSocket, ourAddr, dataSize), Self, 'Socket.getsockname');
//
//dataSize := SizeOf(peerAddr);
//GMCheckSocketCode(getpeername(FSocket, peerAddr, dataSize), Self, 'Socket.getpeername');
end;

procedure TGMSocket.Connect(const AHost, APort: TGMString);
const cStrMethodName = 'Connect';
var address: IGMSocketAddress;
begin
  //if FConnected then Exit;
  GMCheckPointerAssigned(SocketAddrCreateClass, 'SocketAddrCreateClass', Self, cStrMethodName);
  address := SocketAddrCreateClass.Create(Self, AHost, APort, True);
  CheckCanceled;
  Connect2(address);
end;

procedure TGMSocket.Bind2(const AAddress: IGMSocketAddress);
const cStrMethodName = 'Bind';
var port: U_short; dataSize: LongInt;
begin
  GMCheckPointerAssigned(Pointer(AAddress), RStrTheAddressArgument, Self, cStrMethodName);
  FLocalAddress := AAddress;

  if AAddress.Obj is TGMIPSocketAddress then
   port := GMSocketAPI.ntohs((AAddress.Obj as TGMIPSocketAddress).IPAddress.IP4Port)
  else
   port := $FFFF;

  if GMSocketApi.Bind(Socket, AAddress.Obj.AddrData^, AAddress.Obj.AddrDataSize) <> WSANOERROR then
     GMCheckSocketCode(WSAGetLastError, [], Self, 'SocketAPI.Bind');

  if port = 0 then // <- let system assign an unused port!
   begin
    dataSize := AAddress.Obj.AddrDataSize;
    if GMSocketApi.getsockname(FSocket, AAddress.Obj.AddrData^, dataSize) <> WSANOERROR then
       GMCheckSocketCode(WSAGetLastError, [], Self, 'SocketAPI.getsockname');
   end;

  GMTrace(GMFormat(RStrBindingSocketFmt, [GMGetIntfText(AAddress)]), tpSocket); // <- trace after a system assigned port may have been used
  CheckCanceled;
end;

procedure TGMSocket.Bind(const APort, AHost: TGMString);
var address: IGMSocketAddress;
begin
  address := SocketAddrCreateClass.Create(Self, AHost, APort);
  CheckCanceled;
  Bind2(address);
end;

procedure TGMSocket.Listen(const AMaxConnectionQueueLen: LongInt);
begin
  if GMSocketApi.Listen(Socket, AMaxConnectionQueueLen) <> WSANOERROR then
     GMCheckSocketCode(WSAGetLastError, [], Self, 'SocketAPI.Listen');
end;

function TGMSocket.AcceptConnection: TSocket;
var remoteAddr: IGMSocketAddress; dataSize: LongInt;
begin
  remoteAddr := SocketAddrCreateClass.Create(True);
  dataSize :=  remoteAddr.obj.AddrBufferSize;
  Result := GMSocketApi.accept(FSocket, remoteAddr.obj.AddrData, @dataSize);
  if Result <> INVALID_SOCKET then
   begin
    FRemoteAddress := remoteAddr;
    GMTrace(RStrConnectionAcceptedFrom + GMGetIntfText(remoteAddr), tpSocket);
   end;
end;

procedure TGMSocket.AcceptAndTakeOver;
var sock: TSocket;
begin
  sock := AcceptConnection;
  if sock = INVALID_SOCKET then sock := CheckNonBlockingErrorCode(WSAGetLastError, ioAccept, [], 'SocketAPI.accept');
  if FSocket <> INVALID_SOCKET then GMSocketAPI.closeSocket(FSocket);
  FSocket := sock;
end;

function TGMSocket.Accept: IGMSocket;
var sock: TSocket;
begin
  sock := AcceptConnection;
  if sock = INVALID_SOCKET then sock := CheckNonBlockingErrorCode(WSAGetLastError, ioAccept, [], 'SocketAPI.accept');
  Result := TGMSocket.Create(FAddressFamily, FSocketKind, FProtocol, FAskCanceled, sock, True);
end;

function TGMSocket.SendData(const AData: Pointer; const ADataSize: LongInt): LongInt;
begin
  repeat
   Result := GMSocketApi.send(Socket, AData^, ADataSize, 0);
   if Result = SOCKET_ERROR then CheckNonBlockingErrorCode(WSAGetLastError, ioSend, [], 'SocketAPI.send');
   CheckCanceled;
  until Result <> SOCKET_ERROR;
end;

function TGMSocket.ReceiveData(const AData: Pointer; const ADataSize: LongInt): LongInt;
begin
  repeat
   Result := GMSocketApi.recv(Socket, AData^, ADataSize, 0);
   if Result = SOCKET_ERROR then CheckNonBlockingErrorCode(WSAGetLastError, ioReceive, [], 'SocketAPI.recv');
   CheckCanceled;
  until Result <> SOCKET_ERROR;
end;


{ ---------------------- }
{ ---- TGMTcpSocket ---- }
{ ---------------------- }

constructor TGMTcpSocket.Create(const AIPAdressFamily: TGMIPAddressFamily; //const APreferIp4: Boolean;
  const AAskCanceled: IUnknown; const ARefLifeTime: Boolean);
begin
  inherited Create(AIPAdressFamily, skStream, spTCP, AAskCanceled, INVALID_SOCKET, ARefLifeTime);
  //FPreferIp4 := APreferIp4;
end;

function TGMTcpSocket.SocketAddrCreateClass: TGMSocketAddressClass;
begin
  Result := TGMIPSocketAddress;
end;


{ ------------------------- }
{ ---- TGMSocketStream ---- }
{ ------------------------- }

constructor TGMSocketStream.Create(const ARefLifeTime: Boolean);
begin
  inherited Create(ARefLifeTime);
  FReadSize := cStrmSizeUnlimited;
  FWriteSize := cStrmSizeUnlimited;
end;

constructor TGMSocketStream.Create(const ASocket: IGMSocketIO; const AMode: LongWord; const AName: UnicodeString; const ARefLifeTime: Boolean);
begin
  inherited Create(AMode, AName, ARefLifeTime);
  GMCheckPointerAssigned(Pointer(ASocket), RStrTheSocket, Self, 'Create');
  FSocket := ASocket;
end;

function TGMSocketStream.SetReadContentSize(const AValue: Int64): Int64;
begin
  Result := FReadSize;
  FReadSize := AValue;
  FReadConsumed := 0;
end;

function TGMSocketStream.SetWriteContentSize(const AValue: Int64): Int64;
begin
  Result := FWriteSize;
  FWriteSize := AValue;
  FWriteUsed := 0;
end;

procedure TGMSocketStream.InternalRead(pv: Pointer; cb: LongWord; var pcbRead: LongWord);
begin
  //
  // When Reading beyond end of data or calling with cb=0 then no further reading for subsequent requests
  // is possible. A stupid idea, but we have to deal with it.
  //
  if FReadSize >= 0 then cb := Min(cb, Max(0, FReadSize - FReadConsumed));
  if cb <= 0 then pcbRead := 0 else pcbRead := FSocket.ReceiveData(pv, cb);
  if FReadSize >= 0 then Inc(FReadConsumed, pcbRead);
end;

procedure TGMSocketStream.InternalWrite(pv: Pointer; cb: LongWord; var pcbWritten: LongWord);
begin
  if FWriteSize >= 0 then cb := Min(cb, Max(0, FWriteSize - FWriteUsed));
  if cb <= 0 then pcbWritten := 0 else pcbWritten := FSocket.SendData(pv, cb);
  if FWriteSize >= 0 then Inc(FWriteUsed, pcbWritten);
end;



initialization

  vCSSoketLibrary := TGMCriticalSection.Create;

finalization

  FinalizeSocketLibrary;

end.