msnmessenger.pas

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

   ParamLst.Add(Cmd);
   ParamLst.Add('0'); // dummy
   case BLP of
      bpAL: ParamLst.Add('AL');
      bpBL: ParamLst.Add('BL');
   end;
   ParamLst.Add('0'); // dummy
   ParamLst.Add('all_useraccount_not_in_the_list');
   If Cmd = 'ADD' then
      ParamLst.Add('all_username_not_in_the_list');
end;

procedure TMSNMessenger.DoError(ErrorKind: TErrorKind; ErrorCode: Integer;
  ErrorMsg: WideString);
begin
  if Assigned(FOnError) then
    FOnError(Self, ErrorKind, ErrorCode, ErrorMsg);
end;

procedure TMSNMessenger.ProcessError(const ACommand: String);
var
  CMD: String;
  ERRORCode : integer;
  ERRORStr : String;
  ErrorKind : TErrorKind;
begin
  ERRORCode := -1;
  ErrorKind := fyMsnError;
  CMD := WordAt(ACommand, 1);
  if CMD = IntToStr(ERROR_205) then
  begin
    ERRORCode := ERROR_205;
    ERRORStr := ERROR_205_STR;
  end
  else if CMD = IntToStr(ERROR_208) then
  begin
    ERRORCode := ERROR_208;
    ERRORStr := ERROR_208_STR;
  end
  else if CMD = IntToStr(ERROR_224) then
  begin
    ERRORCode := ERROR_224;
    ERRORStr := ERROR_224_STR;
  end
  else if CMD = IntToStr(ERROR_223) then
  begin
    ERRORCode := ERROR_223;
    ERRORStr := ERROR_223_STR;
  end
  else if CMD = IntToStr(ERROR_229) then
  begin
    ERRORCode := ERROR_229;
    ERRORStr := ERROR_229_STR;
  end
  else if CMD = IntToStr(ERROR_600) then
  begin
    ERRORCode := ERROR_600;
    ERRORStr := ERROR_600_STR;
    ErrorKind := fySocketError;
  end
  else if CMD = IntToStr(ERROR_707) then
  begin
    ERRORCode := ERROR_707;
    ERRORStr := ERROR_707_STR;
    ErrorKind := fySocketError;
  end;
  if ERRORCode <> -1 then
    if Assigned(FOnERROR) then
      FOnERROR(self, ErrorKind, ERRORCode, ERRORStr);
end;

procedure TMSNMessenger.DoNewMail(Inbox: Boolean; FromName: WideString;
  FromAddr: String);
begin
//  if Assigned(FOnNewMail) then
//    FOnNewMail(Self, Inbox, FromName, FromAddr);
end;

procedure TMSNMessenger.DoUnreadMailChange(Init: Boolean);
begin
//  if Assigned(FOnUnreadMailChange) then
//    FOnUnreadMailChange(Self, Init);
end;

procedure TMSNMessenger.DoSystemMessage(Arg1: String);
begin
//   If Assigned(FOnSystemMessage) then
//      FOnSystemMessage(Self, Arg1);
end;

procedure TMSNMessenger.DoGroupListChange;
begin
{  if Assigned(FOnGroupListChange) then
    FOnGroupListChange(Self);
}
end;

procedure TMSNMessenger.DoMemberListUpdated(ListKind: TListKind);
begin
{  if Assigned(FOnMemberListUpdated) then
    FOnMemberListUpdated(Self, ListKind);
}
end;

function TMSNMessenger.ListKindToStr(List: TListKind): String;
begin
  case List of
    lkFL : Result := 'FL';
    lkRL : Result := 'RL';
    lkAL : Result := 'AL';
    lkBL : Result := 'BL';
  end;
end;

procedure TMSNMessenger.SignIn(Account, Password: String; Name: WideString;
  Status: TMsnMemberStatus);
begin
   FSignOutType := otUnKnown;
   FSignInStage := ssTryConnectServer;
   FMembers.Clear;
   FReverseMembers.Clear;
   FAllowMembers.Clear;
   FBlockMembers.Clear;
   FGroups.Clear;
   FMembers.Updated := False;
   FReverseMembers.Updated := False;
   FAllowMembers.Updated := False;
   FBlockMembers.Updated := False;

   FUser.Account := Account;
   FUser.Password := Password;
   FUser.Status := Status;
   FUser.Name := Name;

   If FSocket.Handle > 0 then
   begin
      FSocket.Close;
      FSocket.Addr := '';
      FSocket.Port := FPort;
      FSocket.Connect;
   end
   else
   begin
      FSignInStage := ssUnConnect;
//      DoSignOut(FSignOutType);
   end;
end;

function TMSNMessenger.RenameMember(Account: String;
  NewName: WideString): Integer;
begin
   Inc(FTrID);
   SendCommand(Format('REA %d %s %s'#13#10,
                      [FTrID, Account, EncodeParam(NewName)]));
   Result := FTrID;
end;

function TMSNMessenger.ChangeUserStatus(Status: TMsnMemberStatus): Integer;
begin
   Inc(FTrID);
   SendCommand(Format('CHG %d %s %d'#13#10,
                      [FTrID, MemberStatusToStr(Status), MSNMSGR_CHG]));
   Result := FTrID;
end;

procedure TMSNMessenger.SignOut;
begin
   SendCommand('OUT'#13#10);
end;

procedure TMSNMessenger.DoMemberInit(ListKind: TListKind;
  Member: TMsnMember);
begin
//  if Assigned(FOnMemberInit) then
//    FOnMemberInit(Self, ListKind, Member);
end;

procedure TMSNMessenger.DoMemberAddition(ListKind: TListKind;
  Member: TMsnMember);
begin
//  if Assigned(FOnMemberAddition) then
//    FOnMemberAddition(Self, ListKind, Member);
end;

procedure TMSNMessenger.DoMemberGroupChange(Member: TMsnMemberBase);
begin
//  if Assigned(FOnMemberGroupChange) then
//    FOnMemberGroupChange(Self, Member);
end;

procedure TMSNMessenger.DoMemberDeletion(ListKind: TListKind;
  Member: TMsnMember);
begin
//  if Assigned(FOnMemberDeletion) then
//    FOnMemberDeletion(Self, ListKind, Member);
end;

function TMSNMessenger.RenameGroup(GroupId: Integer;
  NewName: WideString): Integer;
begin
   Inc(FTrID);
   SendCommand(Format('REG %d %d %s 0'#13#10, [FTrID, GroupId, EncodeParam(NewName)]));
   Result := FTrID;
end;

procedure TMSNMessenger.SetBLP(Value: TBLP);
begin
  Inc(FTrID);
  case Value of
     bpAL:
         SendCommand(Format('BLP %d AL'#13#10, [FTrID]));
     bpBL:
         SendCommand(Format('BLP %d BL'#13#10, [FTrID]));
  end;
end;

procedure TMSNMessenger.SetGTC(Value: Boolean);
begin
   Inc(FTrID);
   if Value then
      SendCommand(Format('GTC %d A'#13#10, [FTrID]))
   else
      SendCommand(Format('GTC %d N'#13#10, [FTrID]));
end;


procedure TMSNMessenger.SendRequest(Alias: String);
begin
  if FConnected then
  begin
    if Sessions.GetMsnSessionByAlias(Alias) <> nil then exit;//当前的会话已存在..
    RequestMail := Members.FindMailByAlias(Alias);
    Inc(FTrID);
    SendCommand(Format('XFR %d %s'#13#10, [FTrID, SBString]));
  end;
end;

procedure TMSNMessenger.SetPingInterval(Sec: Integer);
begin
   FPingTimer.Enabled := False;
   FPingTimer.Interval := Sec * 1000;
   FPingTimer.Enabled := false ;
end;

procedure TMSNMessenger.PingTimerProc(Sender: TObject);
begin
   FPingTimer.Enabled := False;
   If FSignInStage = ssSignIn then Ping;
end;

procedure TMSNMessenger.Ping;
begin
  SendCommand('PNG'#13#10);
end;

{ TMsnAuthThread }

constructor TMsnAuthThread.Create(Owner:TMSNMessenger;Chal: String);
begin
   FOwner := Owner;
   FChallenge := TStringList.Create;
   Split(FChallenge, Chal, ',');
   inherited Create(False);
   FreeOnTerminate := True;
end;

procedure TMsnAuthThread.Execute;
var
   LoginSrv, AuthStr: String;
begin
   LoginSrv := ObtainLoginSrv;
   If LoginSrv <> '' then
   begin
      If ObtainAuthStr(LoginSrv, AuthStr) then
      begin
         FOwner.SendCommand(Format('USR %d TWN S %s'#13#10, [FOwner.TrID, AuthStr]))  ;
      end
      else
        FOwner.LogWrite('error:'+AuthStr);
      end
   else
   begin
      FOwner.LogWrite('验证错误！');
   end;
   FChallenge.Free;
end;

function TMsnAuthThread.ObtainAuthStr(LoginSrv: String;
  var AuthStr: String): Boolean;
var
   HeadLst, ParamLst, ClientInfo: TStringList;
   Auth, S: String;
begin
   Result := False;
   HeadLst := TStringList.Create;
   try
      Auth := Format(MSNP8_AUTH_REQUEST,
                     [FChallenge.Values['ru'],
                      UrlEncode(FOwner.Fuser.Account),
                      UrlEncode(FOwner.Fuser.Password),
                      FChallenge.Values['lc'],
                      FChallenge.Values['id'],
                      FChallenge.Values['tw'],
                      FChallenge.Values['fs'],
                      FChallenge.Values['ct'],
                      FChallenge.Values['kpp'],
                      FChallenge.Values['kv'],
                      FChallenge.Values['ver'],
                      FChallenge.Values['tpf']]);
      SplitMimeHeader(HeadLst, SSLGet(LoginSrv, Auth));
      If HeadLst.Values['Location'] <> '' then
         Result := ObtainAuthStr(HeadLst.Values['Location'], AuthStr)
      else If HeadLst.Values['Authentication-Info'] <> '' then
      begin
         ParamLst := TStringList.Create;
         ClientInfo := TStringList.Create;
         try
            Split(ParamLst, HeadLst.Values['Authentication-Info'], ' ');
            If (ParamLst[0] = 'Passport1.4') and (ParamLst[1] <> '') then
            begin
               Split(ClientInfo, ParamLst[1], ',');
               If ClientInfo.Values['da-status'] = 'success' then
               begin
                  S := ClientInfo.Values['from-PP'];
                  AuthStr := Copy(S,2,Length(S)-2);
                  Result := True;
               end;
            end;
         finally
            ParamLst.Free;
            ClientInfo.Free;
         end;
      end
      else If HeadLst.Values['WWW-Authenticate'] <> '' then
      begin
         ParamLst := TStringList.Create;
         ClientInfo := TStringList.Create;
         try
            Split(ParamLst, HeadLst.Values['WWW-Authenticate'], ' ');
            If (ParamLst[0] = 'Passport1.4') and (ParamLst[1] <> '') then
            begin
               Split(ClientInfo, ParamLst[1], ',');
               If ClientInfo.Values['da-status'] = 'failed' then
               begin
                  AuthStr := UrlDecode(ClientInfo.Values['cbtxt']);
                  Result := False;
               end;
            end;
         finally
            ParamLst.Free;
            ClientInfo.Free;
         end;
      end;
   finally
      HeadLst.Free;
   end;
end;

function TMsnAuthThread.ObtainLoginSrv: String;
var
   HeadLst, ParamLst: TStringList;
begin
   Result := '';
   HeadLst := TStringList.Create;
   try
      SplitMimeHeader(HeadLst, SSLGet(INITIAL_PASSPORT_REDIRECT_SERVER, ''));
      If HeadLst.Values['PassportURLs'] <> '' then
      begin
         ParamLst := TStringList.Create;
         try
            Split(ParamLst, HeadLst.Values['PassportURLs'], ',');
            If ParamLst.Values['DALogin'] <> '' then
               Result := 'https://' + ParamLst.Values['DALogin'];
         finally
            ParamLst.Free;
         end;
      end;
   finally
      HeadLst.Free;
   end;
end;

function TMsnAuthThread.SSLGet(Url, Content: String): String;
var
   NetHandle,UrlHandle: HINTERNET;
   Buffer: Array[0..4095] of Char; // 揔摉乧
   dwCode, dwSzBuff, dwTemp: DWORD;
   Proto: String;
   proxyType: Integer;
begin
   NetHandle := InternetOpen('MSMSGS', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
{   If Config.UseInetOptOnSignIn then
   begin
      NetHandle := InternetOpen('MSMSGS', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
   end
   else
   begin
      proxyType := FOwner.Socket.GetInfoInt(NMSOCK_INFO_PROXYTYPE);
      If proxyType = NMSOCK_PROXY_NONE then
         NetHandle := InternetOpen('MSMSGS', INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0)
      else
      begin
         case proxyType of
            NMSOCK_PROXY_HTTP:   Proto := 'http';
            NMSOCK_PROXY_SOCKS4: Proto := 'socks';
            NMSOCK_PROXY_SOCKS5: Proto := 'socks';
         end;
         NetHandle := InternetOpen('MSMSGS', INTERNET_OPEN_TYPE_PROXY,
                                   PChar(Format('https=%s://%s:%d',
                                                [Proto,Config.ProxyHost,Config.ProxyPort])),
                                   PChar('<local>'), 0);
      end;
   end;
}
   UrlHandle := InternetOpenUrl(NetHandle, PChar(Url), PChar(Content), DWORD(-1),
                                INTERNET_FLAG_IGNORE_CERT_CN_INVALID
                                + INTERNET_FLAG_IGNORE_CERT_DATE_INVALID
                                + INTERNET_FLAG_IGNORE_REDIRECT_TO_HTTP
                                + INTERNET_FLAG_IGNORE_REDIRECT_TO_HTTPS
                                + INTERNET_FLAG_KEEP_CONNECTION
                                + INTERNET_FLAG_NO_AUTO_REDIRECT
                                + INTERNET_FLAG_NO_CACHE_WRITE
                                + INTERNET_FLAG_NO_COOKIES
                                + INTERNET_FLAG_NO_UI
                                + INTERNET_FLAG_PRAGMA_NOCACHE
                                + INTERNET_FLAG_RELOAD
                                + INTERNET_FLAG_SECURE, 0);
   dwSzBuff := SizeOf(dwCode);
   dwTemp := 0;
   HttpQueryInfo(UrlHandle, HTTP_QUERY_STATUS_CODE + HTTP_QUERY_FLAG_NUMBER,
                 @dwCode, dwSzBuff, dwTemp);
   case dwCode of
      HTTP_STATUS_REDIRECT:
         begin
            FillChar(Buffer, SizeOf(Buffer), 0);
            dwSzBuff := SizeOf(Buffer);
            dwTemp := 0;
            HttpQueryInfo(UrlHandle, HTTP_QUERY_LOCATION,
                          @Buffer, dwSzBuff, dwTemp);
            Result := SSLGet(String(Buffer), Content);
         end;
      HTTP_STATUS_OK:
         begin
            FillChar(Buffer, SizeOf(Buffer), 0);
            dwSzBuff := SizeOf(Buffer);
            dwTemp := 0;
            HttpQueryInfo(UrlHandle, HTTP_QUERY_RAW_HEADERS_CRLF,
                          @Buffer, dwSzBuff, dwTemp);
            Result := Buffer;
         end;
   end;
   InternetCloseHandle(UrlHandle);
   InternetCloseHandle(NetHandle);
end;

initialization
  GetTimeZoneInformation(TimeZoneInformation);
  Bias := (365 * 70 + 19) - TimeZoneInformation.Bias / (60 * 24);
end.