home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 November / Chip_2002-11_cd1.bin / zkuste / delphi / kompon / d3456 / ICQ.ZIP / ICQ / Component / ICQDirect.pas < prev    next >
Pascal/Delphi Source File  |  2002-08-11  |  14KB  |  422 lines
  1. unit ICQDirect;
  2. {(C) Alex Demchenko(alex@ritlabs.com)}
  3. {$R-}
  4.  
  5. interface
  6. uses
  7.   Windows, Messages, Winsock, Classes,
  8.   MySocket, ICQWorks;
  9.  
  10. type
  11.   PDirectUser = ^TDirectUser;
  12.   TDirectUser = record
  13.     UIN, Cookie: LongWord;
  14.     IPExt, IPInt: LongWord;
  15.     Port: Word;
  16.   end;
  17.  
  18.   TOnHandle = procedure(Sender: TObject; UIN: LongWord; Pak: PRawPkt; Len: LongWord) of object;
  19.  
  20.   TDirectControl = class(TObject)
  21.   private
  22.     FSrv: TSrvSock;
  23.     FPort: Word;
  24.     FList: TList;
  25.     FUList: TList;
  26.     FUIN: LongWord;
  27.     FOnPktDump: TOnPktParseAdv;
  28.     FOnHandle: TOnHandle;
  29.  
  30.     FProxyType: TProxyType;
  31.     FProxyHost: String;
  32.     FProxyPort: Word;
  33.     FProxyAuth: Boolean;
  34.     FProxyPass: String;
  35.     FUserID: String;
  36.     FResolve: Boolean;
  37.     FOnError: TOnError;
  38.     procedure OnIntError(Sender: TObject; ErrorType: TErrorType; ErrorMsg: String);
  39.     procedure OnClientConnected(Sender: TObject; Client: TMySock);
  40.     procedure OnClientDestroy(Sender: TObject);
  41.   public
  42.     constructor Create(MyUIN: LongWord);
  43.     destructor Destroy; override;
  44.     procedure AddUser(UIN, Cookie, IPExt, IPInt: LongWord; Port: Word);
  45.     function GetUser(UIN: LongWord; var User: TDirectUser): Boolean;
  46.     procedure EstabilishConnection(UIN: LongWord);
  47.     function ConnectionEstabilished(UIN: LongWord): Boolean;
  48.     function SendData(UIN: LongWord; Pak: PRawPkt): Boolean;
  49.     property BindPort: Word read FPort;
  50.  
  51.     property ProxyType: TProxyType read FProxyType write FProxyType;
  52.     property ProxyHost: String read FProxyHost write FProxyHost;
  53.     property ProxyPort: Word read FProxyPort write FProxyPort;
  54.     property ProxyUserID: String read FUserID write FUserID;
  55.     property ProxyAuth: Boolean read FProxyAuth write FProxyAuth;
  56.     property ProxyPass: String read FProxyPass write FProxyPass;
  57.     property UseProxyResolve: Boolean read FResolve write FResolve default False;
  58.   published
  59.     property OnPktDump: TOnPktParseAdv read FOnPktDump write FOnPktDump;
  60.     property OnHandle: TOnHandle read FOnHandle write FOnHandle;
  61.     property OnError: TOnError read FOnError write FOnError;
  62.   end;
  63.  
  64.   TDirectClient = class(TObject)
  65.   private
  66.     FDirectSize: LongWord;
  67.     FDirectBuf: TRawPkt;
  68.     FDirectBufLen: LongWord;
  69.  
  70.     FParent: TDirectControl;
  71.     FClSock: TMySock;
  72.     FIncoming: Boolean;
  73.     FOnDestroy: TNotifyEvent;
  74.     FEstabilished: Boolean;
  75.  
  76.     FRemUIN: LongWord;
  77.     FOnError: TOnError;
  78.     procedure OnSockError(Sender: TObject);
  79.     procedure OnSockConnectError(Sender: TObject);
  80.     procedure OnConnect(Sender: TObject);
  81.     procedure OnReceive(Sender: TObject; Socket: TSocket; Buffer: Pointer; BufLen: LongWord);
  82.     procedure SendDirectPacket(Pkt: TRawPkt);
  83.     procedure HandleDirectPacket(Pak: TRawPkt; BufLen: LongWord);
  84.   public
  85.     constructor Create(Client: TMySock; Incoming: Boolean; Parent: TDirectControl);
  86.     destructor Destroy; override;
  87.     procedure DoConnect(UIN: LongWord);
  88.   published
  89.     property OnDestroyMe: TNotifyEvent read FOnDestroy write FOnDestroy;
  90.     property OnError: TOnError read FOnError write FOnError;
  91.   end;
  92.  
  93. implementation
  94. {----------------------------------------------------------------------------------------------}
  95. constructor TDirectControl.Create(MyUIN: LongWord);
  96. begin
  97.   FUIN := MyUIN;
  98.  
  99.   FList := TList.Create;
  100.   FUList := TList.Create;
  101.   FSrv := TSrvSock.Create;
  102.  
  103.   FPort := FindBindPort;
  104.   if not FSrv.StartServer(FPort) then
  105.     OnIntError(Self, ERR_SOCKET, 'Direct connection server cannot be initialized');
  106.   FSrv.OnClientConnected := OnClientConnected;
  107. end;
  108.  
  109. destructor TDirectControl.Destroy;
  110. var
  111.   i: Word;
  112. begin
  113.   FSrv.OnClientConnected := nil;
  114.   if FList.Count > 0 then
  115.     for i := 0 to FList.Count - 1 do
  116.       TDirectClient(FList.Items[i]).Free;
  117.   FList.Free;
  118.   if FUList.Count > 0 then
  119.     for i := 0 to FUList.Count - 1 do
  120.       FreeMem(FUList.Items[i], SizeOf(TDirectUser));
  121.   FUList.Free;
  122.   FSrv.OnClientConnected := nil;
  123.   FSrv.StopServer;
  124.   FSrv.Free;
  125.   inherited;
  126. end;
  127.  
  128. {Add user's direct info, when he changes status or goes offline}
  129. procedure TDirectControl.AddUser(UIN, Cookie, IPExt, IPInt: LongWord; Port: Word);
  130. var
  131.   i: Word;
  132.   p: PDirectUser;
  133. begin
  134.   if FUList.Count > 0 then
  135.     for i := 0 to FUList.Count - 1 do
  136.       if PDirectUser(FUList.Items[i])^.UIN = UIN then
  137.       begin
  138.         PDirectUser(FUList.Items[i])^.Cookie := Cookie;
  139.         PDirectUser(FUList.Items[i])^.IPExt := IPExt;
  140.         PDirectUser(FUList.Items[i])^.IPInt := IPInt;
  141.         PDirectUser(FUList.Items[i])^.Port := Port;
  142.         Exit;
  143.       end;
  144.   GetMem(p, SizeOf(TDirectUser));
  145.   p^.UIN := UIN;
  146.   p^.Cookie := Cookie;
  147.   p^.IPExt := IPExt;
  148.   p^.IPInt := IPInt;
  149.   p^.Port := Port;
  150.   FUList.Add(p);
  151. end;
  152.  
  153. {Get user's direct info from local list}
  154. function TDirectControl.GetUser(UIN: LongWord; var User: TDirectUser): Boolean;
  155. var
  156.   i: Word;
  157. begin
  158.   if FUList.Count > 0 then
  159.     for i := 0 to FUList.Count - 1 do
  160.       if PDirectUser(FUList.Items[i])^.UIN = UIN then
  161.       begin
  162.         User := PDirectUser(FUList.Items[i])^;
  163.         Result := True;
  164.         Exit;
  165.       end;
  166.   Result := False;
  167. end;
  168.  
  169. {Estabilish connection with UIN if it's possible.}
  170. procedure TDirectControl.EstabilishConnection(UIN: LongWord);
  171. var
  172.   DirectClient: TDirectClient;
  173.   Client: TMySock;
  174.   i: Word;
  175. begin
  176.   if FList.Count > 0 then
  177.     for i := 0 to FList.Count - 1 do
  178.       if TDirectClient(FList.Items[i]).FRemUIN = UIN then
  179.         Exit;
  180.   Client := TMySock.Create;
  181.   DirectClient := TDirectClient.Create(Client, False, Self);
  182.   DirectClient.OnDestroyMe := OnClientDestroy;
  183.   FList.Add(DirectClient);
  184.  
  185.   //Assign proxy settings
  186.   DirectClient.FClSock.ProxyType := ProxyType;
  187.   DirectClient.FClSock.ProxyHost := ProxyHost;
  188.   DirectClient.FClSock.ProxyPort := ProxyPort;
  189.   DirectClient.FClSock.ProxyUserID := ProxyUserID;
  190.   DirectClient.FClSock.ProxyAuth := ProxyAuth;
  191.   DirectClient.FClSock.ProxyPass := ProxyPass;
  192.   DirectClient.FClSock.UseProxyResolve := UseProxyResolve;
  193.   DirectClient.OnError := OnIntError;
  194.  
  195.   DirectClient.DoConnect(UIN);
  196. end;
  197.  
  198. {Checks if connection with user has been estabilished.}
  199. function TDirectControl.ConnectionEstabilished(UIN: LongWord): Boolean;
  200. var
  201.   i: Word;
  202. begin
  203.   Result := True;
  204.   if FList.Count > 0 then
  205.     for i := 0 to FList.Count - 1 do
  206.       if TDirectClient(FList.Items[i]).FRemUIN = UIN then
  207.         Exit;
  208.   Result := False;
  209. end;
  210.  
  211. {Send packet to UIN directly.}
  212. function TDirectControl.SendData(UIN: LongWord; Pak: PRawPkt): Boolean;
  213. var
  214.   i: Word;
  215. begin
  216.   Result := False;
  217.   if FList.Count > 0 then
  218.     for i := 0 to FList.Count - 1 do
  219.     begin
  220.       if TDirectClient(FList.Items[i]).FRemUIN = UIN then
  221.       begin
  222.         Result := True;
  223.         TDirectClient(FList.Items[i]).SendDirectPacket(Pak^);
  224.         Exit;
  225.       end;
  226.     end;
  227. end;
  228.  
  229. {Called when some error happened.}
  230. procedure TDirectControl.OnIntError(Sender: TObject; ErrorType: TErrorType; ErrorMsg: String);
  231. begin
  232.   if Assigned(OnError) then
  233.     FOnError(Self, ErrorType, ErrorMsg);
  234. end;
  235.  
  236. {Called when client is connected.}
  237. procedure TDirectControl.OnClientConnected(Sender: TObject; Client: TMySock);
  238. var
  239.   DirectClient: TDirectClient;
  240. begin
  241.   DirectClient := TDirectClient.Create(Client, True, Self);
  242.   DirectClient.OnDestroyMe := OnClientDestroy;
  243.   FList.Add(DirectClient);
  244. end;
  245.  
  246. procedure TDirectControl.OnClientDestroy(Sender: TObject);
  247. begin
  248.   TDirectClient(Sender).Free;
  249.   FList.Remove(Sender);
  250. end;
  251.  
  252.  
  253. {---------------------------------------------------------------------------}
  254. constructor TDirectClient.Create(Client: TMySock; Incoming: Boolean; Parent: TDirectControl);
  255. begin
  256.   FEstabilished := False;
  257.   FClSock := Client;
  258.   FIncoming := Incoming;
  259.   FParent := Parent;
  260.   Client.OnDisconnect := OnSockError;
  261.   Client.OnConnectError := OnSockConnectError;
  262.   Client.OnReceiveProc := OnReceive;
  263.   Client.OnConnectProc := OnConnect;
  264. end;
  265.  
  266. destructor TDirectClient.Destroy;
  267. begin
  268.   FClSock.OnDisconnect := nil;
  269.   FClSock.OnConnectProc := nil;
  270.   FClSock.OnConnectError := nil;
  271.   FClSock.OnReceiveProc := nil;
  272.   FClSock.OnPktParseA := nil;
  273.   FClSock.Free;
  274. end;
  275.  
  276. {Connect to UIN.}
  277. procedure TDirectClient.DoConnect(UIN: LongWord);
  278. var
  279.   User: TDirectUser;
  280.   inaddr: in_addr;
  281. begin
  282.   FRemUIN := UIN;
  283.   if not FParent.GetUser(UIN, User) then
  284.   begin
  285.     OnSockError(Self);
  286.     Exit;
  287.   end else
  288.   begin
  289.     inaddr.S_addr := User.IPExt;
  290.     FClSock.Host := inet_ntoa(inaddr);
  291.     FClSock.Port := User.Port;
  292.   end;
  293.   FClSock.Connect;
  294. end;
  295.  
  296. procedure TDirectClient.OnSockError(Sender: TObject);
  297. begin
  298.   FClSock.OnDisconnect := nil;
  299.   FClSock.OnConnectProc := nil;
  300.   FClSock.OnConnectError := nil;
  301.   FClSock.OnReceiveProc := nil;
  302.   FClSock.OnPktParseA := nil;
  303.   if Assigned(OnDestroyMe) then
  304.     FOnDestroy(Self);
  305. end;
  306.  
  307. procedure TDirectClient.OnSockConnectError(Sender: TObject);
  308. begin
  309.   OnSockError(Self);
  310. end;
  311.  
  312. procedure TDirectClient.OnConnect(Sender: TObject);
  313. var
  314.   pkt: TRawPkt;
  315.   User: TDirectUser;
  316. begin
  317.   if not FParent.GetUser(FRemUIN, User) then begin if Assigned(OnError) then FOnError(Self, ERR_WARNING, 'Direct connection cannot be initialized'); OnSockError(Self); Exit; end;
  318.   CreatePEER_INIT(@pkt, User.Cookie, FRemUIN, FParent.FUIN, User.Port, User.IPExt, User.IPInt, FClSock.ProxyType);
  319.   SendDirectPacket(pkt);
  320. end;
  321.  
  322. procedure TDirectClient.OnReceive(Sender: TObject; Socket: TSocket; Buffer: Pointer; BufLen: LongWord);
  323. var
  324.   i: Word;
  325. begin
  326.   if BufLen = 0 then Exit;
  327.   for i := 0 to BufLen - 1 do
  328.   begin
  329.     FDirectBuf.Data[FDirectBufLen] := PByte(LongWord(Buffer) + i)^;
  330.     Inc(FDirectBufLen);
  331.     if (FDirectBufLen = 2) then
  332.       FDirectSize := PWord(@FDirectBuf)^;
  333.     if (FDirectBufLen = FDirectSize + 2) then {2 - Size before packet}
  334.     begin
  335.       {Prepare structures for receiving the next packet}
  336.       FDirectSize := 0;
  337.       FDirectBuf.Len := 0;
  338.       {}
  339.       HandleDirectPacket(FDirectBuf, FDirectBufLen);
  340.       FDirectBufLen := 0;
  341.     end;
  342.   end;
  343. end;
  344.  
  345. procedure TDirectClient.SendDirectPacket(Pkt: TRawPkt);
  346. var
  347.   buf: array[0..8192] of Byte;
  348. begin
  349.   if FClSock.Connected then
  350.   begin
  351.     FClSock.SendData(Pkt.Len, 2);
  352.     FClSock.SendData(Pkt, Pkt.Len);
  353.   end else
  354.   begin
  355.     OnSockError(Self);
  356.     Exit;
  357.   end;
  358.   Move(pkt.len, buf, 2);
  359.   Move(pkt, Ptr(LongWord(@buf) + 2)^, Pkt.Len);
  360.   if Assigned(FParent.OnPktDump) then
  361.     FParent.FOnPktDump(FParent, @buf, Pkt.Len + 2, False);
  362. end;
  363.  
  364. procedure TDirectClient.HandleDirectPacket(Pak: TRawPkt; BufLen: LongWord);
  365. var
  366.   port: LongWord;
  367.   user: TDirectUser;
  368.   lpkt: TRawPkt;
  369.   ptype: Byte;
  370. begin
  371.   if Assigned(FParent.OnPktDump) then
  372.     FParent.FOnPktDump(FParent, @Pak, BufLen, True);
  373.   GetLInt(@Pak, 2);                     //Packet length
  374.   case GetInt(@Pak, 1) of
  375.     $ff:                                //PEER_INIT
  376.     begin
  377.       if GetLInt(@Pak, 2) < 7 then begin if Assigned(OnError) then FOnError(Self, ERR_WARNING, 'Direct connection cannot be initialized due to security issues'); OnSockError(Self); Exit; end;
  378.       if GetLInt(@Pak, 2) <> $2b then begin if Assigned(OnError) then FOnError(Self, ERR_WARNING, 'Direct connection cannot be initialized due to malformed packet'); OnSockError(Self); Exit; end;
  379.       if GetLInt(@Pak, 4) <> FParent.FUIN then begin if Assigned(OnError) then FOnError(Self, ERR_WARNING, 'Direct connection cannot be initialized due to security issues'); OnSockError(Self); Exit; end;
  380.       Inc(Pak.Len, 2);                  //00 00 - empty
  381.       port := GetLInt(@Pak, 4);         //remote port
  382.       FRemUIN := GetLInt(@Pak, 4);      //remote UIN
  383.       Inc(Pak.Len, 8);                  //IPs, not used
  384.       ptype := GetInt(@Pak, 1);         //Proxy type
  385.       if (ptype <> 04) and (ptype <> 02) then begin if Assigned(OnError) then FOnError(Self, ERR_WARNING, 'Direct connection cannot be initialized due to unsupported proxy type'); OnSockError(Self); Exit; end;
  386.       if GetLInt(@Pak, 4) <> port then begin if Assigned(OnError) then FOnError(Self, ERR_WARNING, 'Direct connection cannot be initialized due to security issues'); OnSockError(Self); Exit; end;
  387.       if not FParent.GetUser(FRemUIN, User) then begin if Assigned(OnError) then FOnError(Self, ERR_WARNING, 'Direct connection cannot be initialized'); OnSockError(Self); Exit; end;
  388.       if GetInt(@Pak, 4) <> User.Cookie then begin if Assigned(OnError) then FOnError(Self, ERR_WARNING, 'Direct connection cannot be initialized due to security issues'); OnSockError(Self); Exit; end;
  389.       CreatePEER_ACK(@lpkt);
  390.       SendDirectPacket(lpkt);
  391.       if FIncoming then
  392.       begin
  393.         CreatePEER_INIT(@lpkt, User.Cookie, FRemUIN, FParent.FUIN, FParent.FPort,
  394.           GetLocalIP, GetLocalIP, FClSock.ProxyType);
  395.         SendDirectPacket(lpkt);
  396.       end else
  397.       begin
  398.         CreatePEER_INIT2(@lpkt, FIncoming);
  399.         SendDirectPacket(lpkt);
  400.       end;
  401.     end;
  402.     $03:
  403.     begin
  404.       if FIncoming then
  405.       begin
  406.         CreatePEER_INIT2(@lpkt, FIncoming);
  407.         SendDirectPacket(lpkt);
  408.       end;
  409.       FEstabilished := True;
  410.     end;
  411.     $02:
  412.     begin
  413.       if Assigned(FParent.OnHandle) then
  414.       begin
  415.         Pak.Len := BufLen;
  416.         FParent.FOnHandle(Self, FRemUIN, @Pak, BufLen);
  417.       end;
  418.     end;
  419.   end;
  420. end;
  421.  
  422. end.