msnmessenger.pas

msn控件 可验证 可接受信息 可发送信息 msn8协议 win32

unit MSNMessenger;

interface

uses
  Classes, SysUtils, QDialogs,  ComCtrls, WSocket, MsnSession, MsnConsts,md5,
  shellapi,StrUtils,WinInet, UMsnUtils,UMemberList,QExtCtrls;

type

  CTime = Integer;
  {登陆邮箱的信息}
  TMsnPassportInfo = record
    LoginTime: Integer;
    EmailEnabled: Boolean;
    MemberIdHigh: Integer;
    MemberIdLow: Integer;
    lang_preference: Integer;
    preferredEmail: String;
    country: String;
    PostalCode: String;
    Gender: String;
    Kid: Integer;
    Age: Integer;
    sid: Integer;
    kv: Integer;
    MSPAuth: String;
    ClientIP: String;
    ClientPort: Integer;
    sl: Integer;
  end;

  TMsnStatusChangeEvent = procedure (Sender: TObject; Member: TMsnMember;
    OldStatus: TMsnMemberStatus; NewStatus: TMsnMemberStatus) of Object;
  TMsnGetGroupEvent= procedure (Sender: TObject; Group: TMsnGroup; Index : Integer) of Object;
  TMsnGetMemberEvent = procedure (Sender: TObject; GroupID: Integer; Member: TMsnMember; MemberKind: TGroupChangeKind) of Object;
  TEMailCountAndAliasEvent = procedure (Sender: TObject; MailCount: Integer; Alias: String) of Object;
  TConncetFailError = Procedure (Sender: TObject; Error: Word; Text : WideString = '') of Object;
  TDisConnectEvent = procedure (Sender: TObject) of Object;
  TGroupChangeEvent = Procedure(Sender: TObject; Group: TMsnGroup; GroupID : Integer; ChangeKind: TGroupChangeKind) of Object;
  TMsnReceiveMessageEvent = procedure (Sender: TObject; Header: UTF8String;
    FromAccount: String; FromName: WideString; Msg: UTF8String) of Object;


  TMSNMessenger = class;

  TMsnAuthThread = class(TTHread)
  private
     Fowner: TMSNMessenger;
     FChallenge: TStringList;
     function SSLGet(Url, Content: String): String;
     function ObtainLoginSrv: String;
     function ObtainAuthStr(LoginSrv: String; var AuthStr: String): Boolean;
  protected
     procedure Execute; override;
  public
     constructor Create(Owner:TMSNMessenger;Chal: String);
  end;


  TMSNMessenger = class(TComponent)
  private
    FTrID: Integer;
    FSignInStage: TSignInStage;
    FAuthThread: TMsnAuthThread;
    FOnSignIn: TNotifyEvent;
    FSignOutType: TSignOutType;
    FIncompleteCommand: UTF8String;
    FGTC: Boolean;
    FBLP: TBLP;
    FLstCount: Integer;
    FLsgCount: Integer;
    FReverseMembers: TMsnMemberList;
    FAllowMembers: TMsnMemberList;
    FBlockMembers: TMsnMemberList;
    FOnUrl: TMsnUrlEvent;
    FOnNewMail: TMsnNewMailEvent;
    FInboxUnread: Integer;
    FFoldersUnread: Integer;
    FMembersCount: Integer;
    FOnGroupAddition: TMsnGroupEvent;
    FUser: TMsnUser;
    FPingTimer: TTimer;
//    FOnReceiveMessage: TReceiveMessage;
    FHost, FPort : String;
    FConnected: Boolean;
    FLog:Tstrings ;
    FMemberCount: Integer;
    FGroupCount: Integer;
    FGroups: TMSNGroupList;
    FMembers: TMsnMemberList;
    FOnMemberStatusChange: TMsnStatusChangeEvent;
    FOnMemberChange: TMsnGetMemberEvent;
    FOnMemberNameChange: TMsnMemberEvent;
    FOnMemberOffline: TMsnMemberEvent;
    FOnMemberOnline: TMsnMemberEvent;
    FOnMemberGroupChange: TMsnMemberEvent;
    FStatus: TMsnMemberStatus;
    FOnGetMailCountAndAlias: TEMailCountAndAliasEvent;
    FOnError: TMsnErrorEvent;
    FSessions: TMsnSessionList;
    FOnReceiveMessage: TMsnReceiveMessageEvent;
    RequestMail: string;
    FOnGroupChange: TGroupChangeEvent;
    FMailCount: Integer;
    FPassInfo: TMsnPassportInfo;
    procedure SetHost(const Value: String);
    procedure SetPort(const Value: String);
    procedure SetMsnUserName(const Value: String);
    procedure SetMsnPassWord(const Value: String);
    function GetSocksServer: string;
    procedure SetSocksServer(const Value: string);
    function GetSocksPort: string;
    procedure SetSocksPort(const Value: string);
    function GetSocksUserName: string;
    procedure SetSocksUserName(const Value: string);
    function GetUserPassWord: string;
    procedure SetUserPassWord(const Value: string);
    procedure SetPingInterval(Sec: Integer);
    procedure PingTimerProc(Sender: TObject);
    {添加会话}
    procedure AddSession(AHost, APort, ACookie, ASessionID, MsnUserName,
        SessionMail : String; AMember:TMsnMember; MemberList : TMsnMemberList);
    {会话断开连接..}
    procedure SessionDisConnect(Sender: TObject);
    {得到登陆邮箱的信息}
    procedure GetPassportInfo(acmdStr : String);
        {处理异常}
    procedure ProcessError(Const ACommand: String);
    {登陆邮箱}
    procedure ProcessMail(acmdStr : String);
    {登陆邮箱信息}
    property  PassInfo: TMsnPassportInfo read FPassInfo;
    procedure Process_XFR_CMD(Trid:integer;stype,sbaddress,cookie:string);
    procedure Process_RNG_CMD(ACmdStr: String);
    procedure ProcessCHL(ParamLst: TStringList);
    procedure ProcessQNG(ParamLst: TStringList);
    procedure ProcessMessage(DataStr: UTF8String);
    procedure ProcessSynCommand(ParamLst: TStringList);
    procedure ProcessChangeStatus(ParamLst: TStringList);
    procedure ProcessChangeName(ParamLst: TStringList);
    procedure ProcessMemberList(ParamLst: TStringList);
    procedure ProcessGroupList(ParamLst: TStringList);
    procedure ProcessPrivacySetting(ParamLst: TStringList);
    procedure CreatePrivacyCommand(var ParamLst: TStringList; Cmd: String; BLP: TBLP);
    procedure ChangeUserName(Account: String; NewName: WideString);
    procedure DoSystemMessage(Arg1: String);
    procedure DoGroupListChange;
    procedure DoMemberListUpdated(ListKind: TListKind);
    function  ListKindToStr(List: TListKind): String;
    procedure SetBLP(Value: TBLP);
    procedure SetGTC(Value: Boolean);

  protected
    {请求的内容..}
    FSocksServer, FSocksPort, FSocksUserName, FSocksUserPassWord : String;
    RequestText : String;
    FSocket: TWSocket;
    {记录日志}
    procedure LogWrite(const Data: String);
    {Socket断开连接}
    procedure SocketDisconnect(Sender: TObject; Error: Word);

    {Socket接收到数据}
    procedure SocketDataAvailable(Sender: TObject; Error: Word);
    procedure SocketConnect(Sender: TObject; Error: Word);
    procedure DoCalled(SessionID, SBAddress, Cookie, CallingUserAccount: String;
      CallingUserName: WideString);
    procedure DoReceiveMessage(Header: UTF8String; FromAccount: String;
                               FromName: WideString; Msg: UTF8String);
    procedure DoUrl(rru, passport: String; id: Integer);
    procedure DoError(ErrorKind: TErrorKind; ErrorCode: Integer; ErrorMsg: WideString = '');

    procedure DoNewMail(Inbox: Boolean; FromName: WideString; FromAddr: String);
    procedure DoUnreadMailChange(Init: Boolean);
    procedure DoMemberInit(ListKind: TListKind; Member: TMsnMember);
    procedure DoMemberAddition(ListKind: TListKind; Member: TMsnMember);
    procedure DoMemberGroupChange(Member: TMsnMemberBase);
    procedure DoMemberDeletion(ListKind: TListKind; Member: TMsnMember);

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Login;
    procedure Logoff;
    property Groups: TMSNGroupList read FGroups;
    property Log: TStrings read FLog write FLog;
    property SignInStage: TSignInStage read FSignInStage;
    property Members: TMsnMemberList read FMembers write FMembers;
    property MailCount: Integer read FMailCount write FMailCount;
    procedure MemberByeSession(Sender: TObject; Member: TMsnMember);
    procedure Close;
    procedure CloseSession(Alias: String);
    function SendMessage(Account: String; MsgText: WideString):boolean ;
        {发送请求会话}
    procedure SendRequest(Alias: String);
    procedure Ping;

    function AddGroup(Const AGroupName: WideString): Integer;
    function ChangeGroup(Const AGroupID: Integer; AGroupName: WideString): Integer;
    function DelGroup(Const AGroupID: Integer): Integer;
    function RenameGroup(GroupId: Integer; NewName: WideString): Integer;

    function AddMember(List: TListKind; Account: String;
                                  GroupId: Integer = -1): Integer;

    function RenameMember(Account: String; NewName: WideString): Integer;
    function ChangeUserStatus(Status: TMsnMemberStatus): Integer;
    procedure sendcommand(Str: UTF8String);
    procedure ProcessSignIn(ParamLst: TStringList);
    procedure FinishSignInProcess;
    property TrID: Integer read FTrID;
    procedure SignIn(Account, Password: String; Name: WideString;
                                Status: TMsnMemberStatus);
    procedure SignOut;
    property GTC: Boolean read FGTC write SetGTC;
    property BLP: TBLP read FBLP write SetBLP;
        property PingInterval: Integer write SetPingInterval;
    published
    {Msn Host}
    property Host: String read FHost write SetHost;
    {Msn Port}
    property Port: String read FPort write SetPort;
    {Msn 好友}
    property Connected: Boolean read FConnected;
    {代理服务器地址}
    property SocksServer: string read GetSocksServer write SetSocksServer;
    {代理服务器端口}
    property SocksPort: string read GetSocksPort write SetSocksPort;
    {代理用户名}
    property SocksUserName: string read GetSocksUserName write SetSocksUserName;
    {代理密码}
    property SocksUserPassWord: string read GetUserPassWord write SetUserPassWord;

    property MemberCount: Integer read FMemberCount write FMemberCount;
    {组数}
    property GroupCount: Integer read FGroupCount write FGroupCount;
    {得到组事件}
    {成员状态更改事件..}
    property OnMemberStatusChange: TMsnStatusChangeEvent read FOnMemberStatusChange
        write FOnMemberStatusChange;
    property OnMemberChange: TMsnGetMemberEvent read FOnMemberChange write
        FOnMemberChange;
    property OnMemberNameChange: TMsnMemberEvent read FOnMemberNameChange write FOnMemberNameChange;
    property OnMemberGroupChange: TMsnMemberEvent read FOnMemberGroupChange write FOnMemberGroupChange;
    property OnMemberOnline: TMsnMemberEvent read FOnMemberOnline write FOnMemberOnline;
    property OnMemberOffline: TMsnMemberEvent read FOnMemberOffline write FOnMemberOffline;
    property Status: TMsnMemberStatus read FStatus write FStatus;
    property OnGetMailCountAndAlias: TEMailCountAndAliasEvent read
        FOnGetMailCountAndAlias write FOnGetMailCountAndAlias;
    property OnError: TMsnErrorEvent read FOnError write FOnError;
    property Sessions: TMsnSessionList read FSessions write FSessions;
    property OnReceiveMessage: TMsnReceiveMessageEvent read FOnReceiveMessage write FOnReceiveMessage;
    property OnGroupChange: TGroupChangeEvent read FOnGroupChange write
        FOnGroupChange;
    property OnSignIn: TNotifyEvent read FOnSignIn write FOnSignIn;
    property OnGroupAddition: TMsnGroupEvent read FOnGroupAddition write FOnGroupAddition;
    property User: TMsnUser read FUser;

  end;


procedure Register;
function DateTimeToCTime(Time: TDateTime): Ctime;

implementation



uses windows, Consts;
var
  TimeZoneInformation: TTimeZoneInformation;
  Bias: TDateTime;

procedure Register;
begin
  RegisterComponents('yxp132', [TMsnMessenger]);
end;

function DateTimeToCTime(Time: TDateTime): Integer;
const
  SecondsPerDay = 24 * 60 * 60;
begin
  Result := Round((Time - Bias) * SecondsPerDay);
end;


{ TMSNMessenger }

constructor TMSNMessenger.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FSocket := TWSocket.Create(Self);
  FSocket.Addr := SMsnAddr;
  FSocket.Port := SMsnPort;
  FSocket.Proto:= SMsnProto;

  FSocket.OnSessionConnected := SocketConnect;
  FSocket.OnSessionClosed    := SocketDisconnect;
  FSocket.OnDataAvailable    := SocketDataAvailable;
  FConnected := False;

  fHost:=SMsnAddr; ;

  FUser:= TMsnUser.Create;
  FGroups := TMsnGroupList.Create;
  FMembers := TMsnMemberList.Create;
  Sessions := TMsnSessionList.Create;

  FPingTimer := TTimer.Create(nil);
  FPingTimer.OnTimer := PingTimerProc;
  FPingTimer.Enabled := False;

  FSocket.Proto:= SMsnProto;
  FUser.Status := UsNLN;
end;

destructor TMSNMessenger.Destroy;
begin
  FPingTimer.Free;
  FSocket.Free;
  FSocket := nil;
  FGroups.Free;
  FMembers.Free;
  FUser.Free;
  inherited Destroy;
end;

procedure TMSNMessenger.Login;
begin
  if FConnected then exit;
   FSignOutType := otUnKnown;
  Try
    FSignInStage := ssUnConnect;
    FSocket.Proto:= SMsnProto;
    FSocket.Connect;
  Except
    On E: Exception do
      if Assigned(FOnError) then
        FOnError(Self, fySocketError, E.HelpContext, E.Message);
  end; //try
end;

procedure TMSNMessenger.Logoff;
begin
  if FConnected then
  begin
    SendCommand('OUT'#13#10);
    FConnected := False;
  end;
end;

procedure TMSNMessenger.LogWrite(const Data: String);
begin
  if Assigned( FLog ) then
    FLog.Add(Data);
end;

procedure TMSNMessenger.SetHost(const Value: String);
begin
  if not Connected then
    FSocket.Addr := Value;
end;

procedure TMSNMessenger.SetMsnPassWord(const Value: String);
begin
  if not Connected then
    Fuser.Password := Value;
end;

procedure TMSNMessenger.SetPort(const Value: String);
begin
  if not Connected then
    FSocket.Port := Value;
end;

procedure TMSNMessenger.SetMsnUserName(const Value: String);
begin
  if not FConnected then
    Fuser.Account:= Value;
end;

procedure TMSNMessenger.SocketConnect(Sender: TObject; Error: Word);
var MsnVer:string ;
begin
  FTrID:=0 ;
  MsnVer := MSN_VERSION9 + ' ' + MSN_VERSION8;
  SendCommand(Format('VER %d %s CVR0'#13#10, [FTrID, MsnVer]));
end;

procedure TMSNMessenger.SocketDataAvailable(Sender: TObject; Error: Word);
var
   DataStr: Utf8String;
   CommandLst: TStringList;
   ParamLst: TStringList;
begin
   CommandLst := TStringList.Create;
   ParamLst := TStringList.Create;
   try
      DataStr := FSocket.ReceiveStr;
      DataStr := FIncompleteCommand + DataStr;
      FIncompleteCommand := SplitCommandStr(CommandLst, DataStr);
logwrite('recv:'+CommandLst.Text);
      while CommandLst.Count > 0 do
      begin
         SplitParamStr(ParamLst, CommandLst[0]);
         if StrToIntDef(SS(ParamLst, 0), -1) <> -1 then ProcessError(ParamLst.Text)
         else if (SS(ParamLst, 0) = 'OUT') and (SS(ParamLst, 1) = 'OTH') then
            FSignOutType := otOTH
         else if (SS(ParamLst, 0) = 'OUT') and (SS(ParamLst, 1) = 'SSD') then
            FSignOutType := otSSD
         else if (SS(ParamLst, 0) = 'CHG') or (SS(ParamLst, 0) = 'NLN') or
                    (SS(ParamLst, 0) = 'FLN') or (SS(ParamLst, 0) = 'ILN') then
            ProcessChangeStatus(ParamLst)
         else if (SS(ParamLst, 0) = 'REA') then  ProcessChangeName(ParamLst)
         else if SS(ParamLst, 0) = 'MSG' then    ProcessMessage(CommandLst[0])
         else if (SS(ParamLst, 0) = 'RNG') then
            Process_RNG_CMD(datastr)
         {   DoCalled(ParamLst[1], ParamLst[2], ParamLst[4],
                     ParamLst[5], DecodeParam(ParamLst[6]))   }
         else if (SS(ParamLst, 0) = 'XFR') then  //and (SS(ParamLst, 2) = 'SB') then
            Process_XFR_CMD(StrToInt(ParamLst[1]),ParamLst[2], ParamLst[3], ParamLst[5])
         else if (SS(ParamLst, 0) = 'SYN') then
           ProcessSynCommand(ParamLst)
         else if (SS(ParamLst, 0) = 'LST') or
                    (SS(ParamLst, 0) = 'ADD') or (SS(ParamLst, 0) = 'REM') then
            ProcessMemberList(ParamLst)
         else if (SS(ParamLst, 0) = 'LSG') or   /// and (SS(ParamLst, 4) <> '0')
                    (SS(ParamLst, 0) = 'ADG') or (SS(ParamLst, 0) = 'REG') or
                    (SS(ParamLst, 0) = 'RMG') then
            ProcessGroupList(ParamLst)
         else if (SS(ParamLst, 0) = 'GTC') or (SS(ParamLst, 0) = 'BLP') then
            ProcessPrivacySetting(ParamLst)  //Initial contact list/settings download
         else if (SS(ParamLst, 0) = 'CHL') then  ProcessCHL(ParamLst)
         else if (SS(ParamLst, 0) = 'QNG') then  ProcessQNG(ParamLst)
         else if (SS(ParamLst, 0) = 'URL') then  DoUrl(ParamLst[2], ParamLst[3], StrToIntDef(SS(ParamLst, 4), 2))
         else if FSignInStage <> ssSignIn then   ProcessSignIn(ParamLst);
         CommandLst.Delete(0);
      end;
   finally
      ParamLst.Free;
      CommandLst.Free;
   end;
end;

procedure TMSNMessenger.SocketDisconnect(Sender: TObject; Error: Word);
begin
  FConnected := False;
  if Assigned(FOnError) then
    if Error = Error_Login then
      FOnError(Sender, fyMsnError, Error)
    else
      FOnError(Sender, fySocketError, Error);
  LogWrite(SocketDiscon);
end;

function TMSNMessenger.GetSocksServer: string;
begin
  Result := FSocksServer;
end;

procedure TMSNMessenger.SetSocksServer(const Value: string);
begin
  if Not FConnected then
  begin