home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 November / Chip_2002-11_cd1.bin / zkuste / delphi / kompon / d3456 / ICQ.ZIP / ICQ / Component / MySocket.pas < prev   
Pascal/Delphi Source File  |  2002-08-16  |  30KB  |  1,011 lines
  1. unit MySocket;
  2. {(C) Alex Demchenko(alex@ritlabs.com)}
  3. {$DEFINE USE_FORMS} //If you don't use forms unit remove this line
  4. {$R-}
  5.  
  6. interface
  7. uses
  8.   Windows, Messages, WinSock, {$IFDEF USE_FORMS}Forms, {$ENDIF} Classes, ICQWorks;
  9.  
  10. function InitMySocket(var WSA: TWSAData): LongWord;
  11. procedure FinalMySocket;
  12.  
  13. type
  14.   {$IFNDEF USE_FORMS}
  15.   TWndMethod = procedure(var Message: TMessage) of object;
  16.   {$ENDIF}
  17.  
  18.   TOnRecv = procedure(Sender: TObject; Socket: TSocket; Buffer: Pointer; BufLen: LongWord) of object;
  19.   TOnPktParse = procedure(Sender: TObject; Buffer: Pointer; BufLen: LongWord) of object;
  20.   TOnPktParseAdv = procedure(Sender: TObject; Buffer: Pointer; BufLen: LongWord; Incoming: Boolean) of object;
  21.   TOnAdvPktParse = procedure(Sender: TObject; Buffer: Pointer; BufLen: LongWord; Incoming: Boolean) of object;
  22.   TOnResolve = procedure(Sender: TObject; Addr: String) of object;
  23.   TOnError = procedure(Sender: TObject; ErrorType: TErrorType; ErrorMsg: String) of object;
  24.  
  25.   TClSock = class(TObject)
  26.   private
  27.     FIp: String;
  28.     FDestPort: LongWord;
  29.     FClSock: TSocket;
  30.     FWndHandle: THandle;
  31.     FOnRecv: TOnRecv;
  32.     FOnDisconnect: TNotifyEvent;
  33.     FOnConnect: TNotifyEvent;
  34.     FOnConnectError: TNotifyEvent;
  35.     FOnPktParse: TOnPktParse;
  36.     FHostIp: array[0..MAXGETHOSTSTRUCT - 1] of Char;
  37.     FResolve: Boolean;
  38.     FOnResolve: TOnResolve;
  39.     FOnFailed: TNotifyEvent;
  40.     FOnError: TOnError;
  41.     function ResolveAddr(Value: Pointer): LongInt;
  42.     function TestResolve(IP: String): Boolean;
  43.     procedure InitConnect(dwIP: LongWord);
  44.     procedure OnSockMsg(var Msg: TMessage);
  45.     function IsConnected: Boolean;
  46.   public
  47.     constructor Create;
  48.     destructor Destroy; override;
  49.     procedure Connect; //Connect to remote host
  50.     procedure Resolve; //Just resolve remote host w/o connecting
  51.     procedure Disconnect;
  52.     procedure SendData(var Buf; BufLen: LongWord);
  53.     property IP: String read FIp write FIp;
  54.     property DestPort: LongWord read FDestPort write FDestPort;
  55.     property Connected: Boolean read IsConnected;
  56.   published
  57.     property OnRecieve: TOnRecv read FOnRecv write FOnRecv;
  58.     property OnDisconnect: TNotifyEvent read FOnDisconnect write FOnDisconnect;
  59.     property OnConnect: TNotifyEvent read FOnConnect write FOnConnect;
  60.     property OnConnectError: TNotifyEvent read FOnConnectError write FOnConnectError;
  61.     property OnPktParse: TOnPktParse read FOnPktParse write FOnPktParse;
  62.     property OnResolve: TOnResolve read FOnResolve write FOnResolve;
  63.     property OnResolveFailed: TNotifyEvent read FOnFailed write FOnFailed;
  64.     property OnError: TOnError read FOnError write FOnError;
  65.   end;
  66.  
  67.   TProxySock = class(TObject)
  68.   private
  69.     FSrcBuf: array[0..MAX_DATA_LEN - 1] of Byte;
  70.     FSrcLen: Word;
  71.     FSock: TClSock;
  72.     FProxyType: TProxyType;
  73.     FProxyHost: String;
  74.     FProxyPort: Word;
  75.     FProxyAuth: Boolean;
  76.     FProxyPass: String;
  77.     FUserID: String;
  78.     FHost: String;
  79.     FPort: Word;
  80.     FResolve: Boolean;
  81.     FSocks: Word;
  82.     FOnConnectError: TNotifyEvent;
  83.     FOnDisconnect: TNotifyEvent;
  84.     FOnPktParse: TOnAdvPktParse;
  85.     FOnError: TOnError;
  86.     FOnRecv: TOnRecv;
  87.     FOnConnectProc: TNotifyEvent;
  88.   private
  89.     procedure OnSockResolve(Sender: TObject; Addr: String);
  90.     procedure OnSockResolveFailed(Sender: TObject);
  91.     procedure OnSockConnect(Sender: TObject);
  92.     procedure OnSockRecv(Sender: TObject; Socket: TSocket; Buffer: Pointer; BufLen: LongWord);
  93.     procedure OnSockConnectError(Sender: TObject);
  94.     procedure OnSockDisconnect(Sender: TObject);
  95.     procedure OnSockError(Sender: TObject; ErrorType: TErrorType; ErrorMsg: String);
  96.     procedure OnPktParse(Sender: TObject; Buffer: Pointer; BufLen: LongWord);
  97.   protected
  98.     procedure OnReceive(Buffer: Pointer; BufLen: LongWord); dynamic;
  99.   public
  100.     constructor Create;
  101.     destructor Destroy; override;
  102.     procedure Connect; dynamic;
  103.     procedure Disconnect;
  104.     procedure SendData(var Buf; BufLen: LongWord);
  105.     property Host: String read FHost write FHost;
  106.     property Port: Word read FPort write FPort;
  107.     property ProxyType: TProxyType read FProxyType write FProxyType;
  108.     property ProxyHost: String read FProxyHost write FProxyHost;
  109.     property ProxyPort: Word read FProxyPort write FProxyPort;
  110.     property ProxyUserID: String read FUserID write FUserID;
  111.     property ProxyAuth: Boolean read FProxyAuth write FProxyAuth;
  112.     property ProxyPass: String read FProxyPass write FProxyPass;
  113.     property UseProxyResolve: Boolean read FResolve write FResolve default False;
  114.   published
  115.     property OnConnectError: TNotifyEvent read FOnConnectError write FOnConnectError;
  116.     property OnDisconnect: TNotifyEvent read FOnDisconnect write FOnDisconnect;
  117.     property OnPktParseA: TOnAdvPktParse read FOnPktParse write FOnPktParse;
  118.     property OnError: TOnError read FOnError write FOnError;
  119.     property OnReceiveProc: TOnRecv read FOnRecv write FOnRecv;
  120.     property OnConnectProc: TNotifyEvent read FOnConnectProc write FOnConnectProc;
  121.   end;
  122.  
  123.   TMySock = class(TProxySock)
  124.   private
  125.     function GetClientSocket: TSocket;
  126.     procedure SetClientSocket(Socket: TSocket);
  127.     function IsConnected: Boolean;
  128.   public
  129.     property ClientSocket: TSocket read GetClientSocket write SetClientSocket;
  130.     property Connected: Boolean read IsConnected;
  131.   end;
  132.  
  133.   TOnClientConnected = procedure(Sender: TObject; Socket: TMySock) of object;
  134.  
  135.   TSrvSock = class(TObject)
  136.   private
  137.     FWndHandle: THandle;
  138.     FSrvSock: TSocket;
  139.     FOnClientConnected: TOnClientConnected;
  140.     procedure OnSockMsg(var Msg: TMessage);
  141.   public
  142.     constructor Create;
  143.     destructor Destroy; override;
  144.     function StartServer(Port: Word): Boolean;
  145.     function StopServer: Boolean;
  146.   published
  147.     property OnClientConnected: TOnClientConnected read FOnClientConnected write FOnClientConnected;
  148.   end;
  149.  
  150.  
  151. function GetLocalIP: LongInt;
  152. function FindBindPort: Word;
  153.  
  154. implementation
  155. const
  156.   WSA_ACCEPT   = WM_USER + $10;
  157.   WSA_NETEVENT = WM_USER + $20;
  158.   WSA_RESOLVE_COMPLETE = WM_USER + $30;
  159.  
  160. function InitMySocket(var WSA: TWSAData): LongWord;
  161. begin
  162.   Result := WSAStartup(MAKEWORD(1, 1), WSA);
  163. end;
  164.  
  165. procedure FinalMySocket;
  166. begin
  167.   WSACleanUp;
  168. end;
  169.  
  170. //////////////////////////////////////////////////////////////////////////////////////////////////////////
  171. {$IFNDEF USE_FORMS}
  172. type
  173.   PObjectInstance = ^TObjectInstance;
  174.   TObjectInstance = packed record
  175.     Code: Byte;
  176.     Offset: Integer;
  177.     case Integer of
  178.       0: (Next: PObjectInstance);
  179.       1: (Method: TWndMethod);
  180.   end;
  181.  
  182.   PInstanceBlock = ^TInstanceBlock;
  183.   TInstanceBlock = packed record
  184.     Next: PInstanceBlock;
  185.     Code: array[1..2] of Byte;
  186.     WndProcPtr: Pointer;
  187.     Instances: array[0..100] of TObjectInstance;
  188.   end;
  189.  
  190. var
  191.   InstBlockList: PInstanceBlock;
  192.   InstFreeList: PObjectInstance;
  193.  
  194. { Standard window procedure }
  195. { In    ECX = Address of method pointer }
  196. { Out   EAX = Result }
  197.  
  198. function StdWndProc(Window: HWND; Message, WParam: Longint;
  199.   LParam: Longint): Longint; stdcall; assembler;
  200. asm
  201.           XOR     EAX,EAX
  202.           PUSH    EAX
  203.           PUSH    LParam
  204.           PUSH    WParam
  205.           PUSH    Message
  206.           MOV     EDX,ESP
  207.           MOV     EAX,[ECX].Longint[4]
  208.           CALL    [ECX].Pointer
  209.           ADD     ESP,12
  210.           POP     EAX
  211. end;
  212.  
  213. { Allocate an object instance }
  214. function CalcJmpOffset(Src, Dest: Pointer): Longint;
  215. begin
  216.   Result := Longint(Dest) - (Longint(Src) + 5);
  217. end;
  218.  
  219. function MakeObjectInstance(Method: TWndMethod): Pointer;
  220. const
  221.   BlockCode: array[1..2] of Byte = (
  222.     $59,       { POP ECX }
  223.     $E9);      { JMP StdWndProc }
  224.   PageSize = 4096;
  225. var
  226.   Block: PInstanceBlock;
  227.   Instance: PObjectInstance;
  228. begin
  229.   if InstFreeList = nil then
  230.   begin
  231.     Block := VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
  232.     Block^.Next := InstBlockList;
  233.     Move(BlockCode, Block^.Code, SizeOf(BlockCode));
  234.     Block^.WndProcPtr := Pointer(CalcJmpOffset(@Block^.Code[2], @StdWndProc));
  235.     Instance := @Block^.Instances;
  236.     repeat
  237.       Instance^.Code := $E8;  { CALL NEAR PTR Offset }
  238.       Instance^.Offset := CalcJmpOffset(Instance, @Block^.Code);
  239.       Instance^.Next := InstFreeList;
  240.       InstFreeList := Instance;
  241.       Inc(Longint(Instance), SizeOf(TObjectInstance));
  242.     until Longint(Instance) - Longint(Block) >= SizeOf(TInstanceBlock);
  243.     InstBlockList := Block;
  244.   end;
  245.   Result := InstFreeList;
  246.   Instance := InstFreeList;
  247.   InstFreeList := Instance^.Next;
  248.   Instance^.Method := Method;
  249. end;
  250.  
  251. { Free an object instance }
  252. procedure FreeObjectInstance(ObjectInstance: Pointer);
  253. begin
  254.   if ObjectInstance <> nil then
  255.   begin
  256.     PObjectInstance(ObjectInstance)^.Next := InstFreeList;
  257.     InstFreeList := ObjectInstance;
  258.   end;
  259. end;
  260.  
  261. var
  262.   UtilWindowClass: TWndClass = (
  263.   style: 0;
  264.   lpfnWndProc: @DefWindowProc;
  265.   cbClsExtra: 0;
  266.   cbWndExtra: 0;
  267.   hInstance: 0;
  268.   hIcon: 0;
  269.   hCursor: 0;
  270.   hbrBackground: 0;
  271.   lpszMenuName: nil;
  272.   lpszClassName: 'TPUtilWindow');
  273.  
  274. function AllocateHWnd(Method: TWndMethod): THandle;
  275. var
  276.   TempClass: TWndClass;
  277.   ClassRegistered: Boolean;
  278. begin
  279.   UtilWindowClass.hInstance := HInstance;
  280.   ClassRegistered := GetClassInfo(HInstance, UtilWindowClass.lpszClassName,
  281.     TempClass);
  282.   if not ClassRegistered or (TempClass.lpfnWndProc <> @DefWindowProc) then
  283.   begin
  284.     if ClassRegistered then
  285.       Windows.UnregisterClass(UtilWindowClass.lpszClassName, HInstance);
  286.     Windows.RegisterClass(UtilWindowClass);
  287.   end;
  288.   Result := CreateWindow(UtilWindowClass.lpszClassName,
  289.     '', WS_POPUP, 0, 0, 0, 0, 0, 0, HInstance, nil);
  290.   if Assigned(Method) then
  291.     SetWindowLong(Result, GWL_WNDPROC, Longint(MakeObjectInstance(Method)));
  292. end;
  293.  
  294. procedure DeallocateHWnd(Wnd: THandle);
  295. var
  296.   Instance: Pointer;
  297. begin
  298.   Instance := Pointer(GetWindowLong(Wnd, GWL_WNDPROC));
  299.   DestroyWindow(Wnd);
  300.   if Instance <> @DefWindowProc then FreeObjectInstance(Instance);
  301. end;
  302. {$ENDIF}
  303. /////////////////////////////////////////////////////////////////////////////////////////////////////////
  304.  
  305. constructor TClSock.Create;
  306. begin
  307.   inherited;
  308.   FWndHandle := AllocateHwnd(OnSockMsg);
  309.   FClSock := INVALID_SOCKET;
  310.   FResolve := False;
  311. end;
  312.  
  313. destructor TClSock.Destroy;
  314. begin
  315.   closesocket(FClSock);
  316.   DeallocateHwnd(FWndHandle);
  317.   inherited;
  318. end;
  319.  
  320. function TClSock.ResolveAddr(Value: Pointer): LongInt;
  321. var
  322.   addr: in_addr;
  323.   hostent: PHostEnt;
  324. begin
  325.   Result := -1;
  326.   hostent := Value;
  327.   if hostent^.h_addr_list <> nil then
  328.   begin
  329.     addr.S_addr := PLongInt(hostent^.h_addr_list^)^;
  330.     Result := addr.S_addr;
  331.   end else
  332.     Exit;
  333. end;
  334.  
  335. function TClSock.TestResolve(IP: String): Boolean;
  336. begin
  337.   Result := inet_addr(PChar(IP)) <> LongInt(INADDR_NONE);
  338. end;
  339.  
  340. procedure TClSock.InitConnect(dwIP: LongWord);
  341. var
  342.   dest_sin: TSockAddr;
  343. begin
  344.   FClSock := socket(AF_INET, SOCK_STREAM, 0);
  345.   WSAAsyncSelect(FClSock, FWndHandle, WSA_NETEVENT, FD_CONNECT or FD_CLOSE or FD_READ);
  346.  
  347.   dest_sin.sin_family := AF_INET;
  348.   dest_sin.sin_addr.s_addr := dwIP;
  349.   dest_sin.sin_port := htons(FDestPort);
  350.  
  351.   if (WinSock.connect(FClSock, dest_sin, SizeOf(TSockAddr)) = SOCKET_ERROR) and (WSAGetLastError <> WSAEWOULDBLOCK) then
  352.   begin
  353.     if Assigned(OnError) then
  354.       FOnError(Self, ERR_SOCKET, 'connect() returned SOCKET_ERROR');
  355.     if Assigned(OnConnectError) then
  356.       FOnConnectError(Self);
  357.     Disconnect;
  358.     Exit;
  359.   end;
  360. end;
  361.  
  362. procedure TClSock.OnSockMsg(var Msg: TMessage);
  363. var
  364.   rc: Integer;
  365.   buf: array[0..1023] of Byte;
  366.   inaddr: in_addr;
  367. begin
  368.   case Msg.Msg of
  369.     WSA_RESOLVE_COMPLETE:
  370.     begin
  371.       if FResolve then
  372.       begin
  373.         if Assigned(OnResolve) then
  374.         begin
  375.           if HIWORD(Msg.wParam) <> 0 then
  376.           begin
  377.            if Assigned(OnError) then
  378.               FOnError(Self, ERR_SOCKET, 'Cannot resolve host');
  379.             if Assigned(OnResolveFailed) then
  380.               FOnFailed(Self);
  381.             Exit;
  382.           end;
  383.           inaddr.S_addr := ResolveAddr(@FHostIP);
  384.           if Assigned(OnResolve) then
  385.             FOnResolve(Self, inet_ntoa(inaddr));
  386.           Exit;
  387.         end;
  388.       end;
  389.       if HIWORD(Msg.wParam) <> 0 then
  390.       begin
  391.         if Assigned(OnError) then
  392.           FOnError(Self, ERR_SOCKET, 'Cannot resolve host');
  393.         if Assigned(OnConnectError) then
  394.           FOnConnectError(Self);
  395.         Disconnect;
  396.         Exit;
  397.       end;
  398.       InitConnect(ResolveAddr(@FHostIP));
  399.     end;
  400.     WSA_NETEVENT:
  401.     begin
  402.       if WSAGetSelectEvent(Msg.lParam) = FD_READ then
  403.       begin
  404.         rc := recv(Msg.wParam, buf, SizeOf(buf) - 1, 0);
  405.         if rc <> SOCKET_ERROR then
  406.         begin
  407.           if Assigned(OnRecieve) then
  408.             FOnRecv(Self, Msg.wParam, @buf, rc);
  409.         end else
  410.         begin
  411.           if Assigned(OnError) then
  412.             FOnError(Self, ERR_SOCKET, 'Received some data, but recv() returned 0');
  413.           Disconnect;
  414.         end;
  415.         Exit;
  416.       end
  417.       //Connection with server was lost
  418.       else if WSAGetSelectEvent(Msg.lParam) = FD_CLOSE then
  419.         Disconnect
  420.       else if WSAGetSelectEvent(Msg.lParam) = FD_CONNECT then
  421.       begin
  422.         if HIWORD(Msg.lParam) = 0 then
  423.         begin
  424.           if Assigned(OnConnect) then
  425.             FOnConnect(Self);
  426.         end else
  427.         begin
  428.           if Assigned(OnError) then
  429.             FOnError(Self, ERR_SOCKET, 'Cannot connect: no rote to host.');
  430.           if Assigned(OnConnectError) then
  431.             FOnConnectError(Self);
  432.           Disconnect;            
  433.           Exit;
  434.         end;
  435.       end;
  436.     end;
  437.   end;
  438. end;
  439.  
  440. function TClSock.IsConnected: Boolean;
  441. begin
  442.   Result := FClSock <> INVALID_SOCKET;
  443. end;
  444.  
  445. procedure TClSock.Connect;
  446. begin
  447.   FResolve := False;
  448.   if not TestResolve(FIp) then
  449.   begin
  450.     if WSAAsyncGetHostByName(FWndHandle, WSA_RESOLVE_COMPLETE, PChar(FIp), @FHostIp, SizeOf(FHostIp)) = 0 then
  451.     begin
  452.       if Assigned(OnError) then
  453.         FOnError(Self, ERR_SOCKET, 'Cannot init async. resolving');
  454.       if Assigned(OnConnectError) then
  455.         FOnConnectError(Self);
  456.       Disconnect;
  457.       Exit;
  458.     end;
  459.   end else
  460.   begin
  461.     InitConnect(inet_addr(PChar(FIp)));
  462.   end;
  463. end;
  464.  
  465. procedure TClSock.Resolve;
  466. begin
  467.   if not TestResolve(FIp) then
  468.   begin
  469.     FResolve := True;
  470.     if WSAAsyncGetHostByName(FWndHandle, WSA_RESOLVE_COMPLETE, PChar(FIp), @FHostIp, SizeOf(FHostIp)) = 0 then
  471.     begin
  472.       if Assigned(OnError) then
  473.         FOnError(Self, ERR_SOCKET, 'Cannot init async. resolving');
  474.       if Assigned(OnResolveFailed) then
  475.         FOnFailed(Self);
  476.     end;
  477.   end else
  478.   begin
  479.     FResolve := False;
  480.     if Assigned(OnResolve) then
  481.       FOnResolve(Self, FIp);
  482.   end;
  483. end;
  484.  
  485. procedure TClSock.Disconnect;
  486. begin
  487.   if FClSock <> INVALID_SOCKET then
  488.   begin
  489.     closesocket(FClSock);
  490.     FClSock := INVALID_SOCKET;
  491.     if Assigned(OnDisconnect) then
  492.       FOnDisconnect(Self);
  493.   end;
  494. end;
  495.  
  496. procedure TClSock.SendData(var Buf; BufLen: LongWord);
  497. var
  498.   ret: LongInt;
  499. begin
  500.   if FClSock <> INVALID_SOCKET then
  501.   begin
  502.     ret := send(FClSock, Buf, BufLen, 0);
  503.     if ret = SOCKET_ERROR then
  504.     begin
  505.       if Assigned(OnError) then
  506.         FOnError(Self, ERR_SOCKET, 'Could not send data');
  507.       Disconnect;
  508.       Exit;
  509.     end;
  510.     if Assigned(OnPktParse) then
  511.       FOnPktParse(Self, @Buf, BufLen);
  512.   end;
  513. end;
  514.  
  515. function GetLocalIP: LongInt;
  516. type
  517.   PaPInAddr = ^TaPInAddr;
  518.   TaPInAddr = array[0..$FFFE] of PInAddr;
  519. var
  520.   phe: PHostEnt;
  521.   pptr: PaPInAddr;
  522.   Buffer: array[0..63] of Char;
  523.   I: Integer;
  524. begin
  525.   Result := -1;
  526.   GetHostName(Buffer, SizeOf(Buffer));
  527.   phe := GetHostByName(buffer);
  528.   if phe = nil then Exit;
  529.   pptr := PaPInAddr(Phe^.h_addr_list);
  530.   I := 0;
  531.   while pptr^[I] <> nil do
  532.   begin
  533.     Result := pptr^[I]^.S_addr;
  534.     Inc(I);
  535.   end;
  536. end;
  537.  
  538. function FindBindPort: Word;
  539. var
  540.   i: Word;
  541.   srv_address: sockaddr_in;
  542.   sock: TSocket;
  543. begin
  544.   Result := 0;
  545.   sock := socket(AF_INET, SOCK_STREAM, 0);
  546.   if sock = INVALID_SOCKET then
  547.     Exit;
  548.   srv_address.sin_family := AF_INET;
  549.   srv_address.sin_addr.s_addr := INADDR_ANY;
  550.   for i := 3000 to 50000 do
  551.   begin
  552.     srv_address.sin_port := htons(i);
  553.     if bind(sock, srv_address, SizeOf(srv_address)) <> SOCKET_ERROR then
  554.     begin
  555.       closesocket(sock);
  556.       Result := i;
  557.       Exit;
  558.     end;
  559.   end;
  560. end;
  561.  
  562. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@2}
  563.  
  564. constructor TProxySock.Create;
  565. begin
  566.   inherited Create;
  567.   //Socket for working with TCP connections
  568.   FSock := TClSock.Create;
  569.   FSrcLen := 0;
  570.  
  571.   //Assign internal Events
  572.   FSock.OnRecieve := OnSockRecv;
  573.   FSock.OnDisconnect := OnSockDisconnect;
  574.   FSock.OnConnectError := OnSockConnectError;
  575.   FSock.OnPktParse := OnPktParse;
  576.   FSock.OnConnect := OnSockConnect;
  577.   FSock.OnResolve := OnSockResolve;
  578.   FSock.OnResolveFailed := OnSockResolveFailed;
  579.   FSock.OnError := OnSockError;
  580. end;
  581.  
  582. {*** DESTRUCTOR ***}
  583. destructor TProxySock.Destroy;
  584. begin
  585.   FSock.OnRecieve := nil;          //.                                               .
  586.   FSock.OnDisconnect := nil;       //.                                               .
  587.   FSock.OnConnectError := nil;     //.   DO NOT USE NOTIFICATIONS WHILE DESTROYING   .
  588.   FSock.OnPktParse := nil;         //.      THE OBJECT, CAUSES ACCESS VIOLATIONS     .
  589.   FSock.OnConnect := nil;          //.                                               .
  590.   FSock.OnResolve := nil;          //.
  591.   FSock.OnError := nil;
  592.   FSock.Free;
  593.   inherited;
  594. end;
  595.  
  596. {Connect procedure. Use it to connect to the remote server.}
  597. procedure TProxySock.Connect;
  598. begin
  599.   if (ProxyType = P_SOCKS4) or (ProxyType = P_SOCKS5) then
  600.   begin
  601.     FSock.OnPktParse := nil;       //Do not dump proxy data
  602.     if not FResolve then
  603.     begin
  604.       FSock.IP := Host;
  605.       FSock.Resolve;
  606.       Exit;
  607.     end;
  608.     FSock.IP := ProxyHost;
  609.     FSock.DestPort := ProxyPort;
  610.     FSock.Connect;
  611.   end else
  612.   begin
  613.     FSock.IP := Host;
  614.     FSock.DestPort := Port;
  615.     FSock.Connect;
  616.   end;
  617. end;
  618.  
  619. {Force socket disconnection.}
  620. procedure TProxySock.Disconnect;
  621. begin
  622.   FSock.Disconnect;
  623. end;
  624.  
  625. {Called when socket cannot connect to remote host.}
  626. procedure TProxySock.OnSockConnectError(Sender: TObject);
  627. begin
  628.   if Assigned(OnConnectError) then
  629.     FOnConnectError(Self);
  630. end;
  631.  
  632. {Called when closed connection.}
  633. procedure TProxySock.OnSockDisconnect(Sender: TObject);
  634. begin
  635.   if Assigned(OnDisconnect) then
  636.     FOnDisconnect(Self);
  637. end;
  638.  
  639. procedure TProxySock.OnSockError(Sender: TObject; ErrorType: TErrorType; ErrorMsg: String);
  640. begin
  641.   if Assigned(OnError) then
  642.     FOnError(Self, ErrorType, ErrorMsg);
  643. end;
  644.  
  645. {Called when resolving of Host has been complete.}
  646. procedure TProxySock.OnSockResolve(Sender: TObject; Addr: String);
  647. begin
  648.   if FProxyType = P_NONE then Exit;
  649.   Host := Addr;
  650.   FSock.IP := ProxyHost;
  651.   FSock.DestPort := ProxyPort;
  652.   FSock.Connect;
  653. end;
  654.  
  655. {Called when resolving failed.}
  656. procedure TProxySock.OnSockResolveFailed(Sender: TObject);
  657. begin
  658.   if Assigned(OnConnectError) then
  659.     FOnConnectError(Self);
  660. end;
  661.  
  662. {Called after our socket connected to server.}
  663. procedure TProxySock.OnSockConnect(Sender: TObject);
  664. var
  665.   buf: array[0..255] of Byte;
  666. begin
  667.   if ProxyType = P_NONE then                                   //Do nothing if we are not using proxies
  668.   begin
  669.     if Assigned(OnConnectProc) then
  670.       FOnConnectProc(Self);
  671.     Exit
  672.   end
  673.   else if ProxyType = P_SOCKS4 then
  674.   begin
  675.     buf[0] := 4;                                                //Socks4
  676.     buf[1] := 1;                                                //Code: 1 - Connect
  677.     PWord(Ptr(LongWord(@Buf) + 2))^ := htons(Port);             //Port
  678.     PDWord(Ptr(LongWord(@Buf) + 4))^ := inet_addr(PChar(Host)); //Host
  679.     if ProxyAuth then                                           //Add some packet specified data when using proxy authentication
  680.     begin
  681.       if Length(ProxyUserID) > 0 then                           //Test if ProxyUserID string is not nil
  682.         Move(PChar(ProxyUserID)^, buf[8], Length(ProxyUserID)); //If it's not then add it to packet
  683.       buf[8 + Length(ProxyUserID) + 1] := 0;                    //Always present NULL termination byte
  684.     end else
  685.       buf[9] := 0;                                              //Always present NULL termination byte
  686.     FSock.SendData(buf, 8 + Length(ProxyUserID) + 1);
  687.   end
  688.   else if ProxyType = P_SOCKS5 then
  689.   begin
  690.     FSocks := 0;                        //Socks authorization progress
  691.     buf[0] := 5;                        //Socks5
  692.     buf[1] := 1;                        //Number of methods
  693.     if ProxyAuth then                   //Choose auth method
  694.       buf[2] := 2                       //Use authentication
  695.     else
  696.       buf[2] := 0;                      //Plain connect
  697.     FSock.SendData(buf, 3);             //Send SOCKS5 initialization packet
  698.   end;
  699. end;
  700.  
  701. {Called when something received on socket.}
  702. procedure TProxySock.OnSockRecv(Sender: TObject; Socket: TSocket; Buffer: Pointer; BufLen: LongWord);
  703. var
  704.   i: Word;
  705.   UserLen, PassLen: Word;
  706.   procedure DoSocks5Connect;
  707.   var
  708.     len: Word;
  709.     buf: array[0..255] of Byte;
  710.   begin
  711.     if not UseProxyResolve then         //Socks5 supports on-server-resolving
  712.       len := 4
  713.     else
  714.       len := Length(Host) + 1;
  715.     buf[0] := 5;                        //Socks5
  716.     buf[1] := 1;                        //Command: connect
  717.     buf[2] := 0;                        //Reserved
  718.     if UseProxyResolve then
  719.     begin
  720.       buf[3] := 3;
  721.       buf[4] := len - 1;
  722.       Move(PChar(Host)^, buf[5], len - 1);
  723.     end else
  724.     begin
  725.       buf[3] := 1;
  726.       PDWord(LongWord(@buf) + 4)^ := inet_addr(PChar(Host));
  727.     end;
  728.     PWord(LongWord(@buf) + 4 + Len)^ := htons(Port);
  729.     FSock.SendData(buf, 6 + Len);
  730.   end;
  731.  
  732. begin
  733.   if BufLen = 0 then Exit;
  734.   if ProxyType = P_SOCKS4 then
  735.   begin
  736.     for i := 0 to BufLen - 1 do
  737.     begin
  738.       FSrcBuf[FSrcLen] := PByte(LongWord(Buffer) + i)^;
  739.       Inc(FSrcLen);
  740.       if FSrcLen = 8 then
  741.       begin
  742.         FProxyType := P_NONE;           //After we connected to proxy we work as usual
  743.         Dec(BufLen, i);
  744.         FSrcLen := 0;
  745.         if PByte(Ptr(LongWord(Buffer) + 1))^ <> 90 then
  746.         begin
  747.           if Assigned(OnError) then
  748.             FOnError(Self, ERR_PROXY, 'SOCKS4 server cannot connect to remote server');
  749.           if Assigned(OnConnectError) then
  750.             FOnConnectError(Self);
  751.           Exit;
  752.         end;
  753.         FSock.OnPktParse := OnPktParse;
  754.         if Assigned(OnConnectProc) then
  755.           FOnConnectProc(Self);
  756.         if i < BufLen - 1 then
  757.           OnSockRecv(Sender, Socket, Ptr(LongWord(Buffer) + i), BufLen);        //Continue handling of remaining data
  758.       end;
  759.     end;
  760.     Exit;
  761.   end else
  762.   if ProxyType = P_SOCKS5 then
  763.   begin
  764.     for i := 0 to BufLen - 1 do
  765.     begin
  766.       FSrcBuf[FSrcLen] := PByte(LongWord(Buffer) + i)^;
  767.       Inc(FSrcLen);
  768.       case FSocks of
  769.         0:
  770.         begin
  771.           if FSrcLen = 2 then
  772.           begin
  773.             if FSrcBuf[1] = $ff then
  774.             begin
  775.               if Assigned(OnError) then
  776.                 FOnError(Self, ERR_PROXY, 'Auth methods are not supported by SOCKS5 server');
  777.               if Assigned(OnConnectError) then
  778.                 FOnConnectError(Self);
  779.               Exit;
  780.             end;
  781.             FSrcLen := 0;
  782.             if FSrcBuf[1] = 2 then
  783.             begin
  784.               UserLen := Length(ProxyUserID);
  785.               PassLen := Length(ProxyPass);
  786.               FSrcBuf[0] := 1;
  787.               FSrcBuf[1] := UserLen;
  788.               Move(PChar(ProxyUserID)^, Ptr(LongWord(@FSrcBuf) + 2)^, UserLen);
  789.               FSrcBuf[UserLen + 2] := PassLen;
  790.               Move(PChar(ProxyPass)^, Ptr(LongWord(@FSrcBuf) + 3 + UserLen)^, UserLen);
  791.               FSock.SendData(FSrcBuf, 3 + UserLen + PassLen);
  792.               Inc(FSocks);
  793.             end else
  794.             begin
  795.               Inc(FSocks, 2);
  796.               DoSocks5Connect;
  797.             end;
  798.           end;
  799.         end;
  800.         1:
  801.         begin
  802.           if FSrcLen = 2 then
  803.           begin
  804.             if FSrcBuf[1] <> 0 then
  805.             begin
  806.               if Assigned(OnError) then
  807.                 FOnError(Self, ERR_PROXY, 'SOCKS5 server cannot authenticate us');
  808.               if Assigned(OnConnectError) then
  809.                 FOnConnectError(Self);
  810.               Exit;
  811.             end;
  812.             FSrcLen := 0;
  813.             Inc(FSocks);
  814.             DoSocks5Connect;
  815.           end;
  816.         end;
  817.         2:
  818.         begin
  819.           if FSrcLen = 10 then
  820.           begin
  821.             if (FSrcBuf[0] <> 5) or (FSrcBuf[1] <> 0) then
  822.             begin
  823.               if Assigned(OnError) then
  824.                 FOnError(Self, ERR_PROXY, 'SOCKS5 server cannot connect to remote server');
  825.               if Assigned(OnConnectError) then
  826.                 FOnConnectError(Self);
  827.               Exit;
  828.             end;
  829.             FSrcLen := 0;
  830.             ProxyType := P_NONE;
  831.             FSock.OnPktParse := OnPktParse;
  832.             if Assigned(OnConnectProc) then
  833.               FOnConnectProc(Self);
  834.             if i < BufLen - 1 then
  835.               OnSockRecv(Sender, Socket, Ptr(LongWord(Buffer) + i), BufLen);        //Continue handling of remaining data
  836.           end;
  837.         end;
  838.       end;
  839.     end;
  840.     Exit;
  841.   end;
  842.   OnReceive(Buffer, BufLen);
  843. end;
  844.  
  845. {Called when some data has been sent through socket.}
  846. procedure TProxySock.OnPktParse(Sender: TObject; Buffer: Pointer; BufLen: LongWord);
  847. begin
  848.   if Assigned(OnPktParseA) then
  849.     FOnPktParse(Sender, Buffer, BufLen, False);
  850. end;
  851.  
  852. {Sending data throgh socket.}
  853. procedure TProxySock.SendData(var Buf; BufLen: LongWord);
  854. begin
  855.   FSock.SendData(Buf, BufLen);
  856. end;
  857.  
  858. {Forward handlers.}
  859. procedure TProxySock.OnReceive;
  860. begin
  861.   if Assigned(OnReceiveProc) then
  862.     FOnRecv(Self, FSock.FClSock, Buffer, BufLen);
  863. end;
  864.  
  865.  
  866. function TMySock.GetClientSocket: TSocket;
  867. begin
  868.   Result := FSock.FClSock;
  869. end;
  870.  
  871. procedure TMySock.SetClientSocket(Socket: TSocket);
  872. begin
  873.   FSock.FClSock := Socket;
  874. end;
  875.  
  876. function TMySock.IsConnected: Boolean;
  877. begin
  878.   Result := FSock.IsConnected;
  879. end;
  880.  
  881.  
  882.  
  883. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  884. {-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=}
  885. constructor TSrvSock.Create;
  886. begin
  887.   inherited;
  888.   FWndHandle := AllocateHwnd(OnSockMsg);
  889.   FSrvSock := INVALID_SOCKET;
  890. end;
  891.  
  892. destructor TSrvSock.Destroy;
  893. begin
  894.   DeallocateHwnd(FWndHandle);
  895.   StopServer;
  896.   inherited;
  897. end;
  898.  
  899. procedure TSrvSock.OnSockMsg(var Msg: TMessage);
  900. var
  901.   //rc: Integer;
  902.   acc_sin_len: Integer;
  903.   acc_sin: sockaddr_in;
  904.   FClSock: TSocket;
  905.   FCl: TMySock;
  906. begin
  907.   case Msg.Msg of
  908.     WSA_ACCEPT:
  909.     begin
  910.       if WSAGETSELECTERROR(Msg.lParam) <> 0 then
  911.       begin
  912.         MessageBox(0, 'accept  Error', 'Error', MB_OK);
  913.         //WSAAsyncSelect(FSrvSock, FWndHandle, 0, 0);
  914.         Exit;
  915.       end;
  916.  
  917.       //Size of acc_sin
  918.       acc_sin_len := SizeOf(acc_sin);
  919.  
  920.       //Allow connection
  921.       FClSock := accept(FSrvSock, @acc_sin, @acc_sin_len);
  922.  
  923.       if FClSock = INVALID_SOCKET then
  924.       begin
  925.         MessageBox(0, 'accept  Error, invalid socket', 'Error', MB_OK);
  926.         Exit;
  927.       end;
  928.  
  929.       FCl := TMySock.Create;
  930.       FCl.ClientSocket := FClSock;
  931.  
  932.       //Allow network notifies in client socket
  933.       {rc := WSAAsyncSelect(FClSock, FCl.FWndHandle, WSA_NETEVENT,
  934.         FD_READ or FD_CLOSE);
  935.       if rc > 0 then
  936.       begin
  937.         closesocket(FClSock);
  938.         MessageBox(0, 'WSAAsyncSelect  Error', 'Error', MB_OK);
  939.         FCl.Free;
  940.         Exit;
  941.       end;}
  942.       if Assigned(OnClientConnected) then
  943.         FOnClientConnected(Self, FCl);
  944.     end;
  945.   end;
  946. end;
  947.  
  948.  
  949. function TSrvSock.StartServer(Port: Word): Boolean;
  950. var
  951.   srv_address: sockaddr_in;
  952.   rc: Integer;
  953. begin
  954.   Result := False;
  955.  
  956.   //Creating server socket
  957.   FSrvSock := socket(AF_INET, SOCK_STREAM, 0);
  958.   if FSrvSock = INVALID_SOCKET then
  959.   begin
  960.     MessageBox(0, 'Could not create server socket', 'Error', MB_OK);
  961.     Exit;
  962.   end;
  963.  
  964.   srv_address.sin_family := AF_INET;
  965.   srv_address.sin_addr.s_addr := INADDR_ANY;  //Accept connection from all addresses
  966.   srv_address.sin_port := htons(Port);        //Set local port
  967.  
  968.   //Binding a port
  969.   if bind(FSrvSock, srv_address, SizeOf(srv_address)) = SOCKET_ERROR then
  970.   begin
  971.     //Closing socket on error
  972.     closesocket(FSrvSock);
  973.     MessageBox(0, 'Could not bind server', 'Error', MB_OK);
  974.     Exit;
  975.   end;
  976.  
  977.   //Setting socket in listen status
  978.   if listen(FSrvSock, 5) = SOCKET_ERROR then
  979.   begin
  980.     closesocket(FSrvSock);
  981.     MessageBox(0, 'listen Error', 'Error', MB_OK);
  982.     Exit;
  983.   end;
  984.  
  985.   rc := WSAAsyncSelect(FSrvSock, FWndHandle, WSA_ACCEPT, FD_ACCEPT);
  986.   if rc > 0 then
  987.   begin
  988.     closesocket(FSrvSock);
  989.     MessageBox(0, 'WSAAsyncSelect  Error', 'Error', MB_OK);
  990.     Exit;
  991.   end;
  992.  
  993.   Result := True;
  994. end;
  995.  
  996. function TSrvSock.StopServer: Boolean;
  997. begin
  998.   Result := False;
  999.   if FSrvSock  <> INVALID_SOCKET then
  1000.   begin
  1001.     //Removing receiveing of all notifications
  1002.     WSAAsyncSelect(FSrvSock, FWndHandle, 0, 0);
  1003.     //If socket was created then close it
  1004.     closesocket(FSrvSock);
  1005.     FSrvSock := INVALID_SOCKET;
  1006.     Result := True;
  1007.   end;
  1008. end;
  1009.  
  1010. end.
  1011.