home *** CD-ROM | disk | FTP | other *** search
Wrap
unit ICQDirect; {(C) Alex Demchenko(alex@ritlabs.com)} {$R-} interface uses Windows, Messages, Winsock, Classes, MySocket, ICQWorks; type PDirectUser = ^TDirectUser; TDirectUser = record UIN, Cookie: LongWord; IPExt, IPInt: LongWord; Port: Word; end; TOnHandle = procedure(Sender: TObject; UIN: LongWord; Pak: PRawPkt; Len: LongWord) of object; TDirectControl = class(TObject) private FSrv: TSrvSock; FPort: Word; FList: TList; FUList: TList; FUIN: LongWord; FOnPktDump: TOnPktParseAdv; FOnHandle: TOnHandle; FProxyType: TProxyType; FProxyHost: String; FProxyPort: Word; FProxyAuth: Boolean; FProxyPass: String; FUserID: String; FResolve: Boolean; FOnError: TOnError; procedure OnIntError(Sender: TObject; ErrorType: TErrorType; ErrorMsg: String); procedure OnClientConnected(Sender: TObject; Client: TMySock); procedure OnClientDestroy(Sender: TObject); public constructor Create(MyUIN: LongWord); destructor Destroy; override; procedure AddUser(UIN, Cookie, IPExt, IPInt: LongWord; Port: Word); function GetUser(UIN: LongWord; var User: TDirectUser): Boolean; procedure EstabilishConnection(UIN: LongWord); function ConnectionEstabilished(UIN: LongWord): Boolean; function SendData(UIN: LongWord; Pak: PRawPkt): Boolean; property BindPort: Word read FPort; property ProxyType: TProxyType read FProxyType write FProxyType; property ProxyHost: String read FProxyHost write FProxyHost; property ProxyPort: Word read FProxyPort write FProxyPort; property ProxyUserID: String read FUserID write FUserID; property ProxyAuth: Boolean read FProxyAuth write FProxyAuth; property ProxyPass: String read FProxyPass write FProxyPass; property UseProxyResolve: Boolean read FResolve write FResolve default False; published property OnPktDump: TOnPktParseAdv read FOnPktDump write FOnPktDump; property OnHandle: TOnHandle read FOnHandle write FOnHandle; property OnError: TOnError read FOnError write FOnError; end; TDirectClient = class(TObject) private FDirectSize: LongWord; FDirectBuf: TRawPkt; FDirectBufLen: LongWord; FParent: TDirectControl; FClSock: TMySock; FIncoming: Boolean; FOnDestroy: TNotifyEvent; FEstabilished: Boolean; FRemUIN: LongWord; FOnError: TOnError; procedure OnSockError(Sender: TObject); procedure OnSockConnectError(Sender: TObject); procedure OnConnect(Sender: TObject); procedure OnReceive(Sender: TObject; Socket: TSocket; Buffer: Pointer; BufLen: LongWord); procedure SendDirectPacket(Pkt: TRawPkt); procedure HandleDirectPacket(Pak: TRawPkt; BufLen: LongWord); public constructor Create(Client: TMySock; Incoming: Boolean; Parent: TDirectControl); destructor Destroy; override; procedure DoConnect(UIN: LongWord); published property OnDestroyMe: TNotifyEvent read FOnDestroy write FOnDestroy; property OnError: TOnError read FOnError write FOnError; end; implementation {----------------------------------------------------------------------------------------------} constructor TDirectControl.Create(MyUIN: LongWord); begin FUIN := MyUIN; FList := TList.Create; FUList := TList.Create; FSrv := TSrvSock.Create; FPort := FindBindPort; if not FSrv.StartServer(FPort) then OnIntError(Self, ERR_SOCKET, 'Direct connection server cannot be initialized'); FSrv.OnClientConnected := OnClientConnected; end; destructor TDirectControl.Destroy; var i: Word; begin FSrv.OnClientConnected := nil; if FList.Count > 0 then for i := 0 to FList.Count - 1 do TDirectClient(FList.Items[i]).Free; FList.Free; if FUList.Count > 0 then for i := 0 to FUList.Count - 1 do FreeMem(FUList.Items[i], SizeOf(TDirectUser)); FUList.Free; FSrv.OnClientConnected := nil; FSrv.StopServer; FSrv.Free; inherited; end; {Add user's direct info, when he changes status or goes offline} procedure TDirectControl.AddUser(UIN, Cookie, IPExt, IPInt: LongWord; Port: Word); var i: Word; p: PDirectUser; begin if FUList.Count > 0 then for i := 0 to FUList.Count - 1 do if PDirectUser(FUList.Items[i])^.UIN = UIN then begin PDirectUser(FUList.Items[i])^.Cookie := Cookie; PDirectUser(FUList.Items[i])^.IPExt := IPExt; PDirectUser(FUList.Items[i])^.IPInt := IPInt; PDirectUser(FUList.Items[i])^.Port := Port; Exit; end; GetMem(p, SizeOf(TDirectUser)); p^.UIN := UIN; p^.Cookie := Cookie; p^.IPExt := IPExt; p^.IPInt := IPInt; p^.Port := Port; FUList.Add(p); end; {Get user's direct info from local list} function TDirectControl.GetUser(UIN: LongWord; var User: TDirectUser): Boolean; var i: Word; begin if FUList.Count > 0 then for i := 0 to FUList.Count - 1 do if PDirectUser(FUList.Items[i])^.UIN = UIN then begin User := PDirectUser(FUList.Items[i])^; Result := True; Exit; end; Result := False; end; {Estabilish connection with UIN if it's possible.} procedure TDirectControl.EstabilishConnection(UIN: LongWord); var DirectClient: TDirectClient; Client: TMySock; i: Word; begin if FList.Count > 0 then for i := 0 to FList.Count - 1 do if TDirectClient(FList.Items[i]).FRemUIN = UIN then Exit; Client := TMySock.Create; DirectClient := TDirectClient.Create(Client, False, Self); DirectClient.OnDestroyMe := OnClientDestroy; FList.Add(DirectClient); //Assign proxy settings DirectClient.FClSock.ProxyType := ProxyType; DirectClient.FClSock.ProxyHost := ProxyHost; DirectClient.FClSock.ProxyPort := ProxyPort; DirectClient.FClSock.ProxyUserID := ProxyUserID; DirectClient.FClSock.ProxyAuth := ProxyAuth; DirectClient.FClSock.ProxyPass := ProxyPass; DirectClient.FClSock.UseProxyResolve := UseProxyResolve; DirectClient.OnError := OnIntError; DirectClient.DoConnect(UIN); end; {Checks if connection with user has been estabilished.} function TDirectControl.ConnectionEstabilished(UIN: LongWord): Boolean; var i: Word; begin Result := True; if FList.Count > 0 then for i := 0 to FList.Count - 1 do if TDirectClient(FList.Items[i]).FRemUIN = UIN then Exit; Result := False; end; {Send packet to UIN directly.} function TDirectControl.SendData(UIN: LongWord; Pak: PRawPkt): Boolean; var i: Word; begin Result := False; if FList.Count > 0 then for i := 0 to FList.Count - 1 do begin if TDirectClient(FList.Items[i]).FRemUIN = UIN then begin Result := True; TDirectClient(FList.Items[i]).SendDirectPacket(Pak^); Exit; end; end; end; {Called when some error happened.} procedure TDirectControl.OnIntError(Sender: TObject; ErrorType: TErrorType; ErrorMsg: String); begin if Assigned(OnError) then FOnError(Self, ErrorType, ErrorMsg); end; {Called when client is connected.} procedure TDirectControl.OnClientConnected(Sender: TObject; Client: TMySock); var DirectClient: TDirectClient; begin DirectClient := TDirectClient.Create(Client, True, Self); DirectClient.OnDestroyMe := OnClientDestroy; FList.Add(DirectClient); end; procedure TDirectControl.OnClientDestroy(Sender: TObject); begin TDirectClient(Sender).Free; FList.Remove(Sender); end; {---------------------------------------------------------------------------} constructor TDirectClient.Create(Client: TMySock; Incoming: Boolean; Parent: TDirectControl); begin FEstabilished := False; FClSock := Client; FIncoming := Incoming; FParent := Parent; Client.OnDisconnect := OnSockError; Client.OnConnectError := OnSockConnectError; Client.OnReceiveProc := OnReceive; Client.OnConnectProc := OnConnect; end; destructor TDirectClient.Destroy; begin FClSock.OnDisconnect := nil; FClSock.OnConnectProc := nil; FClSock.OnConnectError := nil; FClSock.OnReceiveProc := nil; FClSock.OnPktParseA := nil; FClSock.Free; end; {Connect to UIN.} procedure TDirectClient.DoConnect(UIN: LongWord); var User: TDirectUser; inaddr: in_addr; begin FRemUIN := UIN; if not FParent.GetUser(UIN, User) then begin OnSockError(Self); Exit; end else begin inaddr.S_addr := User.IPExt; FClSock.Host := inet_ntoa(inaddr); FClSock.Port := User.Port; end; FClSock.Connect; end; procedure TDirectClient.OnSockError(Sender: TObject); begin FClSock.OnDisconnect := nil; FClSock.OnConnectProc := nil; FClSock.OnConnectError := nil; FClSock.OnReceiveProc := nil; FClSock.OnPktParseA := nil; if Assigned(OnDestroyMe) then FOnDestroy(Self); end; procedure TDirectClient.OnSockConnectError(Sender: TObject); begin OnSockError(Self); end; procedure TDirectClient.OnConnect(Sender: TObject); var pkt: TRawPkt; User: TDirectUser; begin 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; CreatePEER_INIT(@pkt, User.Cookie, FRemUIN, FParent.FUIN, User.Port, User.IPExt, User.IPInt, FClSock.ProxyType); SendDirectPacket(pkt); end; procedure TDirectClient.OnReceive(Sender: TObject; Socket: TSocket; Buffer: Pointer; BufLen: LongWord); var i: Word; begin if BufLen = 0 then Exit; for i := 0 to BufLen - 1 do begin FDirectBuf.Data[FDirectBufLen] := PByte(LongWord(Buffer) + i)^; Inc(FDirectBufLen); if (FDirectBufLen = 2) then FDirectSize := PWord(@FDirectBuf)^; if (FDirectBufLen = FDirectSize + 2) then {2 - Size before packet} begin {Prepare structures for receiving the next packet} FDirectSize := 0; FDirectBuf.Len := 0; {} HandleDirectPacket(FDirectBuf, FDirectBufLen); FDirectBufLen := 0; end; end; end; procedure TDirectClient.SendDirectPacket(Pkt: TRawPkt); var buf: array[0..8192] of Byte; begin if FClSock.Connected then begin FClSock.SendData(Pkt.Len, 2); FClSock.SendData(Pkt, Pkt.Len); end else begin OnSockError(Self); Exit; end; Move(pkt.len, buf, 2); Move(pkt, Ptr(LongWord(@buf) + 2)^, Pkt.Len); if Assigned(FParent.OnPktDump) then FParent.FOnPktDump(FParent, @buf, Pkt.Len + 2, False); end; procedure TDirectClient.HandleDirectPacket(Pak: TRawPkt; BufLen: LongWord); var port: LongWord; user: TDirectUser; lpkt: TRawPkt; ptype: Byte; begin if Assigned(FParent.OnPktDump) then FParent.FOnPktDump(FParent, @Pak, BufLen, True); GetLInt(@Pak, 2); //Packet length case GetInt(@Pak, 1) of $ff: //PEER_INIT begin 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; 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; 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; Inc(Pak.Len, 2); //00 00 - empty port := GetLInt(@Pak, 4); //remote port FRemUIN := GetLInt(@Pak, 4); //remote UIN Inc(Pak.Len, 8); //IPs, not used ptype := GetInt(@Pak, 1); //Proxy type 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; 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; 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; 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; CreatePEER_ACK(@lpkt); SendDirectPacket(lpkt); if FIncoming then begin CreatePEER_INIT(@lpkt, User.Cookie, FRemUIN, FParent.FUIN, FParent.FPort, GetLocalIP, GetLocalIP, FClSock.ProxyType); SendDirectPacket(lpkt); end else begin CreatePEER_INIT2(@lpkt, FIncoming); SendDirectPacket(lpkt); end; end; $03: begin if FIncoming then begin CreatePEER_INIT2(@lpkt, FIncoming); SendDirectPacket(lpkt); end; FEstabilished := True; end; $02: begin if Assigned(FParent.OnHandle) then begin Pak.Len := BufLen; FParent.FOnHandle(Self, FRemUIN, @Pak, BufLen); end; end; end; end; end.