sockutils.pas

delphi完成端口Socks例子,纯Delphi做的

unit SockUtils;

interface

uses Windows, WinSock2, Lists, Streams, SyncObjects, SysUtils;

type
  PSiteInfo = ^TSiteInfo;
  TSiteInfo = record
    Key: Cardinal;
    HostName: array[0..127] of Char;
    Address: array[0..15] of Char;
    AsServer, AsClient: TSocket;
    Data: TObject;
  end;

  TSiteEvent = (seConnected, seDisconnected);

  TLogProc = procedure(const Msg: string);

  PServerInfo = ^TServerInfo;
  TServerInfo = record
    ListenSocket: TSocket;
    CompletionPort: THandle;
    WorkerThreads: Integer;
    Waiter: THandle;
  end;

  TCustomService = class
  protected
    function GetPort: Integer; virtual; abstract;
  public
    procedure ClientChange(Site: PSiteInfo; Event: TSiteEvent); virtual; abstract;
    procedure ServerChange(Site: PSiteInfo; Event: TSiteEvent); virtual; abstract;
    procedure ProcessRequest(Site: PSiteInfo; Data: Pointer; Size: Integer); virtual; abstract;
    function ProcessReply(Site: PSiteInfo; Data: Pointer; Size: Integer): Boolean; virtual; abstract;
    property Port: Integer read GetPort;
  end;

  TSiteInfos = class
  private
    FCriticalSection: TCriticalSection;
    FLastKey: Integer;
    FList, FServers, FClients: TList;
    function GetCount: Integer;
    function GetItem(Index: Integer): PSiteInfo;
    function CompareSiteKey(Item: Pointer; const Key): Integer;
    function CompareSiteClient(Item: Pointer; const Client): Integer;
    function CompareSiteServer(Item: Pointer; const Server): Integer;
    function Find(Key: Cardinal; var Index: Integer): Boolean;
    function FindClient(Socket: TSocket; var Index: Integer): Boolean; overload;
    function FindServer(Socket: TSocket; var Index: Integer): Boolean; overload;
    procedure ConnectAsClient(Site: PSiteInfo);
    procedure DisconnectAsClient(Site: PSiteInfo);
    procedure ConnectAsServer(Site: PSiteInfo);
    procedure DisconnectAsServer(Site: PSiteInfo);
  public
    constructor Create;
    destructor Destroy; override;
    function AddSite(const AName, AAddress: string): PSiteInfo; overload;
    procedure RemoveSite(ASite: PSiteInfo); overload;
    procedure DeleteSite(Index: Integer);
    function FindSite(Key: Integer): PSiteInfo; overload;
    function FindSite(const AName: string): PSiteInfo; overload;
    function FindSite(const AName, AAddress: string): PSiteInfo; overload;
    function FindClient(Socket: TSocket): PSiteInfo; overload;
    function FindServer(Socket: TSocket): PSiteInfo; overload;
    procedure InsertSite(const SiteName: string);
    procedure RemoveSite(const SiteName: string); overload;
    property Count: Integer read GetCount;
    property Items[index: Integer]: PSiteInfo read GetItem; default;
  end;

  TJet = class
  private
    FSites: TSiteInfos;
    function GetEvent: THandle;
  public
    constructor Create;
    destructor Destroy; override;
    function WaitFor: Boolean;
    procedure Rollup;
    procedure Send(Site: PSiteInfo; Data: Pointer; Size: Integer);
    procedure Reply(Site: PSiteInfo; Data: Pointer; Size: Integer);
    property Event: THandle read GetEvent;
    property Sites: TSiteInfos read FSites;
  end;

procedure LogWindowsError(const Msg: string); overload;
procedure LogMessage(const Msg: string); overload;
function StartThread(ThreadFunc: TThreadFunc; Param: Pointer): Boolean;
function InitializeWinSock2(ALogProc: TLogProc): TJet;
procedure FinalizeWinSock2;
function StartSockServer(AService: TCustomService; var Server: PServerInfo): Boolean;
procedure StopSockServer(var ServerInfo: PServerInfo);

implementation

type
  PPerHandleIOData = ^TPerHandleIOData;
  TPerHandleIOData = record
    Overlapped: TOverlapped;
    WSABuffer: WSABUF;
    Key: Cardinal;
  end;

  TAsyncAction = class
  private
    FCriticalSection: TCriticalSection;
    FID: Integer;
    function GetClientState: Boolean;
    function GetServerState: Boolean;
  protected
    FSite: PSiteInfo;
    FIOData: PPerHandleIOData;
    procedure Enter;
    procedure Leave;
    procedure DoAbandon; virtual;
    function DoExecute: Boolean; virtual; abstract;
    procedure DoComplete(Bytes: Integer); virtual; abstract;
  public
    constructor Create(Site: PSiteInfo); virtual;
    destructor Destroy; override;
    procedure SetBuffer(Buf: Pointer; Size: Integer); virtual;
    function Execute: Boolean;
    procedure Complete(Bytes: Integer);
    procedure Abandon;
    procedure Queueing; overload;
    procedure Queueing(Milliseconds: Integer); overload;
    property ID: Integer read FID;
    property ConnectedAsClient: Boolean read GetClientState;
    property ConnectedAsServer: Boolean read GetServerState;
  end;

  TAsyncActionClass = class of TAsyncAction;

  PActionEntry = ^TActionEntry;
  TActionEntry = record
    Action: TAsyncAction;
    Next: PActionEntry;
  end;

  TAsyncActionQueue = class
  private
    FCriticalSection: TCriticalSection;
    FEvent: THandle;
    FHead, FTail: PActionEntry;
    FEmpty: Boolean;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Queue(Action: TAsyncAction);
    function Dequeue(var Action: TAsyncAction): Boolean;
  end;

  TQWord = record
    Lo, Hi: DWORD;
  end;

  PActionDelayEntry = ^TActionDelayEntry;
  TActionDelayEntry = record
    Action: TAsyncAction;
    Delay: TQWord;
  end;

  TAsyncActionDelayQueue = class
  private
    FCriticalSection: TCriticalSection;
    FTimer: THandle;
    FList: TList;
    FTickCount: Cardinal;
    FRound: Integer;
    function GetCurrentTicks: Cardinal;
    procedure SetTimer(Milliseconds: Integer);
    function Compare(Item: Pointer; const Key): Integer;
    procedure Fire;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Queue(Action: TAsyncAction; Milliseconds: Integer); overload;
    procedure Dequeue;
  end;

  TAsyncActions = class
  private
    FCriticalSection: TCriticalSection;
    FPrimaryQueue: TAsyncActionQueue;
    FSecondaryQueue: TAsyncActionDelayQueue;
    FList, FPool: TList;
    FLastID: Integer;
    function CompareActionID(Item: Pointer; const ID): Integer;
    function CompareActionClass(Item: Pointer; const ActionClass): Integer;
    function Find(ID: Integer; var Index: Integer): Boolean; overload;
    function Find(const ActionClass: string; var Index: Integer): Boolean; overload;
  public
    constructor Create;
    destructor Destroy; override;
    function GetAction(ActionClass: TAsyncActionClass;
      Site: PSiteInfo): TAsyncAction; overload;
    function GetAction(ActionClass: TAsyncActionClass;
      Site: PSiteInfo; Buf: Pointer; Size: Integer): TAsyncAction; overload;
    function Find(ID: Integer): TAsyncAction; overload;
    procedure Abandon(ID: Integer);
    procedure Queue(Action: TAsyncAction);
    procedure QueueDelay(Action: TAsyncAction; Milliseconds: Integer);
    function Dequeue: TAsyncAction;
    procedure Requeue;
  end;
  
  TAcceptAction = class(TAsyncAction)
  private
    FBuffer: Pointer;
  protected
    function DoExecute: Boolean; override;
    procedure DoComplete(Bytes: Integer); override;
  public
    constructor Create(Site: PSiteInfo); override;
    destructor Destroy; override;
  end;

  TReplyAction = class(TAsyncAction)
  private
    FBuffer: Pointer;
    FSize, FCapacity, FSent: Integer;
  protected
    procedure DoAbandon; override;
    function DoExecute: Boolean; override;
    procedure DoComplete(Bytes: Integer); override;
  public
    constructor Create(Site: PSiteInfo); override;
    destructor Destroy; override;
    procedure SetBuffer(Buf: Pointer; Size: Integer); override;
  end;

  TSendAction = class(TAsyncAction)
  private
    FBuffer: Pointer;
    FSize, FCapacity, FSent, FAttempt: Integer;
  protected
    procedure DoAbandon; override;
    function DoExecute: Boolean; override;
    procedure DoComplete(Bytes: Integer); override;
  public
    constructor Create(Site: PSiteInfo); override;
    destructor Destroy; override;
    procedure SetBuffer(Buf: Pointer; Size: Integer); override;
  end;

  TWaitAction = class(TAsyncAction)
  private
    FBuffer: Pointer;
    FReceived, FCapacity: Integer;
  protected
    procedure DoAbandon; override;
    function DoExecute: Boolean; override;
    procedure DoComplete(Bytes: Integer); override;
  public
    constructor Create(Site: PSiteInfo); override;
    destructor Destroy; override;
  end;

  TCloseAction = class(TAsyncAction)
  private
    FBuffer: Pointer;
  protected
    function DoExecute: Boolean; override;
    procedure DoComplete(Bytes: Integer); override;
  public
    constructor Create(Site: PSiteInfo); override;
    destructor Destroy; override;
  end;

const
  BUFFER_SIZE = 8192;

var
  HasWinSock2: Boolean;
  LocalHostName, LocalAddress: string;
  Jet: TJet;
  Actions: TAsyncActions;
  Service: TCustomService;

var
  LogProc: TLogProc = nil;

function GetWindowsErrorMessage(ErrCode: Integer): string; overload;
var
  Buf: array[0..1023] of char;
  Len: Integer;
begin
  Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, ErrCode, 0, Buf, 1024, nil);
  SetString(Result, Buf, Len);
end;

function GetErrorMessage(ErrCode: Integer): string; overload;
begin
  Result := Format('Windows Error[%d]: %s', [ErrCode, GetWindowsErrorMessage(ErrCode)]);
end;

function GetErrorMessage: string; overload;
begin
  Result := GetErrorMessage(GetLastError);
end;

procedure LogMessage(const Msg: string); overload;
begin
  if Assigned(LogProc) then
    LogProc(Msg);
end;

procedure LogMessage(const Msg: string; const Args: array of const); overload;
begin
  LogMessage(Format(Msg, Args));
end;

procedure LogError(const Msg: string);
begin
  LogMessage('[ERROR]: %s', [Msg]);
end;

procedure LogWindowsError(const Msg: string; ErrCode: Integer); overload;
begin
  LogError(Format('Windows Error on [%s]: %s', [Msg, GetErrorMessage(ErrCode)]));
end;

procedure LogWindowsError(const Msg: string); overload;
begin
  LogWindowsError(Msg, GetLastError);
end;

function LogWinSockError(const Msg: string; ErrCode: Integer): Boolean; overload;
begin
  if (ErrCode <> ERROR_IO_PENDING) and (ErrCode <> 0) then
  begin
    Result := True;
    LogError(Format('WinSock Error[%d] on [%s]: %s', [ErrCode, Msg,
      GetErrorMessage(ErrCode)]));
  end
  else
    Result := False;
end;

function LogWinSockError(const Msg: string): Boolean; overload;
begin
  Result := LogWinSockError(Msg, WSAGetLastError);
end;

function LogWinSockError(Site: PSiteInfo; const Msg: string; ErrCode: Integer): Boolean; overload;
begin
  if Site = nil then
    Result := LogWinSockError(Msg, ErrCode)
  else if (ErrCode <> ERROR_IO_PENDING) and (ErrCode <> 0) then
  begin
    Result := True;
    LogError(Format('WinSock Error[%d] on [%s] to [%s - %s]: %s', [ErrCode,
      Msg, Site^.HostName, Site^.Address, GetErrorMessage(ErrCode)]));
  end
  else
    Result := False;
end;

function LogWinSockError(Site: PSiteInfo; const Msg: string): Boolean; overload;
begin
  Result := LogWinSockError(Site, Msg, WSAGetLastError);
end;

function StartThread(ThreadFunc: TThreadFunc; Param: Pointer): Boolean;
var
  Handle, Id: THandle;
begin
  Handle := BeginThread(nil, 0, ThreadFunc, Param, 0, Id);
  Result := Handle <> 0;
  if Result then
    CloseHandle(Handle)
  else
    LogWindowsError('CreateThread');
end;

function FillLocalHostInfo: Boolean; forward;
procedure EnumSites(Sites: TSiteInfos); forward;

function InitializeWinSock2(ALogProc: TLogProc): TJet;
var
  WSData: TWSAData;
begin
  LogProc := ALogProc;
  HasWinSock2 := WSAStartup(MAKEWORD(2, 0), WSData) = 0;
  if HasWinSock2 then
//    if (Lo(WSData.wVersion) <> 2) or (Hi(WSData.wVersion) <> 0) then
    if not FillLocalHostInfo then
    begin
      HasWinSock2 := False;
      WSACleanup;
    end;
  if HasWinSock2 then
  begin
    Jet := TJet.Create;
    EnumSites(Jet.Sites);
    Actions := TAsyncActions.Create;
    Result := Jet;
  end
  else
    Result := nil;
end;

procedure FinalizeWinSock2;
begin
  if HasWinSock2 then
  begin
    Actions.Free;
    Jet.Free;
    HasWinSock2 := False;
    WSACleanup;
  end;
end;

function FillLocalHostInfo: Boolean;
var
  P1: array[0..127] of Char;
  P2: PChar;
  HostEnt: PHostEnt;
  inAddr: TInAddr;
begin
  if gethostname(P1, 128) = SOCKET_ERROR then
    LogWinSockError('gethostname')
  else
  begin
    HostEnt := gethostbyname(P1);
    if HostEnt = nil then
      LogWinSockError('gethostbyname')
    else
    begin
      with inAddr, HostEnt^ do
      begin
        S_un_b.s_b1 := Ord(h_addr^[0]);
        S_un_b.s_b2 := Ord(h_addr^[1]);
        S_un_b.s_b3 := Ord(h_addr^[2]);
        S_un_b.s_b4 := Ord(h_addr^[3]);
      end;
      P2 := inet_ntoa(inAddr);
      if P2 = nil then
        LogWinSockError('inet_ntoa')
      else
      begin
        SetString(LocalHostName, HostEnt.h_name, StrLen(HostEnt.h_name));
        SetString(LocalAddress, P2, StrLen(P2));
        Result := True;
        Exit;
      end;
    end;
  end;
  Result := False;
end;

function GetSiteAddress(const AHostName: string; var Address: string): Boolean;
var
  HostEnt: PHostEnt;
  inAddr: TInAddr;
  Addr: PChar;
begin
  HostEnt := gethostbyname(PChar(AHostName));
  if HostEnt = nil then
    LogWinSockError('gethostbyname')
  else
  begin
    with inAddr, HostEnt^ do
    begin
      S_un_b.s_b1 := Ord(h_addr^[0]);
      S_un_b.s_b2 := Ord(h_addr^[1]);
      S_un_b.s_b3 := Ord(h_addr^[2]);
      S_un_b.s_b4 := Ord(h_addr^[3]);
    end;
    Addr := inet_ntoa(inAddr);
    if Addr = nil then
      LogWinSockError('inet_ntoa')
    else
    begin
      SetString(Address, Addr, StrLen(Addr));
      Result := True;
      Exit;
    end;
  end;
  Result := False;
end;

function GetPeerSite(Addr: TSockAddr; var HostName, Address: string): Boolean; overload;
var
  PAddr: PChar;
  HostEnt: PHostEnt;
begin
  PAddr := inet_ntoa(Addr.sin_addr);
  if PAddr = nil then
    LogWinSockError('inet_ntoa')
  else
  begin
    HostEnt := gethostbyaddr(@Addr.sin_addr.s_addr, 4, PF_INET);
    if HostEnt = nil then
      LogWinSockError('gethostbyaddr')
    else
    begin
      SetString(HostName, HostEnt.h_name, StrLen(HostEnt.h_name));
      SetString(Address, PAddr, StrLen(PAddr));
      Result := True;