}

Delphi.int.ru — Портал программистов

Вход Регистрация | Забыли пароль?

Просмотр кода

Идентификатор: 9dd70a16 Описание: xmpp delphi class Код загружен: 19 июня 2012, 12:51 (mirt.steelwater)

  1. //
  2. // simple xmpp implementation
  3. //
  4. // credits: exodus, synapse and libxmlparser
  5. //
  6. // contact: devi[dot]mandiri[at]gmail[dot]com
  7. //
  8. // tested with openfire, ejabberd and googletalk
  9.  
  10. unit uxmpp;
  11.  
  12. {$IFDEF FPC}
  13. {$MODE DELPHI}{$H+}
  14. {$ENDIF}
  15.  
  16. // uncomment this line to debug xml line by line...
  17. {$DEFINE DEBUG_XML}
  18.  
  19. interface
  20.  
  21. uses
  22. {$IFDEF WIN32}
  23. Windows,
  24. {$ENDIF}
  25. Classes, SysUtils, tcpsynapse, xmltag, ExtCtrls;
  26.  
  27. type
  28. TMessageType = (mtRoom,mtPersonal);
  29.  
  30. TChatMessageEvent = procedure(Sender:TObject;
  31. const From:string;
  32. const MsgText:string;
  33. const MsgHTML:string;
  34. TimeStamp:TDateTime;
  35. MsgType:TMessageType) of object;
  36.  
  37. {
  38.   TOfflineMessageEvent = procedure(Sender:TObject;
  39.   From:string;
  40.   MsgText:string;
  41.   MsgHTML:string;
  42.   TimeStamp:TDateTime) of object;
  43. }
  44. TErrorEvent = procedure(Sender:TObject; const ErrMsg:string) of object;
  45. TRoomPresence = procedure(Sender:TObject; const JID:string) of object;
  46. TRoomListEvent= procedure(Sender:TObject; const RoomName:string) of object;
  47. TRosterEvent = procedure(Sender:TObject; const JID,Name,Subscription,Group:string) of object;
  48.  
  49. TXmpp=class
  50. private
  51. FSocket:TTCPClient;
  52. FHost,FPort,
  53. FUser,FPass,
  54. FResource,FCurServer,
  55. FRoomName:string;
  56. FProxyProtocol,
  57. FProxyHost,FProxyPort,
  58. FProxyUser,FProxyPass:string;
  59. {$IFDEF DEBUG_XML}
  60. FOnDebugXML:TTCPEvent;
  61. {$ENDIF}
  62. FAuthd,
  63. FSessAuth,
  64. FPresenceSet,
  65. FMD5,FCramMD5,
  66. FPLAIN:Boolean;
  67. FRoot,FRootTag,
  68. FBuff,FSessID,
  69. FJID,FConference:string;
  70. FMD5Step,FCramMD5Step,
  71. FMYID,FMSGID:integer;
  72. FParser:TXMLTagParser;
  73.  
  74. FOnError:TErrorEvent;
  75. FOnLogin,
  76. FOnLogout:TNotifyEvent;
  77.  
  78. FOnChat:TChatMessageEvent;
  79. // FOnOfflineMsg:TOfflineMessageEvent;
  80. FOnRoster:TRosterEvent;
  81.  
  82. FOnJoinedRoom,
  83. FOnLeftRoom:TRoomPresence;
  84.  
  85. FRoomRoster:TStringList;
  86. FTimer:TTimer;
  87. FOnRoomList:TRoomListEvent;
  88.  
  89. FCurrentID:string; // just test
  90.  
  91. procedure DoOnConnected(Sender:TObject);
  92. procedure DoOnDisconnected(Sender:TObject);
  93. procedure DoOnDebugXML(Sender:TObject; Value:String);
  94. procedure DoOnError(Sender:TObject; Value:string);
  95. procedure DoAfterUpgradedToSSL(Sender:TObject);
  96. procedure DoOnSSLFailed(Sender:TObject;Value:string);
  97.  
  98. procedure SetDefaultVal;
  99. procedure DoError(ErrMsg:string); // zzz...
  100. procedure SendXMPPHeader(AHost:string);
  101. function GetFullTag(AData:string):string;
  102. procedure ProsesData(AData:string);
  103. procedure ParseTags(AData:string);
  104. procedure ProsesTags(tag:TXMLTag);
  105. procedure ParsingFeatures(tag:TXMLTag);
  106. procedure ParsingIQ(tag:TXMLTag);
  107. procedure IQBeforeLoggedIn(tag: TXMLTag);
  108. procedure ParsingPresence(tag:TXMLTag);
  109. procedure ParsingMessage(tag:TXMLTag);
  110. procedure BindingResource;
  111. procedure BindingSession;
  112.  
  113. procedure SendAuth(AuthMethod:string);
  114.  
  115. procedure SendMD5Auth;
  116. procedure SendMD5Response(tag:TXMLTag);
  117. procedure SendCramMD5Auth;
  118. procedure SendCramMD5Response(tag:TXMLTag);
  119. procedure SendPLAINAuth;
  120.  
  121. // hmm.... a "command callback" or "signal listener"... what d'u think ?
  122. function GenerateID:string;
  123.  
  124. function GetJID:string;
  125. function GenerateMSGID:string;
  126.  
  127. procedure AddToRosterRoom(JID:string);
  128. function IsInRosterRoom(JID:string):Boolean;
  129. procedure RemoveFromRosterRoom(JID:string);
  130. function GetRosterRoomJID(JID:string):string;
  131.  
  132. procedure DoOnTimer(Sender:TObject);
  133. procedure SendCommand(XML:string);
  134. procedure SendChatMessage(ToJID,MsgText,MsgHtml:string;MsgType:TMessageType);
  135.  
  136. procedure ParsingIQRoster(tag:TXMLTag);
  137. public
  138. constructor Create;
  139. destructor Destroy;override;
  140.  
  141. procedure Login;
  142. procedure Logout;
  143.  
  144. procedure SendRoomMessage(MsgText:string);
  145. procedure SendPersonalMessage(ToJID,MsgText:string);
  146.  
  147. procedure JoinRoom(RoomName:string);
  148. procedure LeaveRoom;
  149. procedure GetRoomList;
  150.  
  151. published
  152. property JabberID:string read FUser write FUser;
  153. property Password:string read FPass write FPass;
  154. property Resource:string read FResource write FResource;
  155.  
  156. property Host:string read FHost write FHost;
  157. property Port:string read FPort write FPort;
  158.  
  159. property ProxyProtocol:string read FProxyProtocol write FProxyProtocol;
  160. property ProxyHost:string read FProxyHost write FProxyHost;
  161. property ProxyPort:string read FProxyPort write FProxyPort;
  162. property ProxyUser:string read FProxyUser write FProxyUser;
  163. property ProxyPass:string read FProxyPass write FProxyPass;
  164.  
  165. property OnLogin:TNotifyEvent read FOnLogin write FOnLogin;
  166. property OnLogout:TNotifyEvent read FOnLogout write FOnLogout;
  167.  
  168. {$IFDEF DEBUG_XML}
  169. property OnDebugXML:TTCPEvent read FOnDebugXML write FOnDebugXML;
  170. {$ENDIF}
  171.  
  172. property OnError:TErrorEvent read FOnError write FOnError;
  173. property OnMessage:TChatMessageEvent read FOnChat write FOnChat;
  174.  
  175. // property OnOfflineMessage:TOfflineMessageEvent read FOnOfflineMsg write FOnOfflineMsg;
  176.  
  177. property OnUserJoinedRoom:TRoomPresence read FOnJoinedRoom write FOnJoinedRoom;
  178. property OnUserLeftRoom:TRoomPresence read FOnLeftRoom write FOnLeftRoom;
  179.  
  180. property OnRoomList:TRoomListEvent read FOnRoomList write FOnRoomList;
  181.  
  182. property OnRoster:TRosterEvent read FOnRoster write FOnRoster;
  183. end;
  184.  
  185.  
  186. implementation
  187.  
  188. uses
  189. xmppconst,
  190. saslauth,
  191. synautil;
  192.  
  193. { TXmpp }
  194.  
  195. constructor TXmpp.Create;
  196. begin
  197. inherited;
  198. FUser := '';
  199. FPass := '';
  200. FResource := 'Home';
  201. FRootTag := 'stream:stream';
  202. FParser := TXMLTagParser.Create;
  203. FRoomRoster := TStringList.Create;
  204.  
  205. FSocket := TTCPClient.Create;
  206. FSocket.OnConnected := DoOnConnected;
  207. FSocket.OnDisconnected := DoOnDisconnected;
  208. FSocket.OnData := DoOnDebugXML;
  209. FSocket.OnError := DoOnError;
  210. FSocket.OnAfterUpgradedToSSL := DoAfterUpgradedToSSL;
  211. FSocket.OnSSLFailed := DoOnSSLFailed;
  212.  
  213. FTimer := TTimer.Create(nil);
  214. FTimer.Interval := 1000 * 60;
  215. FTimer.OnTimer := DoOnTimer;
  216. FTimer.Enabled := False;
  217.  
  218. end;
  219.  
  220. destructor TXmpp.Destroy;
  221. begin
  222. Logout;
  223. FTimer.Free;
  224. FRoomRoster.Free;
  225. FParser.Clear;
  226. FParser.Free;
  227. FSocket.Free;
  228. inherited;
  229. end;
  230.  
  231. procedure TXmpp.SetDefaultVal;
  232. begin
  233. FAuthd := False;
  234. FSessAuth := False;
  235. FRoot := '';
  236. FCurServer:= '';
  237. FBuff := '';
  238. FSessID := '';
  239. FRoomName := '';
  240. FJID := '';
  241. FConference := '';
  242. FMD5Step := 0;
  243. FCramMD5Step := 0;
  244. FMYID := 0;
  245. FMSGID := 0;
  246. FMD5 := False;
  247. FCramMD5 := False;
  248. FPLAIN := False;
  249. FPresenceSet := False;
  250. FProxyProtocol := 'HTTP';
  251. FProxyHost := '';
  252. FProxyPort := '8080';
  253. FProxyUser := '';
  254. FProxyPass := '';
  255. end;
  256.  
  257. procedure TXmpp.Login;
  258. begin
  259. if FSocket.IsConnected then
  260. Exit;
  261.  
  262. if (Pos('gmail.com',FHost)>0) or
  263. (Pos('google.com',FHost)>0) then
  264. begin
  265. FHost := 'talk.google.com';
  266. FUser := SeparateLeft(FUser,'@');
  267. FUser := FUser + '@' + 'gmail.com';
  268. end;
  269.  
  270. FSocket.Host := FHost;
  271. FSocket.Port := FPort;
  272.  
  273. if (FProxyHost <> '') then
  274. begin
  275. if ( UpperCase(FProxyProtocol) = 'HTTP' ) then
  276. FSocket.ProxyType := pHTTP
  277. else if ( UpperCase(FProxyProtocol) = 'SOCKS4' ) then
  278. FSocket.ProxyType := pSOCKS4
  279. else if ( UpperCase(FProxyProtocol) = 'SOCKS5' ) then
  280. FSocket.ProxyType := pSOCKS5;
  281. FSocket.ProxyHost := FProxyHost;
  282. FSocket.ProxyPort := FProxyPort;
  283. FSocket.ProxyUsername := FProxyUser;
  284. FSocket.ProxyPassword := FProxyPass;
  285. end;
  286.  
  287. FSocket.Connect;
  288. end;
  289.  
  290. procedure TXmpp.Logout;
  291. begin
  292. if FAuthd then begin
  293. SendCommand('<presence type="unavailable"/>');
  294. SendCommand('</stream:stream>');
  295. end else
  296. FSocket.Disconnect;
  297. end;
  298.  
  299. procedure TXmpp.DoOnConnected(Sender:TObject);
  300. begin
  301. SetDefaultVal;
  302. FRoomRoster.Clear;
  303. SendCommand('<?xml version="1.0"?>');
  304. if FHost='talk.google.com' then
  305. SendXMPPHeader('gmail.com')
  306. else
  307. SendXMPPHeader(FHost);
  308. end;
  309.  
  310. procedure TXmpp.DoOnDebugXML(Sender: TObject; Value:string);
  311. begin
  312. if Pos('<',Value)>0 then
  313. begin
  314. {$IFDEF DEBUG_XML}
  315. if Assigned(OnDebugXML) then
  316. FOnDebugXML(Self,'<= '+Value);
  317. {$ENDIF}
  318. if (Value<>('</'+FRootTag+'>')) then
  319. ProsesData(Value)
  320. else
  321. Logout;
  322. end;
  323. end;
  324.  
  325. procedure TXmpp.DoOnDisconnected(Sender:TObject);
  326. begin
  327. SetDefaultVal;
  328. if Assigned(OnLogout) then
  329. FOnLogout(Self);
  330. end;
  331.  
  332. procedure TXmpp.DoOnError(Sender:TObject;Value:string);
  333. begin
  334. DoError(Value);
  335. end;
  336.  
  337. procedure TXmpp.DoAfterUpgradedToSSL(Sender:TObject);
  338. begin
  339. SendXMPPHeader(FCurServer);
  340. end;
  341.  
  342. procedure TXmpp.DoOnSSLFailed(Sender:TObject;Value:string);
  343. begin
  344. // what TODO ?
  345. DoError('SSL connection failed!');
  346. end;
  347.  
  348. procedure TXmpp.SendCommand(XML: string);
  349. begin
  350. if not FSocket.IsConnected then
  351. Exit;
  352. FSocket.SendData(XML);
  353. {$IFDEF DEBUG_XML}
  354. if Assigned(OnDebugXML) then
  355. FOnDebugXML(Self,'=> '+XML);
  356. {$ENDIF}
  357. end;
  358.  
  359. procedure TXmpp.SendXMPPHeader(AHost:string);
  360. begin
  361. SendCommand('<stream:stream to="'+AHost+'" xmlns="jabber:client"'+
  362. ' xmlns:stream="http://etherx.jabber.org/streams" version="1.0">');
  363. end;
  364.  
  365. procedure TXmpp.DoError(ErrMsg: string);
  366. begin
  367. if Assigned(OnError) then
  368. FOnError(Self,ErrMsg)
  369. else
  370. raise EXMLStream.Create(ErrMsg);
  371. end;
  372.  
  373. // exodus
  374. function TXmpp.GetFullTag(AData: string): string;
  375. function RPos(find_data, in_data: string): cardinal;
  376. var
  377. lastpos, newpos: cardinal;
  378. mybuff: string;
  379. origlen: cardinal;
  380. begin
  381. lastpos := 0;
  382. newpos := 0;
  383. origlen := Length(AData);
  384. repeat
  385. mybuff := Copy(in_data, lastpos + 1, origlen-newpos);
  386. newpos := pos(find_data, mybuff);
  387. if (newpos > 0) then begin
  388. lastpos := lastpos + newpos;
  389. end;
  390. until (newpos <= 0);
  391.  
  392. Result := lastpos;
  393. end;
  394. var
  395. sbuff, r, stag, etag, tmps: string;
  396. p, ls, le, e, l, ps, pe, ws, sp, tb, cr, nl, i: longint;
  397. _counter:integer;
  398. begin
  399. Result := '';
  400. _counter := 0;
  401. sbuff := AData;
  402. l := Length(sbuff);
  403.  
  404. if (Trim(sbuff)) = '' then exit;
  405.  
  406. p := Pos('<', sbuff);
  407. if p <= 0 then
  408. begin
  409. DoError('Not a valid XML data!');
  410. Exit;
  411. end;
  412.  
  413. tmps := Copy(sbuff, p, l - p + 1);
  414. e := Pos('>', tmps);
  415. i := Pos('/>', tmps);
  416.  
  417. if ((e = 0) and (i = 0)) then exit;
  418.  
  419. if FRoot = '' then begin
  420. sp := Pos(' ', tmps);
  421. tb := Pos(#09, tmps);
  422. cr := Pos(#10, tmps);
  423. nl := Pos(#13, tmps);
  424.  
  425. ws := sp;
  426. if (tb > 0) then ws := Min(ws,tb);
  427. if (cr > 0) then ws := Min(ws,cr);
  428. if (nl > 0) then ws := Min(ws,nl);
  429.  
  430. if ((i > 0) and (i < ws)) then
  431. FRoot := Trim(Copy(sbuff, p + 1, i - 2))
  432. else if (e < ws) then
  433. FRoot := Trim(Copy(sbuff, p + 1, e - 2))
  434. else
  435. FRoot := Trim(Copy(sbuff, p + 1, ws - 2));
  436.  
  437. if (FRoot = '?xml') or
  438. (FRoot = '!ENTITY') or
  439. (FRoot = '!--') or
  440. (FRoot = '!ATTLIST') or
  441. (FRoot = FRootTag) then begin
  442. r := Copy(sbuff, p, e);
  443. FRoot := '';
  444. FBuff := Copy(sbuff, p + e , l - e - p + 1);
  445. Result := r;
  446. exit;
  447. end;
  448. end;
  449.  
  450. if (e = (i + 1)) then begin
  451. r := Copy(sbuff, p, e);
  452. FRoot := '';
  453. FBuff := Copy(sbuff, p + e, l - e - p + 1);
  454. end
  455. else begin
  456. i := p;
  457. stag := '<' + FRoot;
  458. etag := '</' + FRoot + '>';
  459. ls := length(stag);
  460. le := length(etag);
  461. r := '';
  462. repeat
  463. tmps := Copy(sbuff, i, l - i + 1);
  464. ps := Pos(stag, tmps);
  465.  
  466. if (ps > 0) then begin
  467. _counter := _counter + 1;
  468. i := i + ps + ls - 1;
  469. end;
  470.  
  471. tmps := Copy(sbuff, i, l - i + 1);
  472. pe := RPos(etag, tmps);
  473. if ((pe > 0) and ((ps > 0) and (pe > ps)) ) then begin
  474. _counter := _counter - 1;
  475. i := i + pe + le - 1;
  476. if (_counter <= 0) then begin
  477. r := Copy(sbuff, p, i - p);
  478. FRoot := '';
  479. FBuff := Copy(sbuff, i, l - i + 1);
  480. break;
  481. end;
  482. end;
  483. until ((pe <= 0) or (ps <= 0) or (tmps = ''));
  484. end;
  485. result := r;
  486. end;
  487.  
  488. procedure TXmpp.ProsesData(AData: string);
  489. var
  490. cp_buff: string;
  491. fc,frag: string;
  492. begin
  493. cp_buff := AData;
  494. cp_buff := FBuff + AData;
  495. FBuff := cp_buff;
  496.  
  497. repeat
  498. frag := GetFullTag(FBuff);
  499. if (frag <> '') then
  500. begin
  501. fc := frag[2];
  502. if (fc <> '?') and (fc <> '!') then
  503. ParseTags(frag);
  504. FRoot := '';
  505. end;
  506. until ((frag = '') or (FBuff = ''));
  507. end;
  508.  
  509. procedure TXmpp.ParseTags(AData: string);
  510. var
  511. c_tag: TXMLTag;
  512. begin
  513. FParser.ParseString(AData, FRootTag);
  514. // repeat
  515. c_tag := FParser.PopTag;
  516. if (c_tag <> nil) then
  517. begin
  518. ProsesTags(c_tag);
  519. c_tag.Free;
  520. end;
  521. // until (c_tag = nil);
  522. end;
  523.  
  524. procedure TXmpp.ProsesTags(tag: TXMLTag);
  525. var s:string;
  526. begin
  527. if tag.Name='stream:error' then
  528. begin
  529. if tag.ChildCount>0 then
  530. s := tag.ChildTags[0].Name;
  531. DoError('XML stream error '+s);
  532. end else
  533. if tag.Name=FRootTag then
  534. begin
  535. FSessID := tag.GetAttribute('id');
  536. FCurServer := tag.GetAttribute('from');
  537. end else
  538. if tag.Name='stream:features' then
  539. begin
  540. ParsingFeatures(tag);
  541. end else
  542. if tag.Name='proceed' then
  543. begin
  544. // start ssl connection..
  545. FSocket.DoOpenSSL;
  546. end else
  547. if tag.Name='challenge' then
  548. begin
  549. if FMD5 then begin
  550. if FMD5Step=0 then
  551. SendMD5Response(tag)
  552. else
  553. SendCommand('<response xmlns="'+XMLNS_SASL+'"/>');
  554. end else
  555. if FCramMD5 then begin
  556. if FCramMD5Step=0 then
  557. SendCramMD5Response(tag)
  558. else
  559. SendCommand('<response xmlns="'+XMLNS_SASL+'"/>');
  560. end;
  561. end else
  562. if tag.Name='success' then
  563. begin
  564. FAuthd := True;
  565. SendXMPPHeader(FCurServer);
  566. end else
  567. if tag.Name='failure' then
  568. begin
  569. // phew..
  570. if FMD5 then begin
  571. FMD5 := False;
  572. if FCramMD5 then
  573. SendCramMD5Auth
  574. else
  575. if FPLAIN then
  576. SendPLAINAuth;
  577. end else
  578. if FCramMD5 then begin
  579. FCramMD5 := False;
  580. if FPLAIN then
  581. SendPLAINAuth;
  582. end else
  583. if FPLAIN then
  584. FPLAIN := False;
  585.  
  586.  
  587. if (not FMD5) and (not FCramMD5) and
  588. (not FPLAIN) then
  589. begin
  590. if tag.ChildCount>0 then
  591. s := tag.ChildTags[0].Name;
  592.  
  593. DoError('Failure: '+s);
  594. Logout;
  595. end;
  596.  
  597. end else
  598.  
  599. // stanzas
  600. if tag.Name='iq' then
  601. begin
  602. ParsingIQ(tag);
  603. end else
  604. if tag.Name='presence' then
  605. begin
  606. ParsingPresence(tag);
  607. end else
  608. if tag.Name='message' then
  609. begin
  610. ParsingMessage(tag);
  611. end;
  612. end;
  613.  
  614. procedure TXmpp.ParsingFeatures(tag: TXMLTag);
  615. var
  616. x:TXMLTag;
  617. tl:TXMLTagList;
  618. st:TStringList;
  619. i:integer;
  620. begin
  621. if FAuthd and (not FSessAuth) then
  622. begin
  623. BindingResource;
  624. end else
  625. if (not FAuthd) and (not FSessAuth) then
  626. begin
  627. if tag.TagExists('starttls') then
  628. begin
  629. SendCommand('<starttls xmlns="'+XMLNS_TLS+'"/>');
  630. Exit;
  631. end;
  632.  
  633. if tag.TagExists('mechanisms') then
  634. begin
  635. x := tag.GetFirstTag('mechanisms');
  636. tl := x.ChildTags;
  637. st := TStringList.Create;
  638. try
  639. for i:=0 to tl.Count-1 do
  640. st.Add(tl[i].Data);
  641. FMD5 := (st.IndexOf('DIGEST-MD5')<>-1);
  642. FCramMD5 := (st.IndexOf('CRAM-MD5')<>-1);
  643. FPLAIN:= (st.IndexOf('PLAIN')<>-1);
  644. finally
  645. st.Free;
  646. tl.Free;
  647. end;
  648. end;
  649.  
  650. if tag.TagExists('compression') then
  651. begin
  652. // TODO
  653. end;
  654.  
  655. // what a mess...
  656. if FMD5 then
  657. SendMD5Auth
  658. else
  659. if FCramMD5 then
  660. SendCramMD5Auth
  661. else
  662. if FPLAIN then
  663. SendPLAINAuth
  664. else
  665. DoError('SASL authentication failed!');
  666.  
  667. end; // not FSessAuth
  668.  
  669. end;
  670.  
  671. procedure TXmpp.BindingResource;
  672. var
  673. x,p:TXMLTag;
  674. begin
  675. x := TXMLTag.Create('iq');
  676. try
  677. x.SetAttribute('type','set');
  678. x.SetAttribute('id',GenerateID);
  679. p := x.AddTagNS('bind',XMLNS_BIND);
  680. p.AddBasicTag('resource',FResource);
  681. SendCommand(x.XML);
  682. finally
  683. x.Free;
  684. end;
  685. end;
  686.  
  687. procedure TXmpp.BindingSession;
  688. var s:string;
  689. begin
  690. s := '<iq type="set" id="'+GenerateID+'"><session xmlns="'+XMLNS_SESS+'"/></iq>';
  691. SendCommand(s);
  692. end;
  693.  
  694. procedure TXmpp.SendAuth(AuthMethod:string);
  695. begin
  696. SendCommand('<auth xmlns="'+XMLNS_SASL+'" mechanism="'+AuthMethod+'" xmlns:ga="'+
  697. XMLNS_GOOG+'" ga:client-uses-full-bind-result="true"></auth>');
  698. end;
  699.  
  700. procedure TXmpp.SendMD5Auth;
  701. begin
  702. SendAuth('DIGEST-MD5');
  703. // SendCommand('<auth xmlns="'+XMLNS_SASL+'" mechanism="DIGEST-MD5" xmlns:ga=""/>');
  704. end;
  705.  
  706. procedure TXmpp.SendMD5Response(tag: TXMLTag);
  707. var
  708. c,resp,s:string;
  709. begin
  710. c := tag.Data;
  711. if c<>'' then begin
  712. s := '<response xmlns="'+XMLNS_SASL+'">';
  713. resp := SASLDigestMD5(c,FUser,FPass,FCurServer);
  714. s := s + resp+'</response>';
  715. FMD5Step := 1;
  716. SendCommand(s);
  717. end else
  718. DoError('SASL/DIGEST-MD5 authentication failed!');
  719. end;
  720.  
  721. procedure TXmpp.SendCramMD5Auth;
  722. begin
  723. SendAuth('CRAM-MD5');
  724. // SendCommand('<auth xmlns="'+XMLNS_SASL+'" mechanism="CRAM-MD5"/>');
  725. end;
  726.  
  727. procedure TXmpp.SendCramMD5Response(tag: TXMLTag);
  728. var
  729. c,resp,s:string;
  730. begin
  731. c := tag.Data;
  732. if c<>'' then begin
  733. s := '<response xmlns="'+XMLNS_SASL+'">';
  734. resp := SASLCramMD5(c,FUser,FPass);
  735. s := s + resp+'</response>';
  736. FCramMD5Step := 1;
  737. SendCommand(s);
  738. end else
  739. DoError('SASL/CRAM-MD5 authentication failed!');
  740. end;
  741.  
  742. procedure TXmpp.SendPLAINAuth;
  743. var
  744. s,buf:string;
  745. begin
  746. buf := SASLPlain(FUser,FPass);
  747. // googletalk
  748. // <auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='PLAIN'
  749. // xmlns:ga='http://www.google.com/talk/protocol/auth' ga:client-uses-full-bind-result='true'>bla..bla..</auth>
  750. s := '<auth xmlns="'+XMLNS_SASL+'" mechanism="PLAIN" xmlns:ga="'+
  751. XMLNS_GOOG+'" ga:client-uses-full-bind-result="true">'+buf+'</auth>';
  752. SendCommand(s);
  753. end;
  754.  
  755. function TXmpp.GenerateID: string;
  756. begin
  757. Inc(FMYID);
  758. FCurrentID := Format('%8.8d', [FMYID]);
  759. Result := FCurrentID;
  760. end;
  761.  
  762. function TXmpp.GetJID: string;
  763. begin
  764. Result := SeparateLeft(FJID,'/');
  765. end;
  766.  
  767. procedure TXmpp.IQBeforeLoggedIn(tag: TXMLTag);
  768. var p:TXMLTag;
  769. begin
  770. if tag.TagExists('bind') then
  771. begin
  772. p := tag.GetFirstTag('bind');
  773. FJID := p.GetBasicText('jid');
  774. BindingSession;
  775. end else
  776. // if tag.TagExists('session') then
  777. begin
  778. FSessAuth := True;
  779. //<iq type='get' id='purple2fd60f4d' to='ichthus-desktop'>
  780. //<query xmlns='http://jabber.org/protocol/disco#items'/></iq>
  781. SendCommand('<iq type="get" id="'+GenerateID+'" to="'+FCurServer+'">'+
  782. '<query xmlns="'+XMLNS_DISCO+'#items"/></iq>');
  783. SendCommand('<iq type="get" id="'+GenerateID+'" to="'+FCurServer+'">'+
  784. '<query xmlns="'+XMLNS_DISCO+'#info"/></iq>');
  785. end;
  786. end;
  787.  
  788. procedure TXmpp.ParsingIQ(tag: TXMLTag);
  789. var
  790. ty,iqid,iqfr,
  791. iqty,iqvar,
  792. trid:string;
  793. q,qi:TXMLTag;
  794. i:integer;
  795. begin
  796. trid := tag.GetAttribute('id');
  797. ty := tag.GetAttribute('type');
  798. if (ty='result') then
  799. begin
  800. if (not FSessAuth) then
  801. begin
  802. IQBeforeLoggedIn(tag);
  803. Exit; //
  804. end;
  805.  
  806. iqfr := tag.GetAttribute('from');
  807. q := tag.GetFirstTag('query');
  808. if (q<>nil) then begin
  809. if (q.Namespace=XMLNS_DISCO+'#items') then
  810. begin
  811. for i:=0 to q.ChildCount-1 do
  812. begin
  813. qi := q.ChildTags.Tags[i];
  814. if (qi.Name='item') then begin
  815. //<iq type='get' id='purple2fd60f4f' to='conference.ichthus-desktop'>
  816. //<query xmlns='http://jabber.org/protocol/disco#info'/></iq>
  817. iqid := qi.GetAttribute('jid');
  818. if (iqid<>'') then
  819. begin
  820. if (iqfr=FCurServer) then begin
  821. SendCommand('<iq type="get" id="'+GenerateID+'" to="'+iqid+'">'+
  822. '<query xmlns="'+XMLNS_DISCO+'#info"/></iq>');
  823. end else
  824. if (iqfr=FConference) then begin
  825. if Assigned(OnRoomList) then
  826. FOnRoomList(Self,TrimSPRight(SeparateLeft(qi.GetAttribute('name'),'(')));
  827. end; // room list
  828.  
  829. end;
  830. end;
  831. end;
  832. end else // disco#items
  833.  
  834. if (q.Namespace=XMLNS_DISCO+'#info') then
  835. begin
  836. for i:=0 to q.ChildCount-1 do
  837. begin
  838. qi := q.ChildTags.Tags[i];
  839. if (qi.Name='identity') then
  840. begin
  841. iqid := qi.GetAttribute('category');
  842. iqty := qi.GetAttribute('type');
  843.  
  844. // jabber chat room
  845. if (iqid='conference') and (iqty='text') then
  846. begin
  847. FConference := iqfr;
  848. // assume "Anyone can create a chat room" for now :p
  849.  
  850. end else // conference
  851. if (iqid='server') then
  852. begin
  853. // servername, servertype
  854. end else // server
  855. if (iqid='pubsub') then
  856. begin
  857. //
  858. end; // pubsub
  859. end else // qi.name
  860. if (qi.Name='feature') then
  861. begin
  862. // TODO
  863. iqvar := qi.GetAttribute('var');
  864. // activating keepalive..
  865. if (iqvar='urn:xmpp:ping') then
  866. begin
  867. FTimer.Enabled := True;
  868. end else
  869. if (iqvar=XMLNS_ROSTER) then
  870. begin
  871. //SendCommand('<iq type="get" id="'+GenerateID+'"><query xmlns="'+XMLNS_ROSTER+'"/></iq>');
  872. end;
  873. end;
  874. end; // loop
  875.  
  876. end else // disco#info
  877.  
  878. if (q.Namespace=XMLNS_ROSTER) then
  879. begin
  880.  
  881. ParsingIQRoster(q);
  882.  
  883. // set presence
  884. if not FPresenceSet then
  885. begin
  886. FPresenceSet := True;
  887. //SendCommand('<presence></presence>');
  888. SendCommand('<presence xml:lang="en"><show>chat</show><status></status></presence>');
  889. if Assigned(OnLogin) then FOnLogin(Self);
  890. end;
  891.  
  892.  
  893. end; // roster
  894.  
  895. if not FPresenceSet then
  896. if FCurrentID=trid then
  897. SendCommand('<iq type="get" id="'+GenerateID+'"><query xmlns="'+XMLNS_ROSTER+'"/></iq>');
  898.  
  899. end; // q<>nil
  900.  
  901. end;
  902. end;
  903.  
  904. // exodus
  905. function JabberToDateTime(datestr: string): TDateTime;
  906. var
  907. rdate: TDateTime;
  908. ys, ms, ds, ts: string;
  909. yw, mw, dw: Word;
  910. begin
  911. // Converts assumed UTC time to local.
  912. // translate date from 20000110T19:54:00 to proper format..
  913. ys := Copy(Datestr, 1, 4);
  914. ms := Copy(Datestr, 5, 2);
  915. ds := Copy(Datestr, 7, 2);
  916. ts := Copy(Datestr, 10, 8);
  917.  
  918. try
  919. yw := StrToInt(ys);
  920. mw := StrToInt(ms);
  921. dw := StrToInt(ds);
  922.  
  923. if (TryEncodeDate(yw, mw, dw, rdate)) then begin
  924. rdate := rdate + StrToTime(ts);
  925. Result := rdate - TimeZoneBias(); // Convert to local time
  926. end
  927. else
  928. Result := Now();
  929. except
  930. Result := Now;
  931. end;
  932. end;
  933.  
  934. function RightStr(AText: String; ACount: Integer): string;
  935. begin
  936. Result := Copy(AText, Length(AText) + 1 - ACount, ACount);
  937. end;
  938.  
  939. function LeftStr(AText: String; ACount: Integer): String;
  940. begin
  941. Result := Copy(AText, 1, ACount);
  942. end;
  943.  
  944. function IncHour(const AValue: TDateTime;
  945. const ANumberOfHours: Int64): TDateTime;
  946. begin
  947. Result := ((AValue * HoursPerDay) + ANumberOfHours) / HoursPerDay;
  948. end;
  949.  
  950. function IncMinute(const AValue: TDateTime;
  951. const ANumberOfMinutes: Int64): TDateTime;
  952. begin
  953. Result := ((AValue * MinsPerDay) + ANumberOfMinutes) / MinsPerDay;
  954. end;
  955. // exodus
  956. function XEP82DateTimeToDateTime(datestr: string): TDateTime;
  957. var
  958. rdate: TDateTime;
  959. ys, ms, ds, ts: string;
  960. yw, mw, dw: Word;
  961. tzd: string;
  962. tzd_hs: string;
  963. tzd_ms: string;
  964. tzd_hw: word;
  965. tzd_mw: word;
  966. begin
  967. // Converts UTC or TZD time to Local Time
  968. // translate date from 2008-06-11T10:10:23.102Z (2008-06-11T10:10:23.102-06:00) or to properformat
  969. Result := Now();
  970.  
  971. datestr := Trim(datestr);
  972. if (Length(datestr) = 0) then exit;
  973.  
  974. ys := Copy(datestr, 1, 4);
  975. ms := Copy(datestr, 6, 2);
  976. ds := Copy(datestr, 9, 2);
  977. ts := Copy(datestr, 12, 8);
  978.  
  979. if (RightStr(datestr, 1) = 'Z') then
  980. begin
  981. // Is UTC
  982. try
  983. yw := StrToInt(ys);
  984. mw := StrToInt(ms);
  985. dw := StrToInt(ds);
  986.  
  987. if (TryEncodeDate(yw, mw, dw, rdate)) then begin
  988. rdate := rdate + StrToTime(ts);
  989. Result := rdate - TimeZoneBias(); // Convert to local time
  990. end
  991. else
  992. Result := Now();
  993. except
  994. Result := Now;
  995. end;
  996. end
  997. else begin
  998. // Is not UTC so convert to UTC
  999. tzd := Copy(datestr, Length(datestr) - 5, 6);
  1000. tzd_hs := Copy(tzd, 2, 2);
  1001. tzd_ms := Copy(tzd, 5, 2);
  1002.  
  1003. try
  1004. yw := StrToInt(ys);
  1005. mw := StrToInt(ms);
  1006. dw := StrToInt(ds);
  1007. tzd_hw := StrToInt(tzd_hs);
  1008. tzd_mw := StrToInt(tzd_ms);
  1009.  
  1010. if (TryEncodeDate(yw, mw, dw, rdate)) then
  1011. begin
  1012. rdate := rdate + StrToTime(ts);
  1013. // modify time for TZD offset.
  1014. if (LeftStr(tzd, 1) = '+') then
  1015. begin
  1016. // Time is greater then UTC so subtract time
  1017. rdate := IncHour(rdate, (-1 * tzd_hw));
  1018. rdate := IncMinute(rdate, (-1 * tzd_mw));
  1019. end
  1020. else begin
  1021. // Time is less then UTC so add time
  1022. rdate := IncHour(rdate, tzd_hw);
  1023. rdate := IncMinute(rdate, tzd_mw);
  1024. end;
  1025.  
  1026. // Now that we have UTC, change ot local
  1027. Result := rdate - TimeZoneBias();
  1028. end
  1029. else begin
  1030. Result := Now();
  1031. end;
  1032. except
  1033. Result := Now();
  1034. end;
  1035. end;
  1036.  
  1037. end;
  1038.  
  1039. procedure TXmpp.ParsingMessage(tag: TXMLTag);
  1040. var
  1041. p,x,d:TXMLTag;
  1042. mf,mt,mb,mh,
  1043. fr,ty,_ts:string;
  1044. _time:TDateTime;
  1045. begin
  1046. _time := Now;
  1047. mt := tag.GetAttribute('to');
  1048. if Pos(mt,FJID)=0 then
  1049. Exit;
  1050.  
  1051. ty := tag.GetAttribute('type');
  1052. fr := tag.GetAttribute('from');
  1053.  
  1054. p := tag.GetFirstTag('body');
  1055. if (p<>nil) then
  1056. mb := p.Data;
  1057. x := tag.GetFirstTag('html');
  1058. if (x<>nil) then
  1059. mh := x.XML;
  1060.  
  1061. // room chat message
  1062. if (ty='groupchat') then //and (Pos(FRoomName,fr)>0) then
  1063. begin
  1064. mf := SeparateRight(fr,'/');
  1065. if mf=fr then Exit;
  1066. mf := GetRosterRoomJID(mf);
  1067. if p<>nil then
  1068. if Assigned(OnMessage) then
  1069. FOnChat(Self,mf,mb,mh,_time,mtRoom);
  1070. end else
  1071. // personal chat message
  1072. if (ty='chat') then
  1073. begin
  1074. if p=nil then Exit;
  1075.  
  1076. d := nil;
  1077. if tag.TagExists('x') then
  1078. d := tag.GetFirstTag('x')
  1079. else
  1080. if tag.TagExists('delay') then
  1081. d := tag.GetFirstTag('delay');
  1082.  
  1083. if (d<>nil) then begin
  1084. _ts := tag.GetAttribute('stamp');
  1085. if (d.Namespace=XMLNS_DELAY) or (d.Namespace=XMLNS_DELAY_203) then
  1086. _time := XEP82DateTimeToDateTime(_ts) //JabberToDateTime(_ts)
  1087. end;
  1088. if Assigned(OnMessage) then
  1089. FOnChat(Self,fr,mb,mh,_time,mtPersonal);
  1090. end;
  1091.  
  1092. {
  1093.   if tag.TagExists('body') and
  1094.   (tag.GetAttribute('type')='chat') then
  1095.   begin
  1096.  
  1097.   x := tag.GetFirstTag('x');
  1098.   if (x<>nil) and (x.Namespace=XMLNS_EVENT) then
  1099.   FMsgComposing := x.TagExists('composing');
  1100.  
  1101.   mt := tag.GetAttribute('to');
  1102.   if Pos(GetJID,mt)>0 then
  1103.   begin
  1104.   mf := tag.GetAttribute('from');
  1105.   dt := tag.GetFirstTag('body').Data;
  1106.   p := tag.GetFirstTag('html');
  1107.   mh := p.XML;
  1108.  
  1109.   if Assigned(OnMessage) then
  1110.   FOnChat(Self,mf,dt,mh);
  1111.   end;
  1112.   end;
  1113. }
  1114. end;
  1115.  
  1116. { later...
  1117. function DecodeShowDisplayValue(show: string): string;
  1118. begin
  1119.   if (show = '') then
  1120.   result := 'Available'
  1121.   else if (show = 'chat') then
  1122.   result := 'Free to Chat'
  1123.   else if (show = 'away') then
  1124.   result := 'Away'
  1125.   else if (show = 'xa') then
  1126.   result := 'Extended Away'
  1127.   else if (show = 'dnd') then
  1128.   result := 'Do not Disturb'
  1129.   else
  1130.   result := show;
  1131. end;
  1132. }
  1133.  
  1134. procedure TXmpp.ParsingPresence(tag: TXMLTag);
  1135. var
  1136. p,x:TXMLTag;
  1137. pf,pty,
  1138. pid:string;
  1139. begin
  1140. pf := tag.GetAttribute('from');
  1141. pty:= tag.GetAttribute('type');
  1142.  
  1143. if pty='error' then
  1144. Exit;
  1145.  
  1146. // room presence
  1147. if Pos(FRoomName,pf)>0 then
  1148. begin
  1149. //s := SeparateRight(pf,'/');
  1150. //if (s<>FUser) then
  1151. //begin
  1152. p := tag.GetFirstTag('x');
  1153. if (p<>nil) then begin
  1154. x := p.GetFirstTag('item');
  1155. if (x<>nil) then begin
  1156. pid := x.GetAttribute('jid');
  1157. if pty='unavailable' then
  1158. begin
  1159. if Pos(pid,FJID)>0 then
  1160. FRoomName := '';
  1161.  
  1162. RemoveFromRosterRoom(pid);
  1163. end else
  1164. begin
  1165. //if Pos(pid,FJID)=0 then
  1166. AddToRosterRoom(pid);
  1167. end;
  1168. end;
  1169. end;// p<>nil
  1170. //end;
  1171. end else
  1172. begin
  1173.  
  1174. end;
  1175. end;
  1176.  
  1177. function TXmpp.IsInRosterRoom(JID: string): Boolean;
  1178. var i:integer;
  1179. begin
  1180. Result := False;
  1181. for i:=0 to FRoomRoster.Count-1 do begin
  1182. if (FRoomRoster[i]=JID) then
  1183. begin
  1184. Result := True;
  1185. Break;
  1186. end;
  1187. end;
  1188. end;
  1189.  
  1190. procedure TXmpp.RemoveFromRosterRoom(JID: string);
  1191. var i:integer;
  1192. begin
  1193. if not IsInRosterRoom(JID) then
  1194. Exit;
  1195. for i:=0 to FRoomRoster.Count-1 do
  1196. begin
  1197. if (FRoomRoster[i]=JID) then
  1198. begin
  1199. FRoomRoster.Delete(i);
  1200. Break;
  1201. end;
  1202. end;
  1203. if Assigned(OnUserLeftRoom) then
  1204. FOnLeftRoom(Self,JID);
  1205. end;
  1206.  
  1207. procedure TXmpp.JoinRoom(RoomName: string);
  1208. begin
  1209. if (not FSessAuth) or (RoomName='') then
  1210. Exit;
  1211.  
  1212. // only one room
  1213. if (FRoomName<>'') then begin
  1214. DoError('Only one room/session');
  1215. Exit;
  1216. end;
  1217.  
  1218. FRoomName := SeparateLeft(RoomName,'@');
  1219. FRoomName := FRoomName+'@'+FConference;
  1220.  
  1221. SendCommand('<presence from="'+GetJID+'" to="'+
  1222. FRoomName+'/'+FUser+'"/>');
  1223. end;
  1224.  
  1225. procedure TXmpp.AddToRosterRoom(JID: string);
  1226. begin
  1227. if not IsInRosterRoom(JID) then
  1228. begin
  1229. FRoomRoster.Add(JID);
  1230. if Assigned(OnUserJoinedRoom) then
  1231. FOnJoinedRoom(Self,JID);
  1232. end;
  1233. end;
  1234.  
  1235. function TXmpp.GetRosterRoomJID(JID: string): string;
  1236. var i:integer;
  1237. begin
  1238. Result := '';
  1239. for i:=0 to FRoomRoster.Count-1 do begin
  1240. if (SeparateLeft(FRoomRoster[i],'@')=JID) then
  1241. begin
  1242. Result := FRoomRoster[i];
  1243. Break;
  1244. end;
  1245. end;
  1246. end;
  1247.  
  1248. procedure TXmpp.LeaveRoom;
  1249. begin
  1250. if FRoomName='' then
  1251. Exit;
  1252. SendCommand('<presence to="'+FRoomName+'/'+FUser+'" type="unavailable"/>');
  1253. end;
  1254.  
  1255. procedure TXmpp.DoOnTimer(Sender: TObject);
  1256. begin
  1257. FTimer.Enabled := False;
  1258. if not FSessAuth then
  1259. Exit;
  1260. //<iq type='get' id='purplef5537fcf'><ping xmlns='urn:xmpp:ping'/></iq>
  1261. SendCommand('<iq type="get" id="'+GenerateID+'"><ping xmlns="urn:xmpp:ping"/></iq>');
  1262. FTimer.Enabled := True;
  1263. end;
  1264.  
  1265. procedure TXmpp.GetRoomList;
  1266. begin
  1267. if (FConference='') then
  1268. Exit;
  1269. SendCommand('<iq type="get" id="'+GenerateID+'" to="'+FConference+'">'+
  1270. '<query xmlns="'+XMLNS_DISCO+'#items"/></iq>');
  1271. end;
  1272.  
  1273. function TXmpp.GenerateMSGID: string;
  1274. begin
  1275. Inc(FMSGID);
  1276. Result := 'msg'+Format('%5.5d', [FMSGID]);
  1277. end;
  1278.  
  1279. procedure TXmpp.SendChatMessage(ToJID, MsgText, MsgHtml: string;
  1280. MsgType: TMessageType);
  1281. var s:string;
  1282. x,b,h:TXMLtag;
  1283. begin
  1284. if (not FSessAuth) then
  1285. Exit;
  1286.  
  1287. x := TXMLTag.Create('message');
  1288. try
  1289. x.SetAttribute('from',FJID);
  1290. x.SetAttribute('id',GenerateMSGID);
  1291. x.SetAttribute('to',ToJID);
  1292.  
  1293. case MsgType of
  1294. mtRoom: x.SetAttribute('type','groupchat');
  1295. mtPersonal: x.SetAttribute('type','chat');
  1296. end;
  1297.  
  1298. b := x.AddTag('body');
  1299. b.AddCData(MsgText);
  1300. h := x.AddTagNS('html',XML_XHTMLIM);
  1301. h.AddTagNS('body',XML_XHTML);
  1302. h.AddCData(MsgHtml);
  1303. s := x.XML;
  1304. finally
  1305. x.Free;
  1306. end;
  1307. SendCommand(s);
  1308. end;
  1309.  
  1310. procedure TXmpp.SendPersonalMessage(ToJID, MsgText: string);
  1311. begin
  1312. SendChatMessage(ToJID,MsgText,MsgText,mtPersonal);
  1313. end;
  1314.  
  1315. procedure TXmpp.SendRoomMessage(MsgText: string);
  1316. begin
  1317. if FRoomName='' then
  1318. Exit; // ignore silently
  1319. SendChatMessage(FRoomName,MsgText,MsgText,mtRoom);
  1320. end;
  1321.  
  1322. procedure TXmpp.ParsingIQRoster(tag:TXMLTag);
  1323. var
  1324. _jid,_name,_subscription,_group:string;
  1325. i:integer;
  1326. x:TXMLTag;
  1327. begin
  1328. for i:=0 to tag.ChildTags.Count-1 do begin
  1329. x := tag.ChildTags[i];
  1330. _jid := x.GetAttribute('jid');
  1331. _name:= x.GetAttribute('name');
  1332. _subscription := x.GetAttribute('subscription');
  1333. _group := x.GetBasicText('group');
  1334.  
  1335. if Assigned(OnRoster) then
  1336. FOnRoster(Self,_jid,_name,_subscription,_group);
  1337. end;
  1338. end;
  1339.  
  1340. end.

Ссылка на данный код:

На главную страницу сервиса обмена кодом »