/lib/delphi/src/Thrift.Socket.pas
Pascal | 1617 lines | 1195 code | 209 blank | 213 comment | 140 complexity | 4c556c350c09a5583ad9226331bacf2c MD5 | raw file
Possible License(s): Apache-2.0, MPL-2.0, LGPL-2.1
Large files files are truncated, but you can click here to view the full file
- (*
- * Licensed to the Apache Software Foundation (ASF) under one
- * or more contributor license agreements. See the NOTICE file
- * distributed with this work for additional information
- * regarding copyright ownership. The ASF licenses this file
- * to you under the Apache License, Version 2.0 (the
- * "License"); you may not use this file except in compliance
- * with the License. You may obtain a copy of the License at
- *
- * http://www.apache.org/licenses/LICENSE-2.0
- *
- * Unless required by applicable law or agreed to in writing,
- * software distributed under the License is distributed on an
- * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
- * KIND, either express or implied. See the License for the
- * specific language governing permissions and limitations
- * under the License.
- *)
- unit Thrift.Socket;
- {$I Thrift.Defines.inc}
- {$I-} // prevent annoying errors with default log delegate and no console
- interface
- {$IFNDEF OLD_SOCKETS} // not for OLD_SOCKETS
- uses
- Winapi.Windows, Winapi.Winsock2;
- const
- AI_PASSIVE = $00000001; // Socket address will be used in bind() call
- AI_CANONNAME = $00000002; // Return canonical name in first ai_canonname
- AI_NUMERICHOST = $00000004; // Nodename must be a numeric address string
- AI_NUMERICSERV = $00000008; // Servicename must be a numeric port number
- AI_ALL = $00000100; // Query both IP6 and IP4 with AI_V4MAPPED
- AI_ADDRCONFIG = $00000400; // Resolution only if global address configured
- AI_V4MAPPED = $00000800; // On v6 failure, query v4 and convert to V4MAPPED format
- AI_NON_AUTHORITATIVE = $00004000; // LUP_NON_AUTHORITATIVE
- AI_SECURE = $00008000; // LUP_SECURE
- AI_RETURN_PREFERRED_NAMES = $00010000; // LUP_RETURN_PREFERRED_NAMES
- AI_FQDN = $00020000; // Return the FQDN in ai_canonname
- AI_FILESERVER = $00040000; // Resolving fileserver name resolution
- type
- PAddrInfoA = ^TAddrInfoA;
- TAddrInfoA = record
- ai_flags: Integer;
- ai_family: Integer;
- ai_socktype: Integer;
- ai_protocol: Integer;
- ai_addrlen: NativeUInt;
- ai_canonname: PAnsiChar;
- ai_addr: PSockAddr;
- ai_next: PAddrInfoA;
- end;
- PAddrInfoW = ^TAddrInfoW;
- TAddrInfoW = record
- ai_flags: Integer;
- ai_family: Integer;
- ai_socktype: Integer;
- ai_protocol: Integer;
- ai_addrlen: NativeUInt;
- ai_canonname: PChar;
- ai_addr: PSockAddr;
- ai_next: PAddrInfoW;
- end;
- TAddressFamily = USHORT;
- TIn6Addr = record
- case Integer of
- 0: (_Byte: array[0..15] of UCHAR);
- 1: (_Word: array[0..7] of USHORT);
- end;
- TScopeId = record
- public
- Value: ULONG;
- strict private
- function GetBitField(Loc: Integer): Integer; inline;
- procedure SetBitField(Loc: Integer; const aValue: Integer); inline;
- public
- property Zone: Integer index $0028 read GetBitField write SetBitField;
- property Level: Integer index $2804 read GetBitField write SetBitField;
- end;
- TSockAddrIn6 = record
- sin6_family: TAddressFamily;
- sin6_port: USHORT;
- sin6_flowinfo: ULONG;
- sin6_addr: TIn6Addr;
- case Integer of
- 0: (sin6_scope_id: ULONG);
- 1: (sin6_scope_struct: TScopeId);
- end;
- PSockAddrIn6 = ^TSockAddrIn6;
- const
- NI_NOFQDN = $01; // Only return nodename portion for local hosts
- NI_NUMERICHOST = $02; // Return numeric form of the host's address
- NI_NAMEREQD = $04; // Error if the host's name not in DNS
- NI_NUMERICSERV = $08; // Return numeric form of the service (port #)
- NI_DGRAM = $10; // Service is a datagram service
- NI_MAXHOST = 1025; // Max size of a fully-qualified domain name
- NI_MAXSERV = 32; // Max size of a service name
- function getaddrinfo(pNodeName, pServiceName: PAnsiChar; const pHints: TAddrInfoA; var ppResult: PAddrInfoA): Integer; stdcall;
- function GetAddrInfoW(pNodeName, pServiceName: PWideChar; const pHints: TAddrInfoW; var ppResult: PAddrInfoW): Integer; stdcall;
- procedure freeaddrinfo(pAddrInfo: PAddrInfoA); stdcall;
- procedure FreeAddrInfoW(pAddrInfo: PAddrInfoW); stdcall;
- function getnameinfo(const pSockaddr: TSockAddr; SockaddrLength: Integer; pNodeBuffer: PAnsiChar; NodeBufferSize: DWORD; pServiceBuffer: PAnsiChar;
- ServiceBufferSize: DWORD; Flags: Integer): Integer; stdcall;
- function GetNameInfoW(const pSockaddr: TSockAddr; SockaddrLength: Integer; pNodeBuffer: PWideChar; NodeBufferSize: DWORD; pServiceBuffer: PWideChar;
- ServiceBufferSize: DWORD; Flags: Integer): Integer; stdcall;
- type
- TSmartPointerDestroyer<T> = reference to procedure(Value: T);
- ISmartPointer<T> = reference to function: T;
- TSmartPointer<T> = class(TInterfacedObject, ISmartPointer<T>)
- strict private
- FValue: T;
- FDestroyer: TSmartPointerDestroyer<T>;
- public
- constructor Create(AValue: T; ADestroyer: TSmartPointerDestroyer<T>);
- destructor Destroy; override;
- function Invoke: T;
- end;
- TBaseSocket = class abstract
- public type
- TLogDelegate = reference to procedure( const str: string);
- strict private
- FPort: Integer;
- FSocket: Winapi.Winsock2.TSocket;
- FSendTimeout,
- FRecvTimeout: Longword;
- FKeepAlive: Boolean;
- FLogDelegate: TLogDelegate;
- class constructor Create;
- class destructor Destroy;
- class procedure DefaultLogDelegate(const Str: string);
- strict protected type
- IGetAddrInfoWrapper = interface
- function Init: Integer;
- function GetRes: PAddrInfoW;
- property Res: PAddrInfoW read GetRes;
- end;
- TGetAddrInfoWrapper = class(TInterfacedObject, IGetAddrInfoWrapper)
- strict private
- FNode: string;
- FService: string;
- FHints,
- FRes: PAddrInfoW;
- public
- constructor Create(ANode, AService: string; AHints: PAddrInfoW);
- destructor Destroy; override;
- function Init: Integer;
- function GetRes: PAddrInfoW;
- property Res: PAddrInfoW read GetRes;
- end;
- strict protected
- procedure CommonInit; virtual;
- function CreateSocket(AAddress: string; APort: Integer): IGetAddrInfoWrapper;
- procedure SetRecvTimeout(ARecvTimeout: Longword); virtual;
- procedure SetSendTimeout(ASendTimeout: Longword); virtual;
- procedure SetKeepAlive(AKeepAlive: Boolean); virtual;
- procedure SetSocket(ASocket: Winapi.Winsock2.TSocket);
- property LogDelegate: TLogDelegate read FLogDelegate;
- public
- //
- // Constructs a new socket. Note that this does NOT actually connect the
- // socket.
- //
- constructor Create(ALogDelegate: TLogDelegate = nil); overload;
- constructor Create(APort: Integer; ALogDelegate: TLogDelegate = nil); overload;
- //
- // Destroys the socket object, closing it if necessary.
- //
- destructor Destroy; override;
- //
- // Shuts down communications on the socket
- //
- procedure Close; virtual;
- // The port that the socket is connected to
- property Port: Integer read FPort write FPort;
- // The receive timeout
- property RecvTimeout: Longword read FRecvTimeout write SetRecvTimeout;
- // The send timeout
- property SendTimeout: Longword read FSendTimeout write SetSendTimeout;
- // Set SO_KEEPALIVE
- property KeepAlive: Boolean read FKeepAlive write SetKeepAlive;
- // The underlying socket descriptor
- property Socket: Winapi.Winsock2.TSocket read FSocket write SetSocket;
- end;
- TSocket = class(TBaseSocket)
- strict private type
- TCachedPeerAddr = record
- case Integer of
- 0: (ipv4: TSockAddrIn);
- 1: (ipv6: TSockAddrIn6);
- end;
- strict private
- FHost: string;
- FPeerHost: string;
- FPeerAddress: string;
- FPeerPort: Integer;
- FInterruptListener: ISmartPointer<Winapi.Winsock2.TSocket>;
- FConnTimeout: Longword;
- FLingerOn: Boolean;
- FLingerVal: Integer;
- FNoDelay: Boolean;
- FMaxRecvRetries: Longword;
- FCachedPeerAddr: TCachedPeerAddr;
- procedure InitPeerInfo;
- procedure OpenConnection(Res: TBaseSocket.IGetAddrInfoWrapper);
- procedure LocalOpen;
- procedure SetGenericTimeout(S: Winapi.Winsock2.TSocket; Timeout: Longword; OptName: Integer);
- function GetIsOpen: Boolean;
- procedure SetNoDelay(ANoDelay: Boolean);
- function GetSocketInfo: string;
- function GetPeerHost: string;
- function GetPeerAddress: string;
- function GetPeerPort: Integer;
- function GetOrigin: string;
- strict protected
- procedure CommonInit; override;
- procedure SetRecvTimeout(ARecvTimeout: Longword); override;
- procedure SetSendTimeout(ASendTimeout: Longword); override;
- procedure SetKeepAlive(AKeepAlive: Boolean); override;
- public
- //
- // Constructs a new socket. Note that this does NOT actually connect the
- // socket.
- //
- constructor Create(ALogDelegate: TBaseSocket.TLogDelegate = nil); overload;
- //
- // Constructs a new socket. Note that this does NOT actually connect the
- // socket.
- //
- // @param host An IP address or hostname to connect to
- // @param port The port to connect on
- //
- constructor Create(AHost: string; APort: Integer; ALogDelegate: TBaseSocket.TLogDelegate = nil); overload;
- //
- // Constructor to create socket from socket descriptor.
- //
- constructor Create(ASocket: Winapi.Winsock2.TSocket; ALogDelegate: TBaseSocket.TLogDelegate = nil); overload;
- //
- // Constructor to create socket from socket descriptor that
- // can be interrupted safely.
- //
- constructor Create(ASocket: Winapi.Winsock2.TSocket; AInterruptListener: ISmartPointer<Winapi.Winsock2.TSocket>;
- ALogDelegate: TBaseSocket.TLogDelegate = nil); overload;
- //
- // Creates and opens the socket
- //
- // @throws ETransportationException If the socket could not connect
- //
- procedure Open;
- //
- // Shuts down communications on the socket
- //
- procedure Close; override;
- //
- // Reads from the underlying socket.
- // \returns the number of bytes read or 0 indicates EOF
- // \throws TTransportException of types:
- // Interrupted means the socket was interrupted
- // out of a blocking call
- // NotOpen means the socket has been closed
- // TimedOut means the receive timeout expired
- // Unknown means something unexpected happened
- //
- function Read(var Buf; Len: Integer): Integer;
- //
- // Writes to the underlying socket. Loops until done or fail.
- //
- procedure Write(const Buf; Len: Integer);
- //
- // Writes to the underlying socket. Does single send() and returns result.
- //
- function WritePartial(const Buf; Len: Integer): Integer;
- //
- // Returns a cached copy of the peer address.
- //
- function GetCachedAddress(out Len: Integer): PSockAddr;
- //
- // Set a cache of the peer address (used when trivially available: e.g.
- // accept() or connect()). Only caches IPV4 and IPV6; unset for others.
- //
- procedure SetCachedAddress(const Addr: TSockAddr; Len: Integer);
- //
- // Controls whether the linger option is set on the socket.
- //
- // @param on Whether SO_LINGER is on
- // @param linger If linger is active, the number of seconds to linger for
- //
- procedure SetLinger(LingerOn: Boolean; LingerVal: Integer);
- //
- // Calls select() on the socket to see if there is more data available.
- //
- function Peek: Boolean;
- // Whether the socket is alive
- property IsOpen: Boolean read GetIsOpen;
- // The host that the socket is connected to
- property Host: string read FHost write FHost;
- // Whether to enable or disable Nagle's algorithm
- property NoDelay: Boolean read FNoDelay write SetNoDelay;
- // Connect timeout
- property ConnTimeout: Longword read FConnTimeout write FConnTimeout;
- // The max number of recv retries in the case of a WSAEWOULDBLOCK
- property MaxRecvRetries: Longword read FMaxRecvRetries write FMaxRecvRetries;
- // Socket information formatted as a string <Host: x Port: x>
- property SocketInfo: string read GetSocketInfo;
- // The DNS name of the host to which the socket is connected
- property PeerHost: string read GetPeerHost;
- // The address of the host to which the socket is connected
- property PeerAddress: string read GetPeerAddress;
- // The port of the host to which the socket is connected
- property PeerPort: Integer read GetPeerPort;
- // The origin the socket is connected to
- property Origin: string read GetOrigin;
- end;
- TServerSocketFunc = reference to procedure(sock: Winapi.Winsock2.TSocket);
- TServerSocket = class(TBaseSocket)
- strict private
- FAddress: string;
- FAcceptBacklog,
- FRetryLimit,
- FRetryDelay,
- FTcpSendBuffer,
- FTcpRecvBuffer: Integer;
- FAcceptTimeout: Longword;
- FListening,
- FInterruptableChildren: Boolean;
- FInterruptSockWriter, // is notified on Interrupt()
- FInterruptSockReader, // is used in select with FSocket for interruptability
- FChildInterruptSockWriter: Winapi.Winsock2.TSocket; // is notified on InterruptChildren()
- FChildInterruptSockReader: ISmartPointer<Winapi.Winsock2.TSocket>; // if FnterruptableChildren this is shared with child TSockets
- FListenCallback,
- FAcceptCallback: TServerSocketFunc;
- function CreateSocketObj(Client: Winapi.Winsock2.TSocket): TSocket;
- procedure Notify(NotifySocket: Winapi.Winsock2.TSocket);
- procedure SetInterruptableChildren(AValue: Boolean);
- strict protected
- procedure CommonInit; override;
- public const
- DEFAULT_BACKLOG = 1024;
- public
- //
- // Constructor.
- //
- // @param port Port number to bind to
- //
- constructor Create(APort: Integer; ALogDelegate: TBaseSocket.TLogDelegate = nil); overload;
- //
- // Constructor.
- //
- // @param port Port number to bind to
- // @param sendTimeout Socket send timeout
- // @param recvTimeout Socket receive timeout
- //
- constructor Create(APort: Integer; ASendTimeout, ARecvTimeout: Longword; ALogDelegate: TBaseSocket.TLogDelegate = nil); overload;
- //
- // Constructor.
- //
- // @param address Address to bind to
- // @param port Port number to bind to
- //
- constructor Create(AAddress: string; APort: Integer; ALogDelegate: TBaseSocket.TLogDelegate = nil); overload;
- procedure Listen;
- function Accept: TSocket;
- procedure Interrupt;
- procedure InterruptChildren;
- procedure Close; override;
- property AcceptBacklog: Integer read FAcceptBacklog write FAcceptBacklog;
- property AcceptTimeout: Longword read FAcceptTimeout write FAcceptTimeout;
- property RetryLimit: Integer read FRetryLimit write FRetryLimit;
- property RetryDelay: Integer read FRetryDelay write FRetryDelay;
- property TcpSendBuffer: Integer read FTcpSendBuffer write FTcpSendBuffer;
- property TcpRecvBuffer: Integer read FTcpRecvBuffer write FTcpRecvBuffer;
- // When enabled (the default), new children TSockets will be constructed so
- // they can be interrupted by TServerTransport.InterruptChildren().
- // This is more expensive in terms of system calls (poll + recv) however
- // ensures a connected client cannot interfere with TServer.Stop().
- //
- // When disabled, TSocket children do not incur an additional poll() call.
- // Server-side reads are more efficient, however a client can interfere with
- // the server's ability to shutdown properly by staying connected.
- //
- // Must be called before listen(); mode cannot be switched after that.
- // \throws EPropertyError if listen() has been called
- property InterruptableChildren: Boolean read FInterruptableChildren write SetInterruptableChildren;
- // listenCallback gets called just before listen, and after all Thrift
- // setsockopt calls have been made. If you have custom setsockopt
- // things that need to happen on the listening socket, this is the place to do it.
- property ListenCallback: TServerSocketFunc read FListenCallback write FListenCallback;
- // acceptCallback gets called after each accept call, on the newly created socket.
- // It is called after all Thrift setsockopt calls have been made. If you have
- // custom setsockopt things that need to happen on the accepted
- // socket, this is the place to do it.
- property AcceptCallback: TServerSocketFunc read FAcceptCallback write FAcceptCallback;
- end;
- {$ENDIF} // not for OLD_SOCKETS
- implementation
- {$IFNDEF OLD_SOCKETS} // not for OLD_SOCKETS
- uses
- System.SysUtils, System.Math, System.DateUtils, Thrift.Transport;
- constructor TBaseSocket.TGetAddrInfoWrapper.Create(ANode, AService: string; AHints: PAddrInfoW);
- begin
- inherited Create;
- FNode := ANode;
- FService := AService;
- FHints := AHints;
- FRes := nil;
- end;
- destructor TBaseSocket.TGetAddrInfoWrapper.Destroy;
- begin
- if Assigned(FRes) then
- FreeAddrInfoW(FRes);
- inherited Destroy;
- end;
- function TBaseSocket.TGetAddrInfoWrapper.Init: Integer;
- begin
- if FRes = nil then
- Exit(GetAddrInfoW(@FNode[1], @FService[1], FHints^, FRes));
- Result := 0;
- end;
- function TBaseSocket.TGetAddrInfoWrapper.GetRes: PAddrInfoW;
- begin
- Result := FRes;
- end;
- procedure DestroyerOfFineSockets(ssock: Winapi.Winsock2.TSocket);
- begin
- closesocket(ssock);
- end;
- function TScopeId.GetBitField(Loc: Integer): Integer;
- begin
- Result := (Value shr (Loc shr 8)) and ((1 shl (Loc and $FF)) - 1);
- end;
- procedure TScopeId.SetBitField(Loc: Integer; const aValue: Integer);
- begin
- Value := (Value and ULONG((not ((1 shl (Loc and $FF)) - 1)))) or ULONG(aValue shl (Loc shr 8));
- end;
- function getaddrinfo; external 'ws2_32.dll' name 'getaddrinfo';
- function GetAddrInfoW; external 'ws2_32.dll' name 'GetAddrInfoW';
- procedure freeaddrinfo; external 'ws2_32.dll' name 'freeaddrinfo';
- procedure FreeAddrInfoW; external 'ws2_32.dll' name 'FreeAddrInfoW';
- function getnameinfo; external 'ws2_32.dll' name 'getnameinfo';
- function GetNameInfoW; external 'ws2_32.dll' name 'GetNameInfoW';
- constructor TSmartPointer<T>.Create(AValue: T; ADestroyer: TSmartPointerDestroyer<T>);
- begin
- inherited Create;
- FValue := AValue;
- FDestroyer := ADestroyer;
- end;
- destructor TSmartPointer<T>.Destroy;
- begin
- if Assigned(FDestroyer) then FDestroyer(FValue);
- inherited Destroy;
- end;
- function TSmartPointer<T>.Invoke: T;
- begin
- Result := FValue;
- end;
- class constructor TBaseSocket.Create;
- var
- Version: WORD;
- Data: WSAData;
- Error: Integer;
- begin
- Version := $0202;
- FillChar(Data, SizeOf(Data), 0);
- Error := WSAStartup(Version, Data);
- if Error <> 0 then
- raise Exception.Create('Failed to initialize Winsock.');
- end;
- class destructor TBaseSocket.Destroy;
- begin
- WSACleanup;
- end;
- class procedure TBaseSocket.DefaultLogDelegate(const Str: string);
- var
- OutStr: string;
- begin
- OutStr := Format('Thrift: %s %s', [DateTimeToStr(Now, TFormatSettings.Create), Str]);
- try
- Writeln(OutStr);
- if IoResult <> 0 then OutputDebugString(PChar(OutStr));
- except
- OutputDebugString(PChar(OutStr));
- end;
- end;
- procedure TBaseSocket.CommonInit;
- begin
- FSocket := INVALID_SOCKET;
- FPort := 0;
- FSendTimeout := 0;
- FRecvTimeout := 0;
- FKeepAlive := False;
- FLogDelegate := DefaultLogDelegate;
- end;
- function TBaseSocket.CreateSocket(AAddress: string; APort: Integer): IGetAddrInfoWrapper;
- var
- Hints: TAddrInfoW;
- Res: PAddrInfoW;
- ThePort: array[0..5] of Char;
- Error: Integer;
- begin
- FillChar(Hints, SizeOf(Hints), 0);
- Hints.ai_family := PF_UNSPEC;
- Hints.ai_socktype := SOCK_STREAM;
- Hints.ai_flags := AI_PASSIVE;
- StrFmt(ThePort, '%d', [FPort]);
- Result := TGetAddrInfoWrapper.Create(AAddress, ThePort, @Hints);
- Error := Result.Init;
- if Error <> 0 then begin
- LogDelegate(Format('GetAddrInfoW %d: %s', [Error, SysErrorMessage(Error)]));
- Close;
- raise TTransportExceptionNotOpen.Create('Could not resolve host for server socket.');
- end;
- // Pick the ipv6 address first since ipv4 addresses can be mapped
- // into ipv6 space.
- Res := Result.Res;
- while Assigned(Res) do begin
- if (Res^.ai_family = AF_INET6) or (not Assigned(Res^.ai_next)) then
- Break;
- Res := Res^.ai_next;
- end;
- FSocket := Winapi.Winsock2.socket(Res^.ai_family, Res^.ai_socktype, Res^.ai_protocol);
- if FSocket = INVALID_SOCKET then begin
- Error := WSAGetLastError;
- LogDelegate(Format('TBaseSocket.CreateSocket() socket() %s', [SysErrorMessage(Error)]));
- Close;
- raise TTransportExceptionNotOpen.Create(Format('socket(): %s', [SysErrorMessage(Error)]));
- end;
- end;
- procedure TBaseSocket.SetRecvTimeout(ARecvTimeout: Longword);
- begin
- FRecvTimeout := ARecvTimeout;
- end;
- procedure TBaseSocket.SetSendTimeout(ASendTimeout: Longword);
- begin
- FSendTimeout := ASendTimeout;
- end;
- procedure TBaseSocket.SetKeepAlive(AKeepAlive: Boolean);
- begin
- FKeepAlive := AKeepAlive;
- end;
- procedure TBaseSocket.SetSocket(ASocket: Winapi.Winsock2.TSocket);
- begin
- if FSocket <> INVALID_SOCKET then
- Close;
- FSocket := ASocket;
- end;
- constructor TBaseSocket.Create(ALogDelegate: TLogDelegate);
- begin
- inherited Create;
- CommonInit;
- if Assigned(ALogDelegate) then FLogDelegate := ALogDelegate;
- end;
- constructor TBaseSocket.Create(APort: Integer; ALogDelegate: TLogDelegate);
- begin
- inherited Create;
- CommonInit;
- FPort := APort;
- if Assigned(ALogDelegate) then FLogDelegate := ALogDelegate;
- end;
- destructor TBaseSocket.Destroy;
- begin
- Close;
- inherited Destroy;
- end;
- procedure TBaseSocket.Close;
- begin
- if FSocket <> INVALID_SOCKET then begin
- shutdown(FSocket, SD_BOTH);
- closesocket(FSocket);
- end;
- FSocket := INVALID_SOCKET;
- end;
- procedure TSocket.InitPeerInfo;
- begin
- FCachedPeerAddr.ipv4.sin_family := AF_UNSPEC;
- FPeerHost := '';
- FPeerAddress := '';
- FPeerPort := 0;
- end;
- procedure TSocket.CommonInit;
- begin
- inherited CommonInit;
- FHost := '';
- FInterruptListener := nil;
- FConnTimeout := 0;
- FLingerOn := True;
- FLingerVal := 0;
- FNoDelay := True;
- FMaxRecvRetries := 5;
- InitPeerInfo;
- end;
- procedure TSocket.OpenConnection(Res: TBaseSocket.IGetAddrInfoWrapper);
- label
- Done;
- var
- ErrnoCopy: Integer;
- Ret,
- Ret2: Integer;
- Fds: TFdSet;
- TVal: TTimeVal;
- PTVal: PTimeVal;
- Val,
- Lon: Integer;
- One,
- Zero: Cardinal;
- begin
- if SendTimeout > 0 then SetSendTimeout(SendTimeout);
- if RecvTimeout > 0 then SetRecvTimeout(RecvTimeout);
- if KeepAlive then SetKeepAlive(KeepAlive);
- SetLinger(FLingerOn, FLingerVal);
- SetNoDelay(FNoDelay);
- // Set the socket to be non blocking for connect if a timeout exists
- Zero := 0;
- if FConnTimeout > 0 then begin
- One := 1;
- if ioctlsocket(Socket, Integer(FIONBIO), One) = SOCKET_ERROR then begin
- ErrnoCopy := WSAGetLastError;
- LogDelegate(Format('TSocket.OpenConnection() ioctlsocket() %s %s', [SocketInfo, SysErrorMessage(ErrnoCopy)]));
- raise TTransportExceptionNotOpen.Create(Format('ioctlsocket() failed: %s', [SysErrorMessage(ErrnoCopy)]));
- end;
- end
- else begin
- if ioctlsocket(Socket, Integer(FIONBIO), Zero) = SOCKET_ERROR then begin
- ErrnoCopy := WSAGetLastError;
- LogDelegate(Format('TSocket.OpenConnection() ioctlsocket() %s %s', [SocketInfo, SysErrorMessage(ErrnoCopy)]));
- raise TTransportExceptionNotOpen.Create(Format('ioctlsocket() failed: %s', [SysErrorMessage(ErrnoCopy)]));
- end;
- end;
- Ret := connect(Socket, Res.Res^.ai_addr^, Res.Res^.ai_addrlen);
- if Ret = 0 then goto Done;
- ErrnoCopy := WSAGetLastError;
- if (ErrnoCopy <> WSAEINPROGRESS) and (ErrnoCopy <> WSAEWOULDBLOCK) then begin
- LogDelegate(Format('TSocket.OpenConnection() connect() ', [SocketInfo, SysErrorMessage(ErrnoCopy)]));
- raise TTransportExceptionNotOpen.Create(Format('connect() failed: %s', [SysErrorMessage(ErrnoCopy)]));
- end;
- FD_ZERO(Fds);
- _FD_SET(Socket, Fds);
- if FConnTimeout > 0 then begin
- TVal.tv_sec := FConnTimeout div 1000;
- TVal.tv_usec := (FConnTimeout mod 1000) * 1000;
- PTVal := @TVal;
- end
- else
- PTVal := nil;
- Ret := select(1, nil, @Fds, nil, PTVal);
- if Ret > 0 then begin
- // Ensure the socket is connected and that there are no errors set
- Lon := SizeOf(Val);
- Ret2 := getsockopt(Socket, SOL_SOCKET, SO_ERROR, @Val, Lon);
- if Ret2 = SOCKET_ERROR then begin
- ErrnoCopy := WSAGetLastError;
- LogDelegate(Format('TSocket.OpenConnection() getsockopt() ', [SocketInfo, SysErrorMessage(ErrnoCopy)]));
- raise TTransportExceptionNotOpen.Create(Format('getsockopt(): %s', [SysErrorMessage(ErrnoCopy)]));
- end;
- // no errors on socket, go to town
- if Val = 0 then goto Done;
- LogDelegate(Format('TSocket.OpenConnection() error on socket (after select()) ', [SocketInfo, SysErrorMessage(ErrnoCopy)]));
- raise TTransportExceptionNotOpen.Create(Format('socket OpenConnection() error: %s', [SysErrorMessage(Val)]));
- end
- else if Ret = 0 then begin
- // socket timed out
- LogDelegate(Format('TSocket.OpenConnection() timed out ', [SocketInfo, SysErrorMessage(ErrnoCopy)]));
- raise TTransportExceptionNotOpen.Create('OpenConnection() timed out');
- end
- else begin
- // error on select()
- ErrnoCopy := WSAGetLastError;
- LogDelegate(Format('TSocket.OpenConnection() select() ', [SocketInfo, SysErrorMessage(ErrnoCopy)]));
- raise TTransportExceptionNotOpen.Create(Format('select() failed: %s', [SysErrorMessage(ErrnoCopy)]));
- end;
- Done:
- // Set socket back to normal mode (blocking)
- ioctlsocket(Socket, Integer(FIONBIO), Zero);
- SetCachedAddress(Res.Res^.ai_addr^, Res.Res^.ai_addrlen);
- end;
- procedure TSocket.LocalOpen;
- var
- Res: TBaseSocket.IGetAddrInfoWrapper;
- begin
- if IsOpen then Exit;
- // Validate port number
- if (Port < 0) or (Port > $FFFF) then
- raise TTransportExceptionBadArgs.Create('Specified port is invalid');
- Res := CreateSocket(Host, Port);
- OpenConnection(Res);
- end;
- procedure TSocket.SetGenericTimeout(S: Winapi.Winsock2.TSocket; Timeout: Longword; OptName: Integer);
- var
- Time: DWORD;
- begin
- if S = INVALID_SOCKET then
- Exit;
- Time := Timeout;
- if setsockopt(S, SOL_SOCKET, OptName, @Time, SizeOf(Time)) = SOCKET_ERROR then
- LogDelegate(Format('SetGenericTimeout() setsockopt() %s', [SysErrorMessage(WSAGetLastError)]));
- end;
- function TSocket.GetIsOpen: Boolean;
- begin
- Result := Socket <> INVALID_SOCKET;
- end;
- procedure TSocket.SetNoDelay(ANoDelay: Boolean);
- var
- V: Integer;
- begin
- FNoDelay := ANoDelay;
- if Socket = INVALID_SOCKET then
- Exit;
- V := IfThen(FNoDelay, 1, 0);
- if setsockopt(Socket, IPPROTO_TCP, TCP_NODELAY, @V, SizeOf(V)) = SOCKET_ERROR then
- LogDelegate(Format('TSocket.SetNoDelay() setsockopt() %s %s', [SocketInfo, SysErrorMessage(WSAGetLastError)]));
- end;
- function TSocket.GetSocketInfo: string;
- begin
- if (FHost = '') or (Port = 0) then
- Result := '<Host: ' + GetPeerAddress + ' Port: ' + GetPeerPort.ToString + '>'
- else
- Result := '<Host: ' + FHost + ' Port: ' + Port.ToString + '>';
- end;
- function TSocket.GetPeerHost: string;
- var
- Addr: TSockAddrStorage;
- AddrPtr: PSockAddr;
- AddrLen: Integer;
- ClientHost: array[0..NI_MAXHOST-1] of Char;
- ClientService: array[0..NI_MAXSERV-1] of Char;
- begin
- if FPeerHost = '' then begin
- if Socket = INVALID_SOCKET then
- Exit(FPeerHost);
- AddrPtr := GetCachedAddress(AddrLen);
- if AddrPtr = nil then begin
- AddrLen := SizeOf(Addr);
- if getpeername(Socket, PSockAddr(@Addr)^, AddrLen) <> 0 then
- Exit(FPeerHost);
- AddrPtr := PSockAddr(@Addr);
- SetCachedAddress(AddrPtr^, AddrLen);
- end;
- GetNameInfoW(AddrPtr^, AddrLen, ClientHost, NI_MAXHOST, ClientService, NI_MAXSERV, 0);
- FPeerHost := ClientHost;
- end;
- Result := FPeerHost;
- end;
- function TSocket.GetPeerAddress: string;
- var
- Addr: TSockAddrStorage;
- AddrPtr: PSockAddr;
- AddrLen: Integer;
- ClientHost: array[0..NI_MAXHOST-1] of Char;
- ClientService: array[0..NI_MAXSERV-1] of Char;
- begin
- if FPeerAddress = '' then begin
- if Socket = INVALID_SOCKET then
- Exit(FPeerAddress);
- AddrPtr := GetCachedAddress(AddrLen);
- if AddrPtr = nil then begin
- AddrLen := SizeOf(Addr);
- if getpeername(Socket, PSockAddr(@Addr)^, AddrLen) <> 0 then
- Exit(FPeerHost);
- AddrPtr := PSockAddr(@Addr);
- SetCachedAddress(AddrPtr^, AddrLen);
- end;
- GetNameInfoW(AddrPtr^, AddrLen, ClientHost, NI_MAXHOST, ClientService, NI_MAXSERV, NI_NUMERICHOST or NI_NUMERICSERV);
- FPeerAddress := ClientHost;
- TryStrToInt(ClientService, FPeerPort);
- end;
- Result := FPeerAddress
- end;
- function TSocket.GetPeerPort: Integer;
- begin
- GetPeerAddress;
- Result := FPeerPort;
- end;
- function TSocket.GetOrigin: string;
- begin
- Result := GetPeerHost + ':' + GetPeerPort.ToString;
- end;
- procedure TSocket.SetRecvTimeout(ARecvTimeout: Longword);
- begin
- inherited SetRecvTimeout(ARecvTimeout);
- SetGenericTimeout(Socket, ARecvTimeout, SO_RCVTIMEO);
- end;
- procedure TSocket.SetSendTimeout(ASendTimeout: Longword);
- begin
- inherited SetSendTimeout(ASendTimeout);
- SetGenericTimeout(Socket, ASendTimeout, SO_SNDTIMEO);
- end;
- procedure TSocket.SetKeepAlive(AKeepAlive: Boolean);
- var
- Value: Integer;
- begin
- inherited SetKeepAlive(AKeepAlive);
- Value := IfThen(KeepAlive, 1, 0);
- if setsockopt(Socket, SOL_SOCKET, SO_KEEPALIVE, @Value, SizeOf(Value)) = SOCKET_ERROR then
- LogDelegate(Format('TSocket.SetKeepAlive() setsockopt() %s %s', [SocketInfo, SysErrorMessage(WSAGetLastError)]));
- end;
- constructor TSocket.Create(ALogDelegate: TBaseSocket.TLogDelegate = nil);
- begin
- // Not needed, but just a placeholder
- inherited Create(ALogDelegate);
- end;
- constructor TSocket.Create(AHost: string; APort: Integer; ALogDelegate: TBaseSocket.TLogDelegate);
- begin
- inherited Create(APort, ALogDelegate);
- FHost := AHost;
- end;
- constructor TSocket.Create(ASocket: Winapi.Winsock2.TSocket; ALogDelegate: TBaseSocket.TLogDelegate);
- begin
- inherited Create(ALogDelegate);
- Socket := ASocket;
- end;
- constructor TSocket.Create(ASocket: Winapi.Winsock2.TSocket; AInterruptListener: ISmartPointer<Winapi.Winsock2.TSocket>;
- ALogDelegate: TBaseSocket.TLogDelegate);
- begin
- inherited Create(ALogDelegate);
- Socket := ASocket;
- FInterruptListener := AInterruptListener;
- end;
- procedure TSocket.Open;
- begin
- if IsOpen then Exit;
- LocalOpen;
- end;
- procedure TSocket.Close;
- begin
- inherited Close;
- InitPeerInfo;
- end;
- function TSocket.Read(var Buf; Len: Integer): Integer;
- label
- TryAgain;
- var
- Retries: Longword;
- EAgainThreshold,
- ReadElapsed: UInt64;
- Start: TDateTime;
- Got: Integer;
- Fds: TFdSet;
- ErrnoCopy: Integer;
- TVal: TTimeVal;
- PTVal: PTimeVal;
- Ret: Integer;
- begin
- if Socket = INVALID_SOCKET then
- raise TTransportExceptionNotOpen.Create('Called read on non-open socket');
- Retries := 0;
- // THRIFT_EAGAIN can be signalled both when a timeout has occurred and when
- // the system is out of resources (an awesome undocumented feature).
- // The following is an approximation of the time interval under which
- // THRIFT_EAGAIN is taken to indicate an out of resources error.
- EAgainThreshold := 0;
- if RecvTimeout <> 0 then
- // if a readTimeout is specified along with a max number of recv retries, then
- // the threshold will ensure that the read timeout is not exceeded even in the
- // case of resource errors
- EAgainThreshold := RecvTimeout div IfThen(FMaxRecvRetries > 0, FMaxRecvRetries, 2);
- TryAgain:
- // Read from the socket
- if RecvTimeout > 0 then
- Start := Now
- else
- // if there is no read timeout we don't need the TOD to determine whether
- // an THRIFT_EAGAIN is due to a timeout or an out-of-resource condition.
- Start := 0;
- if Assigned(FInterruptListener) then begin
- FD_ZERO(Fds);
- _FD_SET(Socket, Fds);
- _FD_SET(FInterruptListener, Fds);
- if RecvTimeout > 0 then begin
- TVal.tv_sec := RecvTimeout div 1000;
- TVal.tv_usec := (RecvTimeout mod 1000) * 1000;
- PTVal := @TVal;
- end
- else
- PTVal := nil;
- Ret := select(2, @Fds, nil, nil, PTVal);
- ErrnoCopy := WSAGetLastError;
- if Ret < 0 then begin
- // error cases
- if (ErrnoCopy = WSAEINTR) and (Retries < FMaxRecvRetries) then begin
- Inc(Retries);
- goto TryAgain;
- end;
- LogDelegate(Format('TSocket.Read() select() %s', [SysErrorMessage(ErrnoCopy)]));
- raise TTransportExceptionUnknown.Create(Format('Unknown: %s', [SysErrorMessage(ErrnoCopy)]));
- end
- else if Ret > 0 then begin
- // Check the interruptListener
- if FD_ISSET(FInterruptListener, Fds) then
- raise TTransportExceptionInterrupted.Create('Interrupted');
- end
- else // Ret = 0
- raise TTransportExceptionTimedOut.Create('WSAEWOULDBLOCK (timed out)');
- // falling through means there is something to recv and it cannot block
- end;
- Got := recv(Socket, Buf, Len, 0);
- ErrnoCopy := WSAGetLastError;
- // Check for error on read
- if Got < 0 then begin
- if ErrnoCopy = WSAEWOULDBLOCK then begin
- // if no timeout we can assume that resource exhaustion has occurred.
- if RecvTimeout = 0 then
- raise TTransportExceptionTimedOut.Create('WSAEWOULDBLOCK (unavailable resources)');
- // check if this is the lack of resources or timeout case
- ReadElapsed := MilliSecondsBetween(Now, Start);
- if (EAgainThreshold = 0) or (ReadElapsed < EAgainThreshold) then begin
- if Retries < FMaxRecvRetries then begin
- Inc(Retries);
- Sleep(1);
- goto TryAgain;
- end
- else
- raise TTransportExceptionTimedOut.Create('WSAEWOULDBLOCK (unavailable resources)');
- end
- else
- // infer that timeout has been hit
- raise TTransportExceptionTimedOut.Create('WSAEWOULDBLOCK (timed out)');
- end;
- // If interrupted, try again
- if (ErrnoCopy = WSAEINTR) and (Retries < FMaxRecvRetries) then begin
- Inc(Retries);
- goto TryAgain;
- end;
- if ErrnoCopy = WSAECONNRESET then
- Exit(0);
- // This ish isn't open
- if ErrnoCopy = WSAENOTCONN then
- raise TTransportExceptionNotOpen.Create('WSAENOTCONN');
- // Timed out!
- if ErrnoCopy = WSAETIMEDOUT then
- raise TTransportExceptionNotOpen.Create('WSAETIMEDOUT');
- // Now it's not a try again case, but a real probblez
- LogDelegate(Format('TSocket.Read() recv() %s %s', [SocketInfo, SysErrorMessage(ErrnoCopy)]));
- // Some other error, whatevz
- raise TTransportExceptionUnknown.Create(Format('Unknown: %s', [SysErrorMessage(ErrnoCopy)]));
- end;
- Result := Got;
- end;
- procedure TSocket.Write(const Buf; Len: Integer);
- var
- Sent, B: Integer;
- begin
- Sent := 0;
- while Sent < Len do begin
- B := WritePartial((PByte(@Buf) + Sent)^, Len - Sent);
- if B = 0 then
- // This should only happen if the timeout set with SO_SNDTIMEO expired.
- // Raise an exception.
- raise TTransportExceptionTimedOut.Create('send timeout expired');
- Inc(Sent, B);
- end;
- end;
- function TSocket.WritePartial(const Buf; Len: Integer): Integer;
- var
- B: Integer;
- ErrnoCopy: Integer;
- begin
- if Socket = INVALID_SOCKET then
- raise TTransportExceptionNotOpen.Create('Called write on non-open socket');
- B := send(Socket, Buf, Len, 0);
- if B < 0 then begin
- // Fail on a send error
- ErrnoCopy := WSAGetLastError;
- if ErrnoCopy = WSAEWOULDBLOCK then
- Exit(0);
- LogDelegate(Format('TSocket.WritePartial() send() %s %s', [SocketInfo, SysErrorMessage(ErrnoCopy)]));
- if (ErrnoCopy = WSAECONNRESET) or (ErrnoCopy = WSAENOTCONN) then begin
- Close;
- raise TTransportExceptionNotOpen.Create(Format('write() send(): %s', [SysErrorMessage(ErrnoCopy)]));
- end;
- raise TTransportExceptionUnknown.Create(Format('write() send(): %s', [SysErrorMessage(ErrnoCopy)]));
- end;
- // Fail on blocked send
- if B = 0 then
- raise TTransportExceptionNotOpen.Create('Socket send returned 0.');
- Result := B;
- end;
- function TSocket.GetCachedAddress(out Len: Integer): PSockAddr;
- begin
- case FCachedPeerAddr.ipv4.sin_family of
- AF_INET: begin
- Len := SizeOf(TSockAddrIn);
- Result := PSockAddr(@FCachedPeerAddr.ipv4);
- end;
- AF_INET6: begin
- Len := SizeOf(TSockAddrIn6);
- Result := PSockAddr(@FCachedPeerAddr.ipv6);
- end;
- else
- Len := 0;
- Result := nil;
- end;
- end;
- procedure TSocket.SetCachedAddress(const Addr: TSockAddr; Len: Integer);
- begin
- case Addr.sa_family of
- AF_INET: if Len = SizeOf(TSockAddrIn) then FCachedPeerAddr.ipv4 := PSockAddrIn(@Addr)^;
- AF_INET6: if Len = SizeOf(TSockAddrIn6) then FCachedPeerAddr.ipv6 := PSockAddrIn6(@Addr)^;
- end;
- FPeerAddress := '';
- FPeerHost := '';
- FPeerPort := 0;
- end;
- procedure TSocket.SetLinger(LingerOn: Boolean; LingerVal: Integer);
- var
- L: TLinger;
- begin
- FLingerOn := LingerOn;
- FLingerVal := LingerVal;
- if Socket = INVALID_SOCKET then
- Exit;
- L.l_onoff := IfThen(FLingerOn, 1, 0);
- L.l_linger := LingerVal;
- if setsockopt(Socket, SOL_SOCKET, SO_LINGER, @L, SizeOf(L)) = SOCKET_ERROR then
- LogDelegate(Format('TSocket.SetLinger() setsockopt() %s %s', [SocketInfo, SysErrorMessage(WSAGetLastError)]));
- end;
- function TSocket.Peek: Boolean;
- var
- Retries: Longword;
- Fds: TFdSet;
- TVal: TTimeVal;
- PTVal: PTimeVal;
- Ret: Integer;
- ErrnoCopy: Integer;
- Buf: Byte;
- begin
- if not IsOpen then Exit(False);
- if Assigned(FInterruptListener) then begin
- Retries := 0;
- while true do begin
- FD_ZERO(Fds);
- _FD_SET(Socket, Fds);
- _FD_SET(FInterruptListener, Fds);
- if RecvTimeout > 0 then begin
- TVal.tv_sec := RecvTimeout div 1000;
- TVal.tv_usec := (RecvTimeout mod 1000) * 1000;
- PTVal := @TVal;
- end
- else
- PTVal := nil;
- Ret := select(2, @Fds, nil, nil, PTVal);
- ErrnoCopy := WSAGetLastError;
- if Ret < 0 then begin
- // error cases
- if (ErrnoCopy = WSAEINTR) and (Retries < FMaxRecvRetries) then begin
- Inc(Retries);
- Continue;
- end;
- LogDelegate(Format('TSocket.Peek() select() %s', [SysErrorMessage(ErrnoCopy)]));
- raise TTransportExceptionUnknown.Create(Format('Unknown: %s', [SysErrorMessage(ErrnoCopy)]));
- end
- else if Ret > 0 then begin
- // Check the interruptListener
- if FD_ISSET(FInterruptListener, Fds) then
- Exit(False);
- // There must be data or a disconnection, fall through to the PEEK
- Break;
- end
- else
- // timeout
- Exit(False);
- end;
- end;
- // Check to see if data is available or if the remote side closed
- Ret := recv(Socket, Buf, 1, MSG_PEEK);
- if Ret = SOCKET_ERROR then begin
- ErrnoCopy := WSAGetLastError;
- if ErrnoCopy = WSAECONNRESET then begin
- Close;
- Exit(False);
- end;
- LogDelegate(Format('TSocket.Peek() recv() %s %s', [SocketInfo, SysErrorMessage(ErrnoCopy)]));
- raise TTransportExceptionUnknown.Create(Format('recv(): %s', [SysErrorMessage(ErrnoCopy)]));
- end;
- Result := Ret > 0;
- end;
- function TServerSocket.CreateSocketObj(Client: Winapi.Winsock2.TSocket): TSocket;
- begin
- if FInterruptableChildren then
- Result := TSocket.Create(Client, FChildInterruptSockReader)
- else
- Result := TSocket.Create(Client);
- end;
- procedure TServerSocket.Notify(NotifySocket: Winapi.Winsock2.TSocket);
- var
- Byt: Byte;
- begin
- if NotifySocket <> INVALID_SOCKET then begin
- Byt := 0;
- if send(NotifySocket, Byt, SizeOf(Byt), 0) = SOCKET_ERROR then
- LogDelegate(Format('TServerSocket.Notify() send() %s', [SysErrorMessage(WSAGetLastError)]));
- end;
- end;
- procedure TServerSocket.SetInterruptableChildren(AValue: Boolean);
- begin
- if FListening then
- raise Exception.Create('InterruptableChildren cannot be set after listen()');
- FInterruptableChildren := AValue;
- end;
- procedure TServerSocket.CommonInit;
- begin
- inherited CommonInit;
- FInterruptableChildren := True;
- FAcceptBacklog := DEFAULT_BACKLOG;
- FAcceptTimeout := 0;
- FRetryLimit := 0;
- FRetryDelay := 0;
- FTcpSendBuffer := 0;
- FTcpRecvBuffer := 0;
- FListening := False;
- FInterruptSockWriter := INVALID_SOCKET;
- FInterruptSockReader := INVALID_SOCKET;
- FChildInterruptSockWriter := INVALID_SOCKET;
- end;
- constructor TServerSocket.Create(APort: Integer; ALogDelegate: TBaseSocket.TLogDelegate = nil);
- begin
- // Unnecessary, but here for documentation purposes
- inherited Create(APort, ALogDelegate);
- end;
- constructor TServerSocket.Create(APort: Integer; ASendTimeout, ARecvTimeout: Longword; ALogDelegate: TBaseSocket.TLogDelegate);
- begin
- inherited Create(APort, ALogDelegate);
- SendTimeout := ASendTimeout;
- RecvTimeout := ARecvTimeout;
- end;
- constructor TServerSocket.Create(AAddress: string; APort: Integer; ALogDelegate: TBaseSocket.TLogDelegate);
- begin
- inherited Create(APort, ALogDelegate);
- FAddress := AAddress;
- end;
- procedure TServerSocket.Listen;
- function CreateSocketPair(var Reader, Writer: Winapi.Winsock2.TSocket): Integer;
- label
- Error;
- type
- TSAUnion = record
- case Integer of
- 0: (inaddr: TSockAddrIn);
- 1: (addr: TSockAddr);
- end;
- var
- a: TSAUnion;
- listener: Winapi.Winsock2.TSocket;
- e: Integer;
- addrlen: Integer;
- flags: DWORD;
- reuse: Integer;
- begin
- addrlen := SizeOf(a.inaddr);
- flags := 0;
- reuse := 1;
- listener := Winapi.Winsock2.socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
- if listener = INVALID_SOCKET then
- Exit(SOCKET_ERROR);
- FillChar(a, SizeOf(a), 0);
- a.inaddr.sin_family := AF_INET;
- a.inaddr.sin_addr.s_addr := htonl(INADDR_LOOPBACK);
- a.inaddr.sin_port := 0;
- Reader := INVALID_SOCKET;
- Writer := INVALID_SOCKET;
- // ignore errors coming out of this setsockopt. This is because
- // SO_EXCLUSIVEADDRUSE requires admin privileges on WinXP, but we don't
- // want to force socket pairs to be an admin.
- setsockopt(listener, SOL_SOCKET, Integer(SO_EXCLUSIVEADDRUSE), @reuse, SizeOf(reuse));
- if bind(listener, a.addr, SizeOf(a.inaddr)) = SOCKET_ERROR then
- goto Error;
- if getsockname(listener, a.addr, addrlen) = SOCKET_ERROR then
- goto Error;
- if Winapi.Winsock2.listen(listener, 1) = SOCKET_ERROR then
- goto Error;
- Reader := WSASocket(AF_INET, SOCK_STREAM, 0, nil, 0, flags);
- if Reader = INVALID_SOCKET then
- goto Error;
- if connect(Reader, a.addr, SizeOf(a.inaddr)) = SOCKET_ERROR then
- goto Error;
- Writer := Winapi.Winsock2.accept(listener, nil, nil);
- if Writer = INVALID_SOCKET then
- goto Error;
- closesocket(listener);
- Exit(0);
- Error:
- e := WSAGetLastError;
- closesocket(listener);
- closesocket(Reader);
- closesocket(Writer);
- WSASetLastError(e);
- Result := SOCKET_ERROR;
- end;
- var
- TempIntReader,
- TempIntWriter: Winapi.Winsock2.TSocket;
- One: Cardinal;
- ErrnoCopy: Integer;
- Ling: TLinger;
- Retries: Integer;
- AddrInfo: IGetAddrInfoWrapper;
- SA: TSockAddrStorage;
- Len: Integer;
- begin
- // Create the socket pair used to interrupt
- if CreateSocketPair(TempIntReader, TempIntWriter) = SOCKET_ERROR then begin
- LogDelegate(Format('TServerSocket.Listen() CreateSocketPair() Interrupt %s', [SysErrorMessage(WSAGetLastError)]));
- FInterruptSockReader := INVALID_SOCKET;
- FInterruptSockWriter := INVALID_SOCKET;
- end
- else begin
- FInterruptSockReader := TempIntReader;
- FInterruptSockWriter := TempIntWriter;
- end;
- // Create the socket pair used to interrupt all clients
- if CreateSocketPair(TempIntReader, TempIntWriter) = SOCKET_ERROR then begin
- LogDelegate(Format('TServerSocket.Listen() CreateSocketPair() ChildInterrupt %s', [SysErrorMessage(WSAGetLastError)]));
- FChildInterruptSockReader := TSmartPointer<Winapi.Winsock2.TSocket>.Create(INVALID_SOCKET, nil);
- FChildInterruptSockWriter := INVALID_SOCKET;
- end
- else begin
- FChildInterruptSockReader := TSmartPointer<Winapi.Winsock2.TSocket>.Create(TempIntReader, DestroyerOfFineSockets);
- FChildInterruptSockWriter := TempIntWriter;
- end;
- if (Port < 0) or (Port > $FFFF) then
- raise TTransportExceptionBadArgs.Create('Specified port is invalid');
- AddrInfo := CreateSocket(FAddress, Port);
- // Set SO_EXCLUSIVEADDRUSE to prevent 2MSL delay on accept
- One := 1;
- setsockopt(Socket, SOL_SOCKET, Integer(SO_EXCLUSIVEADDRUSE), @one, SizeOf(One));
- // ignore errors coming out of this setsockopt on Windows. This is because
- // SO_EXCLUSIVEADDRUSE requires admin privileges on WinXP, but we don't
- // want to force servers to be an admin.
- // Set TCP buffer sizes
- if FTcpSendBuffer > 0 then begin
- if setsockopt(Socket, SOL_SOCKET, SO_SNDBUF, @FTcpSendBuffer, SizeOf(FTcpSendBuffer)) = SOCKET_ERROR then begin
- ErrnoCopy := WSAGetLastError;
- LogDelegate(Format('TServerSocket.Listen() setsockopt() SO_SNDBUF %s', [SysErrorMessage(ErrnoCopy)]));
- raise TTransportExceptionNotOpen.Create(Format('Could not set SO_SNDBUF: %s', [SysErrorMessage(ErrnoCopy)]));
- end;
- end;
- if FTcpRecvBuffer > 0 then begin
- if setsockopt(Socket, SOL_SOCKET, SO_RCVBUF, @FTcpRecvBuffer, SizeOf(FTcpRecvBuffer)) = SOCKET_ERROR then begin
- ErrnoCopy := WSAGetLastError;
- LogDelegate(Format('TServerSocket.Listen() setsockopt() SO_RCVBUF %s', [SysErrorMessage(ErrnoCopy)]));
- raise TTransportExceptionNotOpen.Create(Format('Could not set SO_RCVBUF: %s', [SysErrorMessage(ErrnoCopy)]));
- end;
- end;
- // Turn linger off, don't want to block on calls to close
- Ling.l_onoff := 0;
- Ling.l_linger := 0;
- if setsockopt(Socket, SOL_SOCKET, SO_LINGER, @Ling, SizeOf(Ling)) = SOCKET_ERROR then begin
- ErrnoCopy := WSAGetLastError;
- LogDelegate(Format('TServerSocket.Listen() setsockopt() SO_LINGER %s', [SysErrorMessage(ErrnoCopy)]));
- raise TTransportExceptionNotOpen.Create(Format('Could not set SO_LINGER: %s', [SysErrorMessage(ErrnoCopy)]));
- end;
- // TCP Nodelay, speed over bandwidth
- if setsockopt(Socket, IPPROTO_TCP, TCP_NODELAY, @One, SizeOf(One)) = SOCKET_ERROR then begin
- ErrnoCopy := WSAGetLastError;
- LogDelegate(Format('TServerSocket.Listen() setsockopt() TCP_NODELAY %s', [SysErrorMessage(ErrnoCopy)]));
- raise TTransportExceptionNotOpen.Create(Format('Could not set TCP_NODELAY: %s', [SysErrorMessage(ErrnoCopy)]));
- end;
- // Set NONBLOCK on the accept socket
- if ioctlsocket(Socket, Integer(FIONBIO), One) = SOCKET_ERROR then begin
- ErrnoCopy := WSAGetLastError;
- LogDelegate(Format('TServerSocket.Listen() ioctlsocket() FIONBIO %s', [SysErrorMessage(ErrnoCopy)]));
- raise TTransportExceptionNotOpen.Create(Format('ioctlsocket() FIONBIO: %s', [SysErrorMessage(ErrnoCopy)]));
- end;
- // prepare the port information
- // we may want to try to bind more than once, since THRIFT_NO_SOCKET_CACHING doesn't
- // always seem to work. The client can configure the retry variables.
- Retries := 0;
- while True do begin
- if bind(Socket, AddrInfo.Res^.ai_addr^, AddrInfo.Res^.ai_addrlen) = 0 then
- Break;
- Inc(Retries);
- if Retries > FRetryLimit then
- Break;
- Sleep(FRetryDelay * 1000);
- end;
- // retrieve bind info
- if (Port = 0) and (Retries < FRetryLimit) then begin
- Len := SizeOf(SA);
- FillChar(SA, Len, 0);
- if getsockname(Socket, PSockAddr(@SA)^, Len) = SOCKET_ERROR then
- LogDelegate(Format('TServerSocket.Listen() getsockname() %s', [SysErrorMessage(WSAGetLastError)]))
- else begin
- if SA.ss_family = AF_INET6 then
- Port := ntohs(PSockAddrIn6(@SA)^.sin6_port)
- else
- Port := ntohs(PSockAddrIn(@SA)^.sin_port);
- end;
- end;
- // throw an error if we failed to bind properly
- if (Retries > FRetryLimit) then begin
- LogDelegate(Format('TServerSocket.Listen() BIND %d', [Port]));
- Close;
- raise TTransportExceptionNotOpen.Create(Format('Could not bind: %s', [SysErrorMessage(WSAGetLastError)]));
- end;
- if Assigned(FListenCallback) then
- FListenCallback(Socket);
- // Call listen
- if Winapi.Winsock2.listen(Socket, FAcceptBacklog) = SOCKET_ERROR then begin
- ErrnoCopy := WSAGetLastError;
- LogDelegate(Format('TServerSocket.Listen() listen() %s', [SysErrorMessage(ErrnoCopy)]));
- raise TTransportExceptionNotOpen.Create(Format('Could not listen: %s', [SysErrorMessage(ErrnoCopy)]));
- end;
- // The socket is now listening!
- end;
- function TServerSocket.Accept: TSocket;
- var
- Fds: TFdSet;
- MaxEInters,
- NumEInters: Integer;
- TVal: TTimeVal;
- PTVal: PTimeVal;
- ErrnoCopy: Integer;
- Buf: Byte;
- ClientAddress: TSockAddrStorage;
- Size: Integer;
- ClientSocket: Winapi.Winsock2.TSocket;
- Zero: Cardinal;
- Client: TSocket;
- Ret: Integer;
- begin
- MaxEInters := 5;
- NumEInters := 0;
- while True do begin
- FD_ZERO(Fds);
- _FD_SET(Socket, Fds);
- _FD_SET(FInterruptSockReader, Fds);
- if FAcceptTimeout > 0 then begin
- TVal.tv_sec := FAcceptTimeout div 1000;
- TVal.tv_usec := (FAcceptTimeout mod 1000) * 1000;
- PTVal := @TVal;
- end
- else
- PTVal := nil;
- // TODO: if WSAEINTR is received, we'll restart the timeout.
- // To be accurate, we need to fix this in the future.
- Ret := select(2, @Fds, nil, nil, PTVal);
- if Ret < 0 then begin
- // error cases
- if (WSAGetLastError = WSAEINTR) and (NumEInters < MaxEInters) then begin
- // THRIFT_EINTR needs to be handled manually and we can tolerate
- // a certain number
- Inc(NumEInters);
- Continue;
- end;
- ErrnoCopy := WSAGetLastError;
- LogDelegate(Format('TServerSocket.Accept() select() %s', [SysErrorMessage(ErrnoCopy)]));
- raise TTransportExceptionUnknown.Create(Format('Unknown: %s', [SysErrorMessage(ErrnoCopy)]));
- end
- else if Ret > 0 then begin
- // Check for an interrupt signal
- if (FInterruptSockReader <> INVALID_SOCKET) and FD_ISSET(FInterruptSockReader, Fds) then begin
- if recv(FInterruptSockReader, Buf, SizeOf(Buf), 0) = SOCKET_ERROR then
- LogDelegate(Format('TServerSocket.Accept() recv() interrupt %s', [SysErrorMessage(WSAGetLastError)]));
- raise TTransportExceptionInterrupted.Create('in…
Large files files are truncated, but you can click here to view the full file