unitmain.pas

Delphi版飞信源代码 用Delphi实现飞信功能

unit UnitMain;

interface

uses
  UnitSHA1, UnitMd5, IniFiles, SHFolder, EncdDecd, IdZLibCompressorBase,
{$IFDEF UNICODE}IdCompressorZLib, {$ELSE}IdCompressorZLibEx, {$ENDIF}
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, IdTCPConnection, IdTCPClient, IdCookieManager,
  IdHTTP, StdCtrls, IEHTTP3, IdHashMessageDigest, IdGlobal, IdHash, xmldom,
  XMLIntf, msxmldom, XMLDoc, Buttons, ExtCtrls, ComCtrls, jpeg, IdBaseComponent,
  IdComponent;

{$IFNDEF UNICODE}
type
  RawByteString = AnsiString;
{$ENDIF}

const
  FORM_CAPTION = 'GreenFetion V0.22';

  LOGON_REQUEST_INVITE = 'fetion.com.cn SIP-C/2.0';
  LOGON_REQUEST_ARG = '<args><device type="PC" version="33" client-version="3.3.0370" />' +
    '<caps value="simple-im;im-session;temp-group;personal-group" /><events value="contact;permission;system-message;personal-group" /><user-info attributes="all" /><presence><basic value="400" desc="" /></presence></args>';
  LOGON_GETCONTACTLIST_ARG = '<args><contacts><buddy-lists /><buddies attributes="all" /><mobile-buddies attributes="all" /><chat-friends /><blacklist /></contacts></args>';
  LOGON_GETCONTACTINFO_ARG = '<args><contacts attributes="provisioning;impresa;mobile-no;nickname;name;gender;portrait-crc;ivr-enabled" extended-attributes="score-level">'; //<contact uri="sip:[e-mail];p=9805" version="12" /></contacts></args>';

//  SALT = #$77+#$7A+#$6D+#$03;
var
//  SALT : array[1..4] of ansichar; // = #$FD + #$A5 + ansichar(#$E5) + #$01;
//  SALT : array[0..3] of byte = ($FD, $A5, $E5, $01);
  SALT: array[0..3] of byte = ($A8, $4C, $BF, $00);

const
  MSG_FONT_SIZE = 10;
  MSG_FONT_COLOR = clBlack;
  SYSMSG_FONT_SIZE = 8;
  SYSMSG_FONT_COLOR = clGreen;

type
  // 用户信息
  TUserInfo = record
    Sid: string; // 飞信标识
    IsFetionUser: Boolean;
    Name, NickName, LocalName, MobileNum: string;
    Nation, Province, City: string;
    Group: Integer;
  end;

  // 联系人列表管理
  TContactList = class
  private
    FUserList: array of TUserInfo;
    function GetCount: Integer;
    function GetItem(itemIndex: Integer): TUserInfo;
    function GetUserName(itemIndex: Integer): string;
  public
    procedure Clear;
    procedure AddUser(aSid, aLocalName: string; IsFetionUser: Boolean; aGroup: Integer; aMobileNum: string = ''; aNickName: string = ''; aName: string = '');
    procedure UpdateUserNickName(aSid, aNickName, aName, aMobileNum: string);
    function GetUserSidByName(aName: string): string;
  public
    property Count: Integer read GetCount;
    property Items[itemIndex: Integer]: TUserInfo read GetItem;
    property UserName[itemIndex: Integer]: string read GetUserName;
  end;

  TFormMain = class(TForm)
    IdTCPClient1: TIdTCPClient;
    reLogMsg: TRichEdit;
    Panel1: TPanel;
    Panel2: TPanel;
    mmMsg: TMemo;
    btSendMsg: TBitBtn;
    Label1: TLabel;
    cbContactList: TComboBox;
    tmRegister: TTimer;
    IdHTTP1: TIdHTTP;
    Panel3: TPanel;
    Image1: TImage;
    Label2: TLabel;
    btAddContact: TBitBtn;
    btRefreshContactList: TBitBtn;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure btSendMsgClick(Sender: TObject);
    procedure tmRegisterTimer(Sender: TObject);
    procedure Label2Click(Sender: TObject);
    procedure btAddContactClick(Sender: TObject);
    procedure btRefreshContactListClick(Sender: TObject);
  private
    { Private declarations }
    XMLReader: TXMLDocument;

    FPhoneNum: string;
    FPassWord: string;
    FNickName: string;
    FSSIC: string;
    FUserURI: string; // 用户飞信标识
    FUserSid: string; // 飞信号
    FDomain: string; // 飞信标识中的域名
    FSalt: string;
    FNonce: string;
    FCNonce: string;

    FSIPCServer: string;
    FSIPCPort: Integer;
    FSSISignInURL: string;
    FGetUriURL: string;

    FContactList: TContactList;

    FCall: Integer;
    FRegisterCount: Integer;
    function GetNextCall: Integer;
    function GetNextRegisterCount: Integer;
    function BuildSIPRequest(Cmd: string; fields: array of string;
      arg: string; CmdTryCount: Integer = 1): string;
    function GetSIPResponse(Cmd: string; var ResponseMsg: string): Boolean;

    function hash_password(pwd: string): string;
    function calc_salt(pwd: string): string;
    function calc_cnonce: string;
    function calc_response(sid, domain, pwd, nonce, cnonce: string): string;
    function build_reponse_A: string;

    function SendMessage(uri, msg: string): Boolean;
    procedure RetrivePersonalInfo; // 获取自己的信息
    procedure RetriveContractInfo(aSubscribeResponse: string); // 从预定信息回复中获取某联系人信息
    procedure RetriveContractList;
    procedure RefreshContactList;
    function AddContact(aURI: string; aMsg: string): boolean; //  添加联系人，返回新添加的联系人的信息

    procedure AddLogMsg(msg: string; FontColor: TColor);
    procedure AddSysMsg(msg: string; FontColor: TColor);

    function SocketReadLn: string;
    function SocketReadString(aStrLen: integer): string;
    procedure SocketWrite(aStr: string);

    function ReadUserConfig(aUserPhoneNum: string): boolean;
    function WriteUserConfig(aUserPhoneNum: string; Update: Boolean = True): boolean;
    procedure InitConfigFromFetion; // 从飞信配置文件读用户登录服务器IP信息
  public
    { Public declarations }

    function Login(PhoneNum, Password: string): Boolean;
    function RetriveUserInfo(aURI: string): TUserInfo; // 获取指定用户的信息
    function RetriveURIFromUID(aUid: string): string; // 获取指定飞信号对应的URI
  end;

var
  FormMain: TFormMain;

implementation

{$R *.dfm}

uses UnitLogin, About, UnitAddContact;

function GetSubStringBetween(aString, beginstr, endstr: string): string;
var Len, index, beginPos: Integer;
begin
  Len := 0;
  if Pos(beginstr, aString) <= 0 then
    Exit;
  if Pos(endstr, aString) <= 0 then
    Exit;

  beginPos := Pos(beginstr, aString) + Length(beginstr);
  index := beginPos;
  while aString[index] <> endstr[1] do
  begin
    Inc(index);
    Inc(Len);
  end;
  Result := Copy(aString, beginPos, Len);
end;

function TFormMain.AddContact(aURI: string; aMsg: string): boolean;
var ResponseMsg: string;

  procedure ShowNodeInfo(aNode: IXMLNode; IsFetionUser: boolean);
  var uri, localName: string;
    group: Integer;
  begin
    if aNode = nil then
      Exit;
    uri := '';
    localName := '';
    group := 0;
    if aNode.HasAttribute('uri') then
      uri := aNode.Attributes['uri'];
    if aNode.HasAttribute('local-name') then
      localName := aNode.Attributes['local-name'];
    if aNode.HasAttribute('buddy-lists') then
      group := aNode.Attributes['buddy-lists'];
    if uri <> '' then
      FContactList.AddUser(uri, localName, IsFetionUser, group);
  end;
  procedure ExploreNode(aNode: IXMLNode);
  var I, J: Integer;
  begin
    if aNode.NodeName = 'buddy' then
      ShowNodeInfo(aNode, True);
    if aNode.NodeName = 'mobile-buddy' then
      ShowNodeInfo(aNode, False);

    for I := 0 to aNode.ChildNodes.Count - 1 do
    begin
      ExploreNode(aNode.ChildNodes[I]);
    end;
  end;
begin
  Result := False;
  if not IdTCPClient1.Connected then
    Exit;

  SocketWrite(BuildSIPRequest('S', ['N: AddBuddy'],
    '<args><contacts><buddies><buddy uri="' + aUri + '" buddy-lists="1" desc="' + aMsg + '" expose-mobile-no="1" expose-name="1" /></buddies></contacts></args>'));
  if GetSIPResponse('S', ResponseMsg) then
  begin
    Result := True;
    Exit;
  end;

  // 添加联系人不成功则尝试按手机号码添加联系人
  SocketWrite(BuildSIPRequest('S', ['N: AddMobileBuddy'],
    '<args><contacts><mobile-buddies><mobile-buddy uri="' + aUri + '" buddy-lists="1" desc="' + aMsg + '" invite="1" /></mobile-buddies></contacts></args>'));
  if GetSIPResponse('S', ResponseMsg) then
  begin
    Result := True;
    Exit;
  end;
end;

procedure TFormMain.AddLogMsg(msg: string; FontColor: TColor);
var
  P: Integer;
begin
  P := Length(reLogMsg.Text); //Keep Append Position
  with reLogMsg do
  begin
    Lines.Add(msg);
    Lines.Add('--------------------');
    SelStart := P;
    SelLength := Length(reLogMsg.Text) - P;
    SelAttributes.Color := FontColor;
    SelAttributes.Size := MSG_FONT_SIZE;
  end;
  Windows.SendMessage(reLogMsg.Handle, WM_VSCROLL, SB_BOTTOM, 0);
end;

procedure TFormMain.AddSysMsg(msg: string; FontColor: TColor);
var
  P: Integer;
begin
  P := Length(reLogMsg.Text); //Keep Append Position
  with reLogMsg do
  begin
    Lines.Add('【系统提示】:' + msg);
    SelStart := P;
    SelLength := Length(reLogMsg.Text) - P;
    SelAttributes.Color := FontColor;
    SelAttributes.Size := SYSMSG_FONT_SIZE;
  end;
  Windows.SendMessage(reLogMsg.Handle, WM_VSCROLL, SB_BOTTOM, 0);
end;

procedure TFormMain.btAddContactClick(Sender: TObject);
begin
  FormAddContact.edPSMsg.Text := FNickName;
  if FormAddContact.ShowModal = mrOK then
    if AddContact(FormAddContact.AddUri, FormAddContact.PSMsg) then
      AddSysMsg('添加联系人成功。' + #$0D + #$0A, clGreen)
    else
      AddSysMsg('添加联系人失败。' + #$0D + #$0A, clRed);
end;

procedure TFormMain.btRefreshContactListClick(Sender: TObject);
begin
  RefreshContactList;
end;

procedure TFormMain.btSendMsgClick(Sender: TObject);
begin
  if mmMsg.Text = '' then
    Exit;
  AddLogMsg(mmMsg.Text, clBlack);
  if SendMessage(FContactList.Items[cbContactList.ItemIndex].Sid, mmMsg.Text) then
    AddSysMsg('短信发送完毕！' + #$0D + #$0A, clGreen)
  else
    AddSysMsg('短信发送失败！' + #$0D + #$0A, clRed);
  mmMsg.Clear;

end;

function TFormMain.BuildSIPRequest(Cmd: string; fields: array of string;
  arg: string; CmdTryCount: Integer = 1): string;
var I: Integer;
  UTF8arg: RawByteString;
begin
  Result := Cmd + ' ' + LOGON_REQUEST_INVITE;
  Result := Result + #$D + #$A + 'F: ' + FUserSid;
  if Cmd = 'R' then
  begin
    Result := Result + #$D + #$A + 'I: 1';
  end else
  begin
    if CmdTryCount = 1 then
      Result := Result + #$D + #$A + 'I: ' + IntToStr(GetNextCall())
    else
      Result := Result + #$D + #$A + 'I: ' + IntToStr(FCall);
  end;
  Result := Result + #$D + #$A + 'Q: ' + IntToStr(CmdTryCount) + ' ' + Cmd;
  for I := 0 to Length(fields) - 1 do
    Result := Result + #$D + #$A + fields[I];
  UTF8arg := UTF8Encode(arg);
  if Length(UTF8arg) > 0 then
  begin
    Result := Result + #$D + #$A + 'L: ' + IntToStr(Length(UTF8arg))
      + #$D + #$A + #$D + #$A
      + arg;
  end else
  begin
    Result := Result + #$D + #$A + #$D + #$A;
  end;
end;


function TFormMain.GetSIPResponse(Cmd: string; var ResponseMsg: string): Boolean;
var CmdLine: string;
  // 读取一个完整的SIP响应，并返回SIP响应对应的命令
  function ReadASIPResponse(var SIPMsg: string): string;
  var NewLine, SIPCmd, SubCmd: string;
    tmpIndex: Integer;
    MsgLength: Integer;
  begin
    Result := '';
    MsgLength := 0;
    CmdLine := SocketReadLn(); // SIP 响应头
    if Length(CmdLine) <= 0 then
      Exit;
    repeat
      NewLine := SocketReadLn();
      if Length(NewLine) <= 0 then
        Break;
      if UpperCase(NewLine[1]) = 'Q' then
      begin
          // 提取SIP命令
        tmpIndex := Pos(' ', NewLine);
        tmpIndex := PosIdx(' ', NewLine, tmpIndex + 1);
        Result := Copy(NewLine, tmpIndex + 1, MaxInt);
      end;
      if UpperCase(NewLine[1]) = 'N' then
      begin
          // 提取SIP子命令
        tmpIndex := Pos(' ', NewLine);
        SubCmd := Copy(NewLine, tmpIndex + 1, MaxInt);
      end;
      if UpperCase(NewLine[1]) = 'L' then
      begin
          // 获取SIP消息长度
        tmpIndex := Pos(' ', NewLine);
        MsgLength := StrToIntDef(Copy(NewLine, tmpIndex + 1, MaxInt), 0);
      end;
      if UpperCase(NewLine[1]) = 'W' then
      begin
          // 获取登录认证时服务器提供的Nonce
        FNonce := GetSubStringBetween(NewLine, 'nonce="', '"');
      end;
    until False;

    if MsgLength <= 0 then
      Exit;

    // 读取SIP消息
    SIPMsg := SocketReadString(MsgLength);

    // 获取联系人信息
    if Result = 'BN' then
      if SubCmd = 'contact' then
        RetriveContractInfo(SIPMsg);
  end;
begin
  Result := False;
  ResponseMsg := '';
  try
    // 读取与命令无关的响应
    while ReadASIPResponse(ResponseMsg) <> Cmd do ;

    if Pos('200 OK', CmdLine) > 0 then
      Result := True
    else
      if Pos('280 Send SMS OK', CmdLine) > 0 then
        Result := True;
  except
  end;
end;

function TFormMain.build_reponse_A: string;
begin
  FSalt := calc_salt(FPassWord);
  FCNonce := calc_cnonce;
//  Result := 'Digest algorithm="SHA1-sess",response="'
  Result := 'Digest '
//    + 'algorithm="MD5-sess",'
  + 'algorithm="SHA1-sess",'
    + 'response="' + calc_response(FUserSid, FDomain, FPassWord, FNonce, FCNonce)
    + '",cnonce="' + FCNonce
    + '",salt="' + FSalt
    + '",ssic="' + FSSIC
    + '"';
end;

function TFormMain.hash_password(pwd: string): string;
var
  SHA1Context: TSHA1Context;
  SHA1Digest: TSHA1Digest;
  byteBuf: TBytes;
  r: array[0..256] of byte;
begin
  FillMemory(@r[0], 257, 0);
{$IFDEF UNICODE}
  byteBuf := ToBytes(pwd, Length(pwd));
{$ELSE}
  byteBuf := ToBytes(pwd);
{$ENDIF}

  SHA1Init(SHA1Context);
  SHA1Update(SHA1Context, PAnsiChar(@byteBuf[0]), Length(byteBuf));
  SHA1Final(SHA1Context, SHA1Digest);