unit Groups; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, StdCtrls, WebSocket2, CustomServer2, blcksock,Idhttp, superobject, WebSocketClient, ExtCtrls, Forms, Dialogs, IniFiles, LoggerImport, DownloadFileFromWeb, GroupMonitor, RealICQUtility; type TOnGetTeamInfo = procedure (aTeamID: String) of Object; //群组成员数据 TProtocolMethod = procedure(Data: String) of Object; TTeamMemberCard = class private FTeamID: string; FID: String; FServerID: String; FUserID: String; FAlias: String; FTimesTamp: Int64; public property ID: String read FID; property ServerID: String read FServerID; property UserID: String read FUserID; property Alias: String read FAlias Write FAlias; property TimesTamp: Int64 read FTimesTamp; end; TGroup = class private FIP: String; FPort: Integer; FImageIP: String; FImagePort: Integer; FClient: TWebSocketClientConnection; FProtocolsList: TStringList; FTeams: TStringList; FTempSendFileList: TStringlist; FEnable: Boolean; FLoginName: string; FDownFile: TDownFile; FTeamMemberCards: TStringList; FOnGetTeamInfo : TOnGetTeamInfo; procedure UpdateTeamInfoFromJson(AJo: ISuperObject); function GetOrCreateTeam(ATeamID: string): TObject; function GetTeam(ATeamID: string): TObject; function FormatStrFromServer(AStr: string): string; function FormatStrToServer(AStr: string): string; procedure SetGetTeamInfo(const Value: TOnGetTeamInfo); procedure ProcessOnGroupSubscribeResponse(Data: String); procedure ProcessOnGroupAddResponse(Data: String); procedure ProcessOnGroupAddBroadCast(Data: String); procedure ProcessOnGroupRemoveResponse(Data: String); procedure ProcessOnGroupRemoveBroadcast(Data: String); procedure ProcessOnGroupSayResponse(Data: String); procedure ProcessOnGroupSayBroadCast(Data: String); procedure ProcessOnGroupInfoRead(Data: String); procedure ProcessOnGroupInfoUpdate(Data: String); procedure ProcessOnGroupInfoUpdateBroadCast(Data: String); procedure ProcessOngroupMemberaddresponse(Data: String); procedure ProcessOnGroupMemberaddBroadcast(Data: String); procedure ProcessOnGroupManagerAddResponse(Data: String); procedure ProcessOnGroupManagerAddBroadCast(Data: String); procedure ProcessOnGroupMemberRemoveResponse(Data: String); procedure ProcessOnGroupMemberRemoveBroadCast(Data: String); procedure ProcessOnGroupManagerRemoveResponse(Data: String); procedure ProcessOnGroupManagerRemoveBroadCast(Data: String); procedure ProcessOnGroupMemberLeaveRespone(Data: String); procedure ProcessOnGroupMemberleaveBroadCast(Data: String); procedure ProcessOnGroupSearch(Data: String); procedure ProcessOngroupMemberApplyConfirm(Data: String); procedure ProcessOnGroupMemberApplyResponse(Data: String); procedure ProcessOnGroupFileBroadCast(Data: String); procedure ProcessOnGroupFileUploadResponse(Data: String); procedure ProcessOnGroupMemberUpdateResponse(Data: String); function GetTeams:TStringList; function GetMemberCard(ATeamID, ALoginName: string): TTeamMemberCard; procedure DownFaceFileComplete(Source_file, Dest_file: String; blStatus: boolean; ErrMessage: String); procedure SetLoginName(const Value: string); function InitMemebers(ATeamID: string; AJoUser: ISuperObject): string; function ConcateMembers(AMemebersStr: string; ANewMembers: TSuperArray): string; public constructor Create(); destructor Destroy; override; procedure Start; procedure Close; procedure SendMessage(Data: String); Procedure TestEvent; procedure Send(Data: string); procedure UploadFile(Hash, FileName, ID, GroupID: String); procedure DownloadTeamFace(AMD5String, AFileName, Path: String); procedure SendFilesRequest(AGroupId, AUserId, FileName: String); procedure UpdateTeamInfo(ATeamID, AIntro, ANotice, AName: string; AAuth: Integer); procedure SendTeamMessage(ATeamID, ASender, AMsg: String; AFont: TFont; AFaces: TStringList; Attachs: String); procedure Subscribe; procedure UnSubscribe; procedure Search(AKey, AName, ATeamID, ACreator: String); procedure Leave(ATeamID: string); procedure AddManager(ATeamID, AName: String); procedure RemoveManager(ATeamID, AName: String); procedure AddTeamMembers(ATeamID: String; AUsers: TStringList); procedure RemoveTeamMembers(ATeamID: string; AUsers: TStringList); procedure RemoveMember(ATeamID,AName: String); procedure SetAlias(ATeamID, ALoginName, Alias: String); function GetAlias(ATeamID, ALoginName: string): string; Procedure SendGetTeamInfo(ATeamID: String); procedure RemoveTeam(ATeamID: string); procedure CreateTeam(ATeamName, ATeamCallBoard, ATeamIntro: String; ATeamMembers: TStringList; AIsTempTeam: Boolean); procedure JoinTeam(ATeamID, ATag: String); procedure JoinTeamResponse(ATeamID, ALoginName, AMsg: String; ARet : Integer); procedure Reconnect; procedure StopReconnect; //MainForm.TimerForreconnectgroup.Enabled := False; procedure OnOpen(aSender: TWebSocketCustomConnection); procedure OnRead(aSender: TWebSocketCustomConnection; aFinal, aRes1, aRes2, aRes3: boolean; aCode: integer; aData: TMemoryStream); procedure OnWrite(aSender: TWebSocketCustomConnection; aFinal, aRes1, aRes2, aRes3: boolean; aCode: integer; aData: TMemoryStream); procedure OnClose(aSender: TWebSocketCustomConnection; aCloseCode: integer; aCloseReason: string; aClosedByPeer: boolean); procedure OnConnectionSocket(Sender: TObject; Reason: THookSocketReason; const Value: String); published property IP: String read FIP write FIP; property Port: Integer read FPort write FPort; property ImageIP: String read FImageIP write FImageIP; property ImagePort: Integer read FImagePort write FImagePort; property Teams: TStringList read GetTeams; property Enable: Boolean read FEnable; property LoginName: string read FLoginName write SetLoginName; property TempSendFileList: TStringlist read FTempSendFileList; property OnGetTeamInfo : TOnGetTeamInfo Read FOnGetTeamInfo write SetGetTeamInfo; end; var Group: TGroup; implementation uses synsock, synachar, StrUtils, synautil, math, TypInfo, BClasses, DateUtils, CreateTeamFrm, MainFrm, SearchTeamFrm, IdMultipartFormData, MD5, xFonts, ShareUtils, RealICQClient, RealICQUtils, DataProviderImport, InterfaceDataProvider, RealICQModel; const UPLOAD_URL: string = 'http://%s:%d/file/upload'; DOWNLOAD_URL: string = 'http://%s:%d/file/%s'; ADDMEMBERS_PROTOCOL: string = '{"name":"group.member.add","args":{"id":"","users":[]}}'; REMOVEMEMBER_PROTOCOL: string = '5:::{"name":"group.member.remove","args":{"id":"%s","userid":"%s"}}'; REMOVEMEMBERS_PROTOCOL: string = '{"name":"group.member.remove","args":{"id":"","users":[]}}'; ADDMANAGER_PROTOCOL: string = '5:::{"name":"group.manager.add","args":{"id":"%s","managers":["%s"]}}'; REMOVEMANAGER_PROTOCOL: string = '5:::{"name":"group.manager.remove","args":{"id":"%s","managers":["%s"]}}'; SUBSCRIBE_PROTOCOL: string = '5:::{"name":"group.subscribe","args":{"id":"%s"}}'; UNSUBSCRIBE_PROTOCOL: string = '5:::{"name":"group.unsubscribe","args":{"id":"%s"}}'; LEAVE_PROTOCOL: string = '5:::{"name":"group.member.leave","args":{"id":"%s","userid":"%s"}}'; REMOVETEAM_PROTOCOL: string = '5:::{"name":"group.remove","args":{"id":"%s"}}'; MEMBERCARD_KEY: string = '%s:%s'; {$REGION '---'} { TGroup } procedure TGroup.Close; begin if (FClient <> nil) and (not FClient.Closed) then begin FClient.Close(wsCloseNormal, 'goodbye'); WaitForSingleObject(FClient.Handle, 60 * 1000); end; end; constructor TGroup.Create(); begin inherited Create; FEnable := False; FDownFile:= TDownFile.Create; FTeamMemberCards:= TStringList.Create; FProtocolsList := TStringList.Create; FTeams := TStringList.Create; FTempSendFileList := TStringlist.Create; FProtocolsList.Add('group.subscribe.response'); FProtocolsList.Add('group.add.response'); FProtocolsList.Add('group.remove.response'); FProtocolsList.Add('group.say.response'); FProtocolsList.Add('group.say.broadcast'); FProtocolsList.Add('group.info.response'); FProtocolsList.Add('group.member.add.response'); FProtocolsList.Add('group.member.remove.response'); FProtocolsList.Add('group.add.broadcast'); FProtocolsList.Add('group.remove.broadcast'); FProtocolsList.Add('group.member.add.broadcast'); FProtocolsList.Add('group.member.remove.broadcast'); FProtocolsList.Add('group.member.leave.response'); FProtocolsList.Add('group.member.leave.broadcast'); FProtocolsList.Add('group.manager.add.response'); FProtocolsList.Add('group.manager.add.broadcast'); FProtocolsList.Add('group.manager.remove.response'); FProtocolsList.Add('group.update.response'); FProtocolsList.Add('group.update.broadcast'); FProtocolsList.Add('group.manager.remove.broadcast'); FProtocolsList.Add('group.search.response'); FProtocolsList.Add('group.member.apply.confirm'); FProtocolsList.Add('group.member.apply.response'); FProtocolsList.Add('group.file.broadcast'); FProtocolsList.Add('file.upload.response'); FProtocolsList.Add('group.member.update.response'); FProtocolsList.Add('group.member.update.broadcast'); end; destructor TGroup.Destroy; var iLoop: Integer; RealICQTeam: TRealICQTeam; MemberCard: TTeamMemberCard; begin FreeAndNil(FProtocolsList); FreeAndNil(FDownFile); while FTeams.Count > 0 do begin RealICQTeam := FTeams.Objects[0] as TRealICQTeam; FTeams.Delete(0); FreeAndNil(RealICQTeam); end; FreeAndNil(FTeams); //注意 while FTempSendFileList.Count > 0 do begin RealICQTeam := FTempSendFileList.Objects[0] as TRealICQTeam; FTeams.Delete(0); FreeAndNil(RealICQTeam); end; FreeAndNil(FTempSendFileList); while FTeamMemberCards.Count > 0 do begin MemberCard := FTeamMemberCards.Objects[0] as TTeamMemberCard; FTeamMemberCards.Delete(0); FreeAndNil(MemberCard); end; FreeAndNil(FTeamMemberCards); inherited Destroy; end; function TGroup.GetTeams: TStringList; begin if not Assigned(FTeams) then FTeams := TStringList.Create; Result := FTeams; end; procedure TGroup.OnClose(aSender: TWebSocketCustomConnection; aCloseCode: integer; aCloseReason: string; aClosedByPeer: boolean); begin //GrpMonitor.Stop; { TODO -olqq -c : 先把定时器关掉再开 2014/12/12 15:32:22 } if (aClosedByPeer) or (aCloseCode <> 1000) then begin Error(Format('异常断开. Code:%d;Reson:%s;ClolsedByPeer:%s;', [aCloseCode, aCloseReason, BoolToStr(aClosedByPeer)]), 'TGroup.OnClose'); Reconnect; end else Success(Format('正常断开. Code:%d;Reson:%s;ClolsedByPeer:%s;', [aCloseCode, aCloseReason, BoolToStr(aClosedByPeer)]), 'TGroup.OnClose'); end; procedure TGroup.OnConnectionSocket(Sender: TObject; Reason: THookSocketReason; const Value: String); begin end; procedure TGroup.OnOpen(aSender: TWebSocketCustomConnection); begin StopReconnect; Subscribe; //GrpMonitor.Start; end; procedure TGroup.OnRead(aSender: TWebSocketCustomConnection; aFinal, aRes1, aRes2, aRes3: boolean; aCode: integer; aData: TMemoryStream); var s,Recvdata: string; c: TTestWebSocketClientConnection; jo: ISuperObject; protocol:string; RecvMethod: TProtocolMethod; begin try //GrpMonitor.ReflashLastTime; c := TTestWebSocketClientConnection(aSender); s := ReadStrFromStream(c.ReadStream, c.ReadStream.size{min(c.ReadStream.size, 10 * 1024)}); if (c.ReadCode = wsCodeText) then Recvdata := utf8toansi(s)//CharsetConversion(s, UTF_8, GetCurCP) else Recvdata := s; { TODO -olqq -c : 统一发送调用 2014/12/13 12:38:42 } if Recvdata = '2::' then Send('2::'); Recvdata := copy(Recvdata,5,length(Recvdata)); if Recvdata <> '' then begin jo := SO(Recvdata); protocol := jo['name'].AsString; case FProtocolsList.IndexOf(protocol) of 0:ProcessOnGroupSubscribeResponse(Recvdata); 1:ProcessOnGroupAddResponse(Recvdata); 2:ProcessOnGroupRemoveResponse(Recvdata); 3:ProcessOnGroupSayResponse(Recvdata); 4:ProcessOnGroupSayBroadCast(Recvdata); 5:ProcessOnGroupInfoRead(Recvdata); 6:ProcessOngroupmemberaddresponse(Recvdata); 7:ProcessOnGroupMemberRemoveResponse(Recvdata); 8:ProcessOnGroupAddBroadCast(Recvdata); 9:ProcessOnGroupRemoveBroadcast(Recvdata); 10:ProcessOnGroupMemberaddBroadcast(Recvdata); 11:ProcessOnGroupMemberRemoveBroadCast(Recvdata); 12:ProcessOnGroupMemberLeaveRespone(Recvdata); 13:ProcessOnGroupMemberleaveBroadCast(Recvdata); 14:ProcessOnGroupManagerAddResponse(Recvdata); 15:ProcessOnGroupManagerAddBroadCast(Recvdata); 16:ProcessOnGroupManagerRemoveResponse(Recvdata); 17:ProcessOnGroupInfoUpdate(Recvdata); 18:ProcessOnGroupInfoUpdateBroadCast(Recvdata); 19:ProcessOnGroupManagerRemoveBroadCast(Recvdata); 20:ProcessOnGroupSearch(Recvdata); 21:ProcessOngroupmemberapplyconfirm(Recvdata); 22:ProcessOnGroupMemberApplyResponse(Recvdata); 23:ProcessOnGroupFileBroadCast(Recvdata); 24:ProcessOnGroupFileUploadResponse(Recvdata); 25:ProcessOnGroupMemberUpdateResponse(Recvdata); 26:ProcessOnGroupMemberUpdateResponse(Recvdata); end; end; except on E: Exception do Log(E.Message+Recvdata, 'TGroup.OnRead('+Recvdata+')'); end; end; procedure TGroup.OnWrite(aSender: TWebSocketCustomConnection; aFinal, aRes1, aRes2, aRes3: boolean; aCode: integer; aData: TMemoryStream); begin end; procedure TGroup.ProcessOnGroupAddBroadCast(Data: String); var jo: ISuperObject; ja: TSuperArray; nTeamID: String; IsTemp: Integer; begin jo := SO(Data); ja := jo['args'].AsArray; nTeamID := ja[0]['id'].AsString; IsTemp := ja[0]['type'].AsInteger; if IsTemp = 0 then SendGetTeamInfo(nTeamID); end; procedure TGroup.ProcessOnGroupAddResponse(Data: String); var jo: ISuperObject; ja: TSuperArray; HWnd:THandle; nTeamID: String; TeamCreated: Boolean; TeamCaption, FailingCause: String; RealICQTeam: TRealICQTeam; begin jo := SO(Data); ja := jo['args'].AsArray; nTeamID := ja[0]['id'].AsString; TeamCreated := not ja[0]['ret'].AsBoolean; TeamCaption := ''; FailingCause := ja[0]['msg'].AsString; SendGetTeamInfo(nTeamID); // CreateTeamForm.CreateTeamResult(nil,TeamCaption,TeamCreated,nTeamID,FailingCause); // // RealICQTeam := TRealICQTeam.Create; // RealICQTeam.TeamID := nTeamID; // // if assigned(FTeams) then // begin // try // FTeams.AddObject(nTeamID, RealICQTeam); // except // on e:Exception do // showmessage(e.message); // end; // end; end; procedure TGroup.ProcessOnGroupFileBroadCast(Data: String); var jo: ISuperObject; jaargs,jafiles: TSuperArray; iLoop: Integer; filename,hash: String; begin jo := SO(Data); jaargs := jo['args'].AsArray; jafiles := jaargs[0]['files'].AsArray; for ILoop := 0 to jafiles.Length - 1 do begin filename := jafiles[iLoop]['file'].AsString; hash := jafiles[iLoop]['hash'].AsString; DownloadTeamFace(Hash,FileName,''); end; end; procedure TGroup.ProcessOnGroupFileUploadResponse(Data: String); var jo: ISuperObject; jaargs,jafiles: TSuperArray; nTeamID: String; msg: String; iLoop: Integer; filename,hash: String; ret,itemindex: Integer; begin jo := SO(Data); jaargs := jo['args'].AsArray; nTeamID := jaargs[0]['id'].AsString; msg := jaargs[0]['msg'].AsString; jafiles := jaargs[0]['files'].AsArray; for ILoop := 0 to jafiles.Length - 1 do begin filename := jafiles[iLoop]['file'].AsString; hash := jafiles[iLoop]['hash'].AsString; ret := jafiles[iLoop]['ret'].AsInteger; if ret = 0 then begin { TODO -olqq -c : 上传成功 2014/12/19 19:01:52 } end else begin { TODO -olqq -c : 上传失败 2014/12/19 19:01:52 } end; end; end; function ManagersConvertToStr(AManagers: TSuperArray): string; var iLoop: Integer; begin iLoop := 0; Result := ''; while iLoop < AManagers.Length - 1 do begin Result := Result + AManagers[iLoop].AsString + Chr(10); Inc(iLoop); end; Result := Result + AManagers[iLoop].AsString end; function TGroup.InitMemebers(ATeamID: string; AJoUser: ISuperObject): string; var AKey: String; AItem: TSuperAvlEntry; AMemberCard: TTeamMemberCard; begin Result := ''; for AItem in AJoUser.AsObject do begin AKey := Format(MEMBERCARD_KEY, [ATeamID, AItem.Value['id'].AsString]); Result := Result + AItem.Value['id'].AsString + Chr(10); if FTeamMemberCards.IndexOf(AKey) > 0 then Continue; AMemberCard := TTeamMemberCard.create; AMemberCard.FID := AItem.Value['id'].AsString; AMemberCard.FServerID := AItem.Value['serverid'].AsString; AMemberCard.FUserID := AItem.Value['userid'].AsString; AMemberCard.FAlias := AItem.Value['alias'].AsString; AMemberCard.FTimesTamp := AItem.Value['timestamp'].AsInteger; FTeamMemberCards.AddObject(AKey, AMemberCard); end; Result := Copy(Result, 0, Length(Result) - 1); end; procedure TGroup.UpdateTeamInfoFromJson(AJo: ISuperObject); var ATeam : TRealICQTeam; ATeamID: String; begin try ATeamID := AJo.S['id']; if ATeamID = '' then Exit; ATeam := GetOrCreateTeam(ATeamID) as TRealICQTeam; ATeam.TeamCaption := AJo.S['name']; ATeam.TeamCreater := AJo.S['creator']; ATeam.IsTempTeam := AJo.B['type']; ATeam.TeamIntro := FormatStrFromServer(AJo.S['intro']);; ATeam.TeamCallBoard := FormatStrFromServer(AJo.S['notice']); ATeam.TeamValidate := TRealICQTeamValidateType(AJo.I['auth']); ATeam.TeamManagers := ManagersConvertToStr(AJo.A['managers']); ATeam.TeamMembers := InitMemebers(ATeamID, AJo.O['users']); except on E: Exception do Log(E.Message, 'TGroup.UpdateTeamInfo'); end; end; procedure TGroup.ProcessOnGroupInfoRead(Data: String); var jo,jo1,jo2: ISuperObject; ja,ja2: TSuperArray; ATeamID: string; begin try jo := SO(Data); ja := jo['args'].AsArray; jo1 := SO(ja[0].AsString); ja2 := jo1['groups'].AsArray; jo2 := SO(ja2[0].AsString); ATeamID := jo2.S['id']; if ATeamID = '' then Exit; GetMapTeamUsersProvider.Insert(jo2.S['id'], jo2.AsJSon(), jo2.I['ver']); UpdateTeamInfoFromJson(jo2); MainForm.WebSocketSendReadTeamInfo(ATeamID); except on E: Exception do Log(E.Message, 'TGroup.ProcessOnGroupInfoRead'); end; end; procedure TGroup.ProcessOnGroupInfoUpdate(Data: String); var jo,joGroup: ISuperObject; ja : TSuperArray; ATeamID: String; ATeam : TRealICQTeam; begin jo := SO(Data); ja := jo['args'].AsArray; joGroup := SO(ja[0]['group'].AsString); ATeamID := joGroup.S['id']; if ATeamID = '' then Exit; ATeam := GetOrCreateTeam(ATeamID) as TRealICQTeam; ATeam.TeamCaption := joGroup.S['name']; ATeam.TeamIntro := FormatStrFromServer(joGroup.S['intro']);; ATeam.TeamCallBoard := FormatStrFromServer(joGroup.S['notice']); ATeam.TeamValidate := TRealICQTeamValidateType(joGroup.I['auth']); MainForm.WebSocketSendReadTeamInfo(ATeamID); end; procedure TGroup.ProcessOnGroupInfoUpdateBroadCast(Data: String); var jo: ISuperObject; ja,jaManagers: TSuperArray; nTeamID: String; RealICQTeam : TRealICQTeam; I,ItemIndex: Integer; begin jo := SO(Data); ja := jo['args'].AsArray; nTeamID := ja[0]['id'].AsString; ItemIndex := FTeams.indexof(nTeamID); if ItemIndex >= 0 then begin SendGetTeamInfo(nTeamID); end; end; procedure TGroup.ProcessOnGroupManagerAddBroadCast(Data: String); var jo: ISuperObject; ja,jaManagers: TSuperArray; nTeamID, strManagers: String; ATeam : TRealICQTeam; I: Integer; begin jo := SO(Data); ja := jo['args'].AsArray; nTeamID := ja[0]['id'].AsString; jaManagers := ja[0]['managers'].AsArray; ATeam := GetTeam(nTeamID) as TRealICQTeam; if ATeam = nil then begin SendGetTeamInfo(nTeamID); Exit; end; strManagers := ManagersConvertToStr(jaManagers); if Trim(ATeam.TeamManagers) <> '' then ATeam.TeamManagers := ATeam.TeamManagers + char(10) + strManagers else ATeam.TeamManagers := strManagers; MainForm.WebSocketSendReadTeamInfo(nTeamID); end; procedure TGroup.ProcessOnGroupManagerAddResponse(Data: String); var jo: ISuperObject; ja,jaManagers: TSuperArray; nTeamID, strManagers: String; ATeam : TRealICQTeam; I: Integer; begin jo := SO(Data); ja := jo['args'].AsArray; nTeamID := ja[0]['id'].AsString; jaManagers := ja[0]['managers'].AsArray; ATeam := GetTeam(nTeamID) as TRealICQTeam; if ATeam = nil then begin SendGetTeamInfo(nTeamID); Exit; end; strManagers := ManagersConvertToStr(jaManagers); if Trim(ATeam.TeamManagers) <> '' then ATeam.TeamManagers := ATeam.TeamManagers + char(10) + strManagers else ATeam.TeamManagers := strManagers; MainForm.WebSocketSendReadTeamInfo(nTeamID); end; procedure TGroup.ProcessOnGroupManagerRemoveBroadCast(Data: String); var jo: ISuperObject; ja,jaManagers: TSuperArray; nTeamID: String; ATeam : TRealICQTeam; I: Integer; begin jo := SO(Data); ja := jo['args'].AsArray; nTeamID := ja[0]['id'].AsString; jaManagers := ja[0]['managers'].AsArray; ATeam := GetTeam(nTeamID) as TRealICQTeam; SendGetTeamInfo(nTeamID); // if ATeam = nil then // begin // SendGetTeamInfo(nTeamID); // Exit; // end; // for I := 0 to jaManagers.Length - 1 do // begin // ATeam.TeamManagers := StringReplace(Chr(10) + ATeam.TeamManagers + Chr(10), Chr(10) + jaManagers[i].AsString + char(10),char(10),[rfReplaceAll]); // ATeam.TeamManagers := Copy(ATeam.TeamManagers, 2, Length(ATeam.TeamManagers) - 1); // end; // MainForm.WebSocketSendReadTeamInfo(nTeamID); end; procedure TGroup.ProcessOnGroupManagerRemoveResponse(Data: String); var jo: ISuperObject; ja,jaManagers: TSuperArray; nTeamID: String; ATeam : TRealICQTeam; I: Integer; begin jo := SO(Data); ja := jo['args'].AsArray; nTeamID := ja[0]['id'].AsString; jaManagers := ja[0]['managers'].AsArray; ATeam := GetTeam(nTeamID) as TRealICQTeam; SendGetTeamInfo(nTeamID); // if ATeam = nil then // begin // SendGetTeamInfo(nTeamID); // Exit; // end; // for I := 0 to jaManagers.Length - 1 do // begin // ATeam.TeamManagers := StringReplace(Chr(10) +ATeam.TeamManagers + Chr(10), Chr(10) +jaManagers[i].AsString + char(10),char(10),[rfReplaceAll]); // ATeam.TeamManagers := Copy(ATeam.TeamManagers, 2, Length(ATeam.TeamManagers) - 1); // end; // MainForm.WebSocketSendReadTeamInfo(nTeamID); end; procedure TGroup.ProcessOnGroupMemberaddBroadcast(Data: String); var jo: ISuperObject; ja, jaMemebers: TSuperArray; ATeam : TRealICQTeam; nTeamID: String; I: Integer; begin try jo := SO(Data); ja := jo['args'].AsArray; nTeamID := ja[0]['id'].AsString; jaMemebers := ja[0]['users'].AsArray; ATeam := GetTeam(nTeamID) as TRealICQTeam; if ATeam = nil then begin SendGetTeamInfo(nTeamID); Exit; end; ATeam.TeamMembers := ConcateMembers(ATeam.TeamMembers, jaMemebers); MainForm.WebSocketSendReadTeamInfo(nTeamID); except on E: Exception do Error(E.Message, 'TGroup.ProcessOnGroupMemberaddBroadcast(' + Data +')') end; end; function TGroup.ConcateMembers(AMemebersStr: string; ANewMembers: TSuperArray): string; var AMemberList: TStrings; iLoop, jLoop: Integer; isAdd: Boolean; begin Result := ''; AMemberList := SplitString(AMemebersStr, Chr(10)); try for iLoop := AMemberList.Count - 1 downto 0 do if Length(Trim(AMemberList[iLoop])) = 0 then AMemberList.Delete(iLoop); for jLoop := ANewMembers.Length - 1 downto 0 do begin isAdd := True; for iLoop := AMemberList.Count - 1 downto 0 do if SameText(ANewMembers.S[jLoop], AMemberList[iLoop]) then begin isAdd := False; Break; end; if isAdd then AMemberList.Add(ANewMembers.S[jLoop]); end; for iLoop := AMemberList.Count - 1 downto 0 do if iLoop = 0 then Result := Result + AMemberList[iLoop] else Result := Result + AMemberList[iLoop] + Chr(10); finally FreeAndNil(AMemberList); end; end; procedure TGroup.ProcessOngroupmemberaddresponse(Data: String); var jo: ISuperObject; ja, jaMemebers: TSuperArray; ATeam : TRealICQTeam; nTeamID: String; I: Integer; begin try jo := SO(Data); ja := jo['args'].AsArray; nTeamID := ja[0]['id'].AsString; jaMemebers := ja[0]['users'].AsArray; ATeam := GetTeam(nTeamID) as TRealICQTeam; if ATeam = nil then begin SendGetTeamInfo(nTeamID); Exit; end; ATeam.TeamMembers := ConcateMembers(ATeam.TeamMembers, jaMemebers); // for I := 0 to jaMemebers.Length - 1 do // ATeam.TeamMembers := ConcateMembers(ATeam.TeamMembers, jaMemebers.S[I]); MainForm.WebSocketSendReadTeamInfo(nTeamID); except on E: Exception do Error(E.Message, 'TGroup.ProcessOngroupmemberaddresponse(' + Data +')') end; end; procedure TGroup.ProcessOngroupmemberapplyconfirm(Data: String); var jo: ISuperObject; ja: TSuperArray; nTeamID: String; name: String; msg: String; begin try jo := SO(Data); ja := jo['args'].AsArray; nTeamID := ja[0]['groupid'].AsString; name := ja[0]['userid'].AsString; msg := ja[0]['msg'].AsString; MainForm.WebSocketJionTeamRequest(nTeamID,name,msg); except on E: Exception do Error(E.Message, 'TGroup.ProcessOngroupmemberapplyconfirm(' + Data +')'); end; end; procedure TGroup.ProcessOnGroupMemberApplyResponse(Data: String); var jo: ISuperObject; ja: TSuperArray; nTeamID : String; msg: String; begin try jo := SO(Data); ja := jo['args'].AsArray; nTeamID := ja[0]['groupid'].AsString; msg := ja[0]['msg'].AsString; if ja[0]['ret'].AsString = '5' then begin MessageBox(SearchTeamForm.Handle, PChar('群组不允许任何人加入！！！'), '提示', MB_ICONINFORMATION); end; if ja[0]['ret'].AsString = '1' then MainForm.RealICQClientJoinTeamResponse(nil,nTeamID,'管理员',msg,False); // MessageBox(SearchTeamForm.Handle, PChar('申请加入的群组不允许任何人加入！！！'), '提示', MB_ICONINFORMATION); if ja[0]['ret'].AsString = '0' then begin SendGetTeamInfo(nTeamID); MainForm.RealICQClientJoinTeamResponse(nil,nTeamID,'管理员',msg,True); end; except on E: Exception do Error(E.Message, 'TGroup.ProcessOnGroupMemberApplyResponse(' + Data +')'); end; end; procedure TGroup.ProcessOnGroupMemberleaveBroadCast(Data: String); var jo: ISuperObject; ja,jauser: TSuperArray; nTeamID: String; name: String; iLoop,jLoop: Integer; RealICQTeam: TRealICQTeam; index,itemIndex:Integer; ATeamMembers: TStringList; begin jo := SO(Data); ja := jo['args'].AsArray; nTeamID := ja[0]['id'].AsString; name := ja[0]['userid'].AsString; SendGetTeamInfo(nTeamID); // itemIndex := FTeams.IndexOf(nTeamID); // try // if itemindex >= 0 then // begin // RealICQTeam := FTeams.Objects[itemIndex] as TRealICQTeam; // if not AnsiSameText(name, MainForm.RealICQClient.LoginName) then // begin // RealICQTeam.TeamMembers := StringReplace(Chr(10) +RealICQTeam.TeamMembers + Chr(10), Chr(10) +name + char(10),char(10),[rfReplaceAll]); // RealICQTeam.TeamMembers := Copy(RealICQTeam.TeamMembers, 2, Length(RealICQTeam.TeamMembers) - 1); // MainForm.WebSocketSendReadTeamInfo(nteamID); // end // else // begin // MainForm.WebSocketQuitTeam(RealICQTeam.TeamID); // FTeams.Delete(itemIndex); // end; // end; // except // on E: Exception do // Error(E.Message, 'TGroup.ProcessOnGroupMemberleaveBroadCast(' + Data +')'); // end; end; procedure TGroup.ProcessOnGroupMemberLeaveRespone(Data: String); var jo: ISuperObject; ja: TSuperArray; nTeamID: String; itemIndex: Integer; begin jo := SO(Data); ja := jo['args'].AsArray; nTeamID := ja[0]['id'].AsString; itemIndex := FTeams.IndexOf(nTeamID); if itemIndex > -1 then begin MainForm.WebSocketQuitTeam(nTeamID); FTeams.Delete(itemIndex); end; end; procedure TGroup.ProcessOnGroupMemberRemoveBroadCast(Data: String); var jo: ISuperObject; ja,jauser: TSuperArray; ISSucceed: Boolean; nTeamID: String; msg: String; name: String; iLoop,jLoop: Integer; RealICQTeam: TRealICQTeam; index,itemIndex:Integer; begin jo := SO(Data); ja := jo['args'].AsArray; nTeamID := ja[0]['id'].AsString; jauser := ja[0]['users'].AsArray; itemIndex := Fteams.IndexOf(nTeamID); if itemindex >= -1 then begin RealICQTeam := FTeams.Objects[itemIndex] as TRealICQTeam; for jLoop := 0 to jauser.Length - 1 do begin try name := jauser[jLoop].AsString; if AnsiSameText(name, MainForm.RealICQClient.LoginName) then begin //MainForm.WebSocketRemoveTeamResponse(RealICQTeam.FTeamID); MainForm.WebSocketQuitTeam(nTeamID); FTeams.Delete(itemIndex); Exit; end; except on E: Exception do Error(E.Message, 'TGroup.ProcessOnGroupMemberRemoveBroadCast(' + Data +')'); end; end; SendGetTeamInfo(nTeamID); end; end; procedure TGroup.ProcessOnGroupMemberRemoveResponse(Data: String); var jo: ISuperObject; ja,jauser: TSuperArray; ISSucceed: Boolean; nTeamID: String; msg: String; name: String; iLoop,jLoop: Integer; RealICQTeam: TRealICQTeam; index,itemIndex:Integer; begin jo := SO(Data); ja := jo['args'].AsArray; ISSucceed := not ja[0]['ret'].AsBoolean; nTeamID := ja[0]['id'].AsString; msg := ja[0]['msg'].AsString; jauser := ja[0]['users'].AsArray; SendGetTeamInfo(nTeamID); // itemIndex := Fteams.IndexOf(nTeamID); // if itemindex >= 0 then // begin // RealICQTeam := FTeams.Objects[itemIndex] as TRealICQTeam; // for jLoop := 0 to jauser.Length - 1 do // begin // try // name := jauser[jLoop].AsString; // if not AnsiSameText(name, MainForm.RealICQClient.LoginName) then // begin // RealICQTeam.TeamMembers := StringReplace(Chr(10) +RealICQTeam.TeamMembers + Chr(10), Chr(10) +name + char(10),char(10),[rfReplaceAll]); // RealICQTeam.TeamMembers := Copy(RealICQTeam.TeamMembers, 2, Length(RealICQTeam.TeamMembers) - 1); // MainForm.WebSocketSendReadTeamInfo(nteamID); // end // else // begin // MainForm.WebSocketRemoveTeamResponse(RealICQTeam.TeamID); // FTeams.Delete(itemIndex); // end; // except // on E: Exception do // Error(E.Message, 'TGroup.ProcessOnGroupMemberRemoveResponse(' + Data +')'); // end; // end; // end; end; function TGroup.GetAlias(ATeamID, ALoginName: string): string; var itemIndex: Integer; MemberCard: TTeamMemberCard; begin Result := ''; MemberCard := GetMemberCard(ATeamID, ALoginName); if MemberCard <> nil then Result := MemberCard.Alias; end; function TGroup.GetMemberCard(ATeamID, ALoginName: string): TTeamMemberCard; var itemIndex: Integer; begin Result := nil; itemIndex := FTeamMemberCards.IndexOf(Format(MEMBERCARD_KEY, [ATeamID, ALoginName])); if ItemIndex >= 0 then Result := FTeamMemberCards.Objects[itemIndex] as TTeamMemberCard; end; function TGroup.GetOrCreateTeam(ATeamID: string): TObject; var iIndex: Integer; ATeam: TRealICQTeam; begin iIndex := FTeams.IndexOf(ATeamID); if iIndex = -1 then begin ATeam := TRealICQTeam.Create; ATeam.TeamID := ATeamID; iIndex := FTeams.AddObject(ATeamID, ATeam); end; ATeam := FTeams.objects[iIndex] as TRealICQTeam; Result := ATeam; end; function TGroup.GetTeam(ATeamID: string): TObject; var iIndex: Integer; ATeam: TRealICQTeam; begin ATeam := nil; iIndex := FTeams.IndexOf(ATeamID); if iIndex > -1 then ATeam := FTeams.objects[iIndex] as TRealICQTeam; Result := ATeam; end; procedure TGroup.ProcessOnGroupMemberUpdateResponse(Data: String); var jo: ISuperObject; ja,jaUser: TSuperArray; nTeamID: String; UserID,Alias: String; ret,ItemIndex,UserIndex: Integer; RealICQTeam : TRealICQTeam; MemberCard: TTeamMemberCard; begin jo := SO(Data); ja := jo['args'].AsArray; nTeamID := ja[0]['id'].AsString; jaUser := ja[0]['users'].AsArray; UserID := jaUser[0]['id'].AsString; Alias := jaUser[0]['alias'].AsString; MemberCard := GetMemberCard(nTeamID, UserID); if MemberCard <> nil then begin MemberCard.Alias := Alias; MainForm.WebSocketSendReadTeamInfo(nteamID); end; end; procedure TGroup.ProcessOnGroupRemoveBroadcast(Data: String); var jo: ISuperObject; ja: TSuperArray; nTeamID:String; itemIndex: Integer; begin jo := SO(Data); ja := jo['args'].AsArray; nTeamID := ja[0]['id'].AsString; itemIndex := FTeams.IndexOf(nTeamID); if itemIndex >= 0 then begin MainForm.WebSocketRemoveTeamResponse(nTeamID); FTeams.Delete(itemIndex); end; end; procedure TGroup.ProcessOnGroupRemoveResponse(Data: String); var jo: ISuperObject; ja: TSuperArray; HWnd:THandle; itemIndex: Integer; nTeamID: String; TeamCreated: Boolean; TeamCaption, FailingCause: String; RealICQTeam: TRealICQTeam; begin jo := SO(Data); ja := jo['args'].AsArray; nTeamID := ja[0]['id'].AsString; TeamCreated := not ja[0]['ret'].AsBoolean; FailingCause := ja[0]['msg'].AsString; TeamCaption := ''; itemIndex := FTeams.IndexOf(nTeamID); if itemIndex >= 0 then begin RealICQTeam := FTeams.Objects[itemIndex] as TRealICQTeam; MainForm.WebSocketRemoveTeamResponse(nTeamID); FTeams.Delete(itemIndex); FreeAndNil(RealICQTeam); end; end; procedure TGroup.ProcessOnGroupSayBroadCast(Data: String); const cUnixStartDate: TDateTime = 25569.0; var jo: ISuperObject; ja,jastyle: TSuperArray; ID: String; Groupid: String; Sayer: String; Style: String; Msg: String; TimesTamp: Int64; Hwnd: THandle; aDateTime: TDateTime; FontName,FontSize,FontsStyle,FontColor: String; jaImgs: TSuperArray; FileName,Hash: String; ret,iLoop,itemindex: Integer; begin jo := SO(Data); ja := jo['args'].AsArray; ID := ja[0]['id'].AsString; Groupid := ja[0]['groupid'].AsString; Sayer := ja[0]['sender'].AsString; jastyle := ja[0]['style'].AsArray; FontName := jastyle[0].AsString; FontColor := jastyle[2].AsString; FontSize := jastyle[1].AsString; FontsStyle := jastyle[3].AsString; Style := Format('"%s", %s, [%s], [%s]',[Fontname, FontSize, FontsStyle, FontColor]); Msg := ja[0]['msg'].AsString; TimesTamp := ja[0]['timestamp'].AsInteger; aDateTime := UnixToDateTime(Round(TimesTamp / 1000)+8*60*60); Msg := StringReplace(Msg, '\r\n', #13#10, [rfReplaceAll]); Msg := StringReplace(Msg, '[\r][\n]', '\r\n', [rfReplaceAll]); jaImgs := ja[0]['imgs'].AsArray; for ILoop := 0 to jaImgs.Length - 1 do begin ret := jaImgs[iLoop]['ret'].AsInteger; if ret =1 then begin Hash := jaImgs[iLoop]['hash'].AsString; FileName := jaImgs[iLoop]['file'].AsString; DownloadTeamFace(Hash,FileName,''); end; end; MainForm.WebSocketRecivedbroadcastmesssage(ID,Groupid,Sayer,Style,Msg,aDateTime); end; procedure TGroup.ProcessOnGroupSayResponse(Data: String); var ret: Integer; jo: ISuperObject; jaArgs,jaImgs: TSuperArray; FileName,Hash,ID,GroupId: String; iLoop,itemindex: Integer; begin //showmessage(Data); jo := SO(Data); jaArgs := jo['args'].AsArray; ID := jaArgs[0]['id'].AsString; GroupId := jaArgs[0]['groupid'].AsString; jaImgs := jaArgs[0]['imgs'].AsArray; for ILoop := 0 to jaImgs.Length - 1 do begin ret := jaImgs[iLoop]['ret'].AsInteger; Hash := jaImgs[iLoop]['hash'].AsString; FileName := jaImgs[iLoop]['file'].AsString; if ret = 0 then begin UploadFile(hash,TRealICQClient.GetReceivedFaceDir+FileName,id,GroupId); end; end; end; procedure TGroup.ProcessOnGroupSearch(Data: String); var jo : ISuperObject; ja,jaGroups : TSuperArray; searchTeams: TStringList; SearchTeam: TSearchTeamResultRecord; iLoop: Integer; begin jo := SO(Data); ja := jo['args'].AsArray; jaGroups := ja[0]['groups'].AsArray; searchTeams := TStringList.Create; try for iLoop := 0 to jaGroups.Length - 1 do begin SearchTeam := TSearchTeamResultRecord.Create; SearchTeam.TeamID := jaGroups[iLoop]['id'].AsString; SearchTeam.TeamCaption := jaGroups[iLoop]['name'].AsString; SearchTeam.TeamCreater := jaGroups[iLoop]['creator'].AsString; searchTeams.AddObject(IntToStr(iLoop),SearchTeam); end; SearchTeamForm.ShowTeamSearchResult(searchTeams); finally searchTeams.Free; end; end; procedure TGroup.ProcessOnGroupSubscribeResponse(Data: String); var jo, joFromDB: ISuperObject; ja,ja2, jaVers: TSuperArray; i, versionFromServer, versionFromDB: Integer; RealICQTeam: TRealICQTeam; nTeamID, AJson: String; HWnd: THandle; AKeyValue: TKeyValue; begin FTeams.Clear; jo := SO(Data); ja := jo.A['args']; ja2 := ja[0].A['groups']; jaVers := ja[0].A['vers']; for I := 0 to ja2.Length - 1 do begin nTeamID := ja2.S[i]; if (jaVers <> nil) and (i <= jaVers.Length - 1) then versionFromServer := jaVers.I[i] else begin SendGetTeamInfo(nTeamID); Continue; end; AKeyValue := GetMapTeamUsersProvider.FindKeyValue(nTeamID); versionFromDB := StrToIntDef(AKeyValue[2], -1); AJson := AKeyValue[1]; if (versionFromDB < 0) or (versionFromDB <> versionFromServer) or (AJson = '') then begin SendGetTeamInfo(nTeamID); end else begin joFromDB := SO(AJson); UpdateTeamInfoFromJson(joFromDB); MainForm.WebSocketSendReadTeamInfo(nTeamID); end; end; // for I := 0 to ja2.Length - 1 do // begin // nTeamID := ja2.O[i].S['id']; // versionFromServer := ja2.O[i].I['ver']; // AKeyValue := GetMapTeamUsersProvider.FindKeyValue(nTeamID); // versionFromDB := StrToIntDef(AKeyValue[2], -1); // AJson := AKeyValue[1]; // if (versionFromDB < 0) or (versionFromDB <> versionFromServer) or (AJson = '') then // begin // SendGetTeamInfo(nTeamID); // end // else // begin // joFromDB := SO(AJson); // UpdateTeamInfoFromJson(joFromDB); // MainForm.WebSocketSendReadTeamInfo(nTeamID); // end; // end; end; { TODO -olqq -c : 统一Send方法发送数据，统一异常处理 2014/12/13 23:03:17 } procedure TGroup.Send(Data: string); begin try if (FClient <> nil) and (not FClient.Closed) then FClient.SendText(AnsiToUTF8(Data)); except on E: Exception do begin Error(E.Message, 'TGroup.Send('+Data+')'); end; end; end; procedure TGroup.SendGetTeamInfo(ATeamID: String); var SendStr:String; jo: ISuperObject; begin SendStr := '5:::'+ '{"name":"group.info","args":{"id":"","groups":[{"id":"'+ATeamID+'","ver":0}]}}'; { TODO -olqq -c : 统一发送调用 2014/12/13 12:38:42 } Send(SendStr); //FClient.SendText(AnsiToUTF8(SendStr));//, GetCurCP, UTF_8)); end; procedure TGroup.SendMessage(Data: String); begin { TODO -olqq -c : 统一发送调用 2014/12/13 12:38:42 } Send(Data); //FClient.SendText({CharsetConversion(Dat a, GetCurCP, UTF_8)}AnsiToUTF8(Data)); end; procedure TGroup.SetGetTeamInfo(const Value: TOnGetTeamInfo); begin FOnGetTeamInfo := Value; end; procedure TGroup.SetLoginName(const Value: string); begin FLoginName := Value; end; procedure TGroup.Start; var IdHttp:TIdHTTP; ResponeStr: String; ResourceName: String; tempstringlist : TStringList; heartbeatTimeOut: Integer; begin IdHttp:= TIdHTTP.Create(nil); try ResponeStr := Idhttp.get('http://'+FIP+':'+inttostr(FPort)+'/socket.io/1/'); except on E: Exception do begin Freeandnil(IdHttp); Error(E.Message, 'TGroup.Start'); Reconnect; Exit; end; end; Freeandnil(IdHttp); tempstringlist := TStringList.create; try tempstringlist.Delimiter := ':'; tempstringlist.DelimitedText := ResponeStr; ResourceName := tempstringlist[0]; heartbeatTimeOut := StrToInt(tempstringlist[1]); except on E: Exception do begin tempstringlist.Free; Error(E.Message, 'TGroup.Start'); Reconnect; Exit; end; end; tempstringlist.Free; FClient := TTestWebSocketClientConnection.Create(FIP, inttostr(FPort), '/socket.io/1/websocket/'+ResourceName,'-','ws'); FClient.OnRead := OnRead; FClient.OnWrite := OnWrite; FClient.OnClose := OnClose; FClient.OnOpen := OnOpen; //fClient.Socket.OnSyncStatus := OnConnectionSocket; // FClient.SSL := FUseSSL; FClient.Start; { TODO -olqq -c : 服务端已经有心跳发送 2014/12/12 16:07:11 } end; procedure TGroup.StopReconnect; begin MainForm.TimerForreconnectgroup.Enabled := False; end; procedure TGroup.TestEvent; begin if Assigned(FOnGetTeamInfo) then try FOnGetTeamInfo('11111122'); except on e:Exception do showmessage(e.Message); end; end; {$ENDREGION} {$REGION '请求'} { TODO -olqq -c : 代替TMainForm.WebSocketInHttpSendFile 2014/12/16 12:53:56 } procedure TGroup.UploadFile(Hash, FileName, ID, GroupID: String); var AHttp: TIdHttp; MutPartForm:TIdMultiPartFormDataStream; Ret:TStringStream; response,UpUrl: String; jo,t,jofile: ISuperObject; SendStr: String; begin UpUrl := Format(UPLOAD_URL, [FImageIP, FImagePort]); AHttp := Tidhttp.Create(nil); AHttp.Request.ContentType:='multipart/form-data'; AHttp.HandleRedirects := true; AHttp.AllowCookies := true; MutPartForm := TIdMultiPartFormDataStream.Create; MutPartForm.AddFile('file1', FileName,''); try response := AHttp.Post(UpUrl, MutPartForm); Application.ProcessMessages; finally MutPartForm.Free; AHttp.Free; end; if response = 'ok' then begin jo := SO(); jo.S['name'] := 'group.file'; jo.S['args.id'] := id; jo.S['args.groupid'] := GroupId; t := SA([]); jofile := SO(); jofile.S['file'] := ExtractFileName(filename); jofile.S['hash'] := hash; t.AsArray.Add(jofile); jo['args.files'] := t; SendStr := '5:::' + jo.AsJSon(False,False); Send(SendStr); end; end; procedure TGroup.AddTeamMembers(ATeamID: String; AUsers: TStringList); var jo :ISuperObject; iLoop : Integer; moreusers: String; begin jo := SO(ADDMEMBERS_PROTOCOL); jo.S['args.id'] := ATeamID; for iLoop := 0 to AUsers.Count - 1 do jo.A['args.users'].Add(TSuperObject.Create(AUsers[iLoop])); moreusers := '5:::' + jo.AsJSon(False,False); Send(moreusers); end; procedure TGroup.RemoveTeamMembers(ATeamID: string; AUsers: TStringList); var jo :ISuperObject; iLoop : Integer; moreusers: String; begin jo := SO(REMOVEMEMBERS_PROTOCOL); jo.S['args.id'] := ATeamID; for iLoop := 0 to AUsers.Count - 1 do begin jo.A['args.users'].Add(TSuperObject.Create(AUsers[iLoop])); end; moreusers := '5:::' + jo.AsJSon(False,False); Send(moreusers); end; procedure TGroup.UpdateTeamInfo(ATeamID, AIntro, ANotice, AName: string; AAuth: Integer); var TeamInfo: String; obj: ISuperObject; begin AIntro := StringReplace(AIntro, '\r\n', '[\r][\n]', [rfReplaceAll]); AIntro := StringReplace(AIntro, #13#10, '\r\n', [rfReplaceAll]); ANotice := StringReplace(ANotice, '\r\n', '[\r][\n]', [rfReplaceAll]); ANotice := StringReplace(ANotice, #13#10, '\r\n', [rfReplaceAll]); obj := SO(); obj['name'] := TSuperObject.Create('group.update'); obj['args.id'] := TSuperObject.Create(ATeamID); obj['args.group.intro'] := TSuperObject.Create(AIntro); obj['args.group.notice'] := TSuperObject.Create(ANotice); obj['args.group.name'] := TSuperObject.Create(AName); obj['args.group.auth'] := TSuperObject.Create(AAuth); TeamInfo := '5:::' + obj.AsJSon(False,False); Send(TeamInfo); end; procedure TGroup.SendTeamMessage(ATeamID, ASender, AMsg: String; AFont: TFont; AFaces: TStringList; Attachs: String); var jo : ISuperObject; joStyle: ISuperObject; tFile,jofile: ISuperObject; tAttach,joattach: ISuperObject; sendstr: String; MD5HashValue: MD5Digest; MD5HashString: String; iLoop: Integer; AFace: TFace; begin AMsg := StringReplace(AMsg, '\r\n', '[\r][\n]', [rfReplaceAll]); AMsg := StringReplace(AMsg, #13#10, '\r\n', [rfReplaceAll]); jo := SO(); jo.S['name'] := 'group.say'; jo.S['args.id'] := ''; jo.S['args.groupid'] := ATeamID; jo.S['args.sender'] := ASender; joStyle := SA([]); joStyle.AsArray.S[0] := AFont.Name; joStyle.AsArray.S[1] := inttostr(AFont.Size); joStyle.AsArray.S[2] := ColorToString(AFont.Color); joStyle.AsArray.S[3] := FontStyleToString(AFont); jo['args.style'] := joStyle; jo.S['args.msg'] := AMsg; jo.S['args.timestamp'] :=''; tFile := SA([]); for iLoop := 0 to AFaces.Count - 1 do begin AFace := AFaces.Objects[iLoop] as TFace; jofile := SO(); jofile.S['file'] := ExtractFileName(AFace.FileName); jofile.S['hash'] := UpperCase(AFace.MD5Code); tFile.AsArray.Add(jofile); end; jo['args.imgs'] := tFile; tAttach := SA([]); jo['args.attachs'] := tAttach; sendstr := '5:::' + jo.AsJSon(False,False); Send(sendstr); if Assigned(AFaces) and (AFaces.Count > 0) then TRealICQUtility.FreeStringList(AFaces as TStringList); end; procedure TGroup.Subscribe; var str:String; begin str := Format(SUBSCRIBE_PROTOCOL, [FLoginName]); Send(str); end; procedure TGroup.UnSubscribe; var str:String; begin str := Format(UNSUBSCRIBE_PROTOCOL, [FLoginName]); Send(str); end; procedure TGroup.Search(AKey, AName, ATeamID, ACreator: String); var jo: ISuperObject; SearchStr: String; begin jo := SO(); jo['name'] := TSuperObject.Create('group.search'); jo['args.keyword'] := TSuperObject.Create(AKey); jo['args.name'] := TSuperObject.Create(AName); jo['args.groupid'] := TSuperObject.Create(ATeamID); jo['args.creator'] := TSuperObject.Create(ACreator); SearchStr := '5:::' + jo.AsJSon(False,False); Send(SearchStr); end; procedure TGroup.AddManager(ATeamID, AName: String); var addManager: String; begin addManager := Format(ADDMANAGER_PROTOCOL, [ATeamID, AName]); Send(addManager); end; procedure TGroup.Reconnect; begin MainForm.TimerForreconnectgroup.Enabled := False; MainForm.TimerForreconnectgroup.Interval := RandomRange(10000,60000); Info(IntToStr(MainForm.TimerForreconnectgroup.Interval) + '毫秒之后，开始重连。', 'TGroup.Reconnect'); MainForm.TimerForreconnectgroup.Enabled := True; end; procedure TGroup.RemoveManager(ATeamID, AName: String); var addManager: String; begin addManager := Format(REMOVEMANAGER_PROTOCOL, [ATeamID, AName]); Send(addManager); end; procedure TGroup.Leave(ATeamID: string); var MemberQuit: String; begin MemberQuit := Format(LEAVE_PROTOCOL, [ATeamID, FLoginName]); Send(MemberQuit); end; procedure TGroup.RemoveMember(ATeamID,AName: String); var RemoveMember: String; begin RemoveMember := Format(REMOVEMEMBER_PROTOCOL, [ATeamID, AName]); Send(RemoveMember); end; procedure TGroup.RemoveTeam(ATeamID: String); var DeleteGroup:String; begin DeleteGroup := Format(REMOVETEAM_PROTOCOL, [ATeamID]); Send(DeleteGroup); end; procedure TGroup.JoinTeamResponse(ATeamID, ALoginName, AMsg: String; ARet : Integer); var jo: ISuperObject; ResponseStr: String; begin jo := SO(); jo.S['name'] := 'group.member.apply.confirm.reply'; jo.S['args.id'] := ''; jo.S['args.groupid'] := ATeamID; jo.S['args.userid'] := ALoginName; jo.I['args.ret'] := ARet; jo.S['args.msg'] := AMsg; ResponseStr := '5:::' + jo.AsJSon(False,False); Send(ResponseStr); end; procedure TGroup.JoinTeam(ATeamID, ATag: String); var jo : ISuperObject; SearchStr: String; begin if group.Teams.IndexOf(ATeamID) >= 0 then raise Exception.CreateFmt('%s 已在群组列表中', [ATeamID]); jo := SO(); jo.S['name'] := 'group.member.apply'; jo.S['args.id'] := ''; jo.S['args.groupid'] := ATeamID; jo.S['args.userid'] := FLoginName; jo.S['args.msg'] := ATag; SearchStr := '5:::' + jo.AsJSon(False,False); Send(SearchStr); end; procedure TGroup.DownloadTeamFace(AMD5String, AFileName, Path: String); var FileStream: TFileStream; idHTTP: TIDHTTP; URL: String; ss: String; begin URL := Format(DOWNLOAD_URL, [FImageIP, FImagePort, AMD5String]); FDownFile.OnComplete := DownFaceFileComplete; FDownFile.ThreadDownFile(URL,TRealICQClient.GetReceivedFaceDir+AFileName); end; function TGroup.FormatStrFromServer(AStr: string): string; begin Result := StringReplace(AStr, '\r\n', #13#10, [rfReplaceAll]); Result := StringReplace(Result, '[\r][\n]', '\r\n', [rfReplaceAll]); end; function TGroup.FormatStrToServer(AStr: string): string; begin end; procedure TGroup.DownFaceFileComplete(Source_file, Dest_file: String; blStatus: boolean; ErrMessage: String); begin ShowGettedFace(Dest_file); end; procedure TGroup.SetAlias(ATeamID, ALoginName, Alias: String); var jo, jouser, t: ISuperObject; SendStr: String; begin jo := SO(); jo.S['name'] := 'group.member.update'; jo.S['args.id'] := ATeamID; t := SA([]); jouser := SO(); jouser.S['id'] := ALoginName; jouser.S['alias'] := Alias; t.AsArray.Add(jouser); jo['args.users'] := t; SendStr := '5:::' + jo.AsJSon(False,False); Send(SendStr); end; procedure TGroup.SendFilesRequest(AGroupId, AUserId, FileName: String); var jo,jofile: ISuperObject; t : ISuperObject; SendFileStr: String; MD5HashValue: MD5Digest; MD5HashString: String; begin MD5HashValue := MD5File(FileName); MD5HashString := MD5.MD5Print(MD5HashValue); jo := SO(); jo.S['name'] := 'file.upload'; jo.S['args.groupid'] := AGroupId; jo.S['args.userid'] := AUserId; jo.S['args.id'] := ''; t := SA([]); jofile := SO(); jofile.S['file'] := ExtractFileName(filename); jofile.S['hash'] := UpperCase(MD5HashString); t.AsArray.Add(jofile); jo['args.files'] := t; SendFileStr := '5:::' + jo.AsJSon(False,False); Send(SendFileStr); end; procedure TGroup.CreateTeam(ATeamName, ATeamCallBoard, ATeamIntro: String; ATeamMembers: TStringList; AIsTempTeam: Boolean); var createGroup:String; jo: ISuperObject; ja: TSuperArray; iLoop: Integer; begin jo := SO('{"name":"group.add","args":{"name":"","type":"","creator":"","users":[]}}'); jo.S['args.name'] := Trim(ATeamName); jo.I['args.type'] := 0; jo.S['args.creator'] := FLoginName; ja := jo.A['args.users']; for iLoop := 1 to ATeamMembers.Count - 1 do ja.S[iloop-1] := ATeamMembers[iLoop]; createGroup := '5:::'+ jo.AsJSon(False, False); Send(createGroup); end; {$ENDREGION} end.