client_mainform.pas

Delphi快速开发Web Server

unit Client_MainForm;

interface

uses
  Windows, Messages, SysUtils, 
  Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, StdCtrls, Buttons, ExtCtrls,
  ImgList, Menus,

  rtcConn, rtcDataCli, rtcHttpCli,
  rtcInfo, rtcCliModule, rtcFunction,

  tools,

  Client_ChatForm;

const
  MSG_STATUS_UNKNOWN=0;
  MSG_STATUS_OFFLINE=1;
  MSG_STATUS_ONLINE=2;
  MSG_STATUS_IGNORE=3;

type
  TForm1 = class(TForm)
    ClientModule: TRtcClientModule;
    Client: TRtcHttpClient;
    MessengerTab: TPageControl;
    tabLogin: TTabSheet;
    tabFriends: TTabSheet;
    tabIgnore: TTabSheet;
    Panel1: TPanel;
    Panel2: TPanel;
    btnLogout: TBitBtn;
    panLogin: TPanel;
    Panel4: TPanel;
    eServerAddr: TEdit;
    Label1: TLabel;
    eServerPort: TEdit;
    Label2: TLabel;
    eModulePath: TEdit;
    Label3: TLabel;
    Label4: TLabel;
    eLoginUser: TEdit;
    Label5: TLabel;
    eLoginPass: TEdit;
    btnLogin: TBitBtn;
    btnRegister: TBitBtn;
    btnAddFriend: TBitBtn;
    Panel5: TPanel;
    Panel6: TPanel;
    btnLogout2: TBitBtn;
    btnAddIgnore: TBitBtn;
    tvFriends: TTreeView;
    tvIgnore: TTreeView;
    resLogin: TRtcResult;
    lblLogin: TLabel;
    resUpdate: TRtcResult;
    resTimer: TRtcResult;
    resSendText: TRtcResult;
    pmFriends: TPopupMenu;
    SendMessage1: TMenuItem;
    N1: TMenuItem;
    btnDelFriend: TMenuItem;
    AddNewFriend1: TMenuItem;
    pmIgnore: TPopupMenu;
    AddnewIgnore1: TMenuItem;
    N2: TMenuItem;
    btnDelIgnore: TMenuItem;
    resLogout: TRtcResult;
    TimerClient: TRtcHttpClient;
    TimerModule: TRtcClientModule;
    resTimerLogin: TRtcResult;
    msgImages: TImageList;
    pingTimer: TTimer;
    resPing: TRtcResult;
    xUseProxy: TCheckBox;
    xUseXMLRPC: TCheckBox;
    procedure btnLogoutClick(Sender: TObject);
    procedure btnLoginClick(Sender: TObject);
    procedure resLoginReturn(Sender: TRtcConnection; Data,
      Result: TRtcValue);
    procedure ClientModuleResponseAbort(Sender: TRtcConnection);
    procedure FormCreate(Sender: TObject);
    procedure btnRegisterClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure resUpdateReturn(Sender: TRtcConnection; Data,
      Result: TRtcValue);
    procedure btnAddFriendClick(Sender: TObject);
    procedure btnAddIgnoreClick(Sender: TObject);
    procedure btnSendMessageClick(Sender: TObject);
    procedure msgTimerTimer(Sender: TObject);
    procedure resTimerReturn(Sender: TRtcConnection; Data,
      Result: TRtcValue);
    procedure resSendTextReturn(Sender: TRtcConnection; Data,
      Result: TRtcValue);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure btnDelFriendClick(Sender: TObject);
    procedure btnDelIgnoreClick(Sender: TObject);
    procedure resLogoutReturn(Sender: TRtcConnection; Data,
      Result: TRtcValue);
    procedure resTimerLoginReturn(Sender: TRtcConnection; Data,
      Result: TRtcValue);
    procedure pingTimerTimer(Sender: TObject);
    procedure resPingReturn(Sender: TRtcConnection; Data,
      Result: TRtcValue);
  private
    { Private declarations }
  public
    { Public declarations }
    do_notify:boolean;

    oldUserName,
    myUserName:string;
    myCheckTime:TDateTime;

    procedure StartLogin;

    procedure FriendList_Clear;
    procedure IgnoreList_Clear;

    procedure FriendList_Add(uname:string);
    procedure FriendList_Del(uname:string);
    procedure IgnoreList_Add(uname:string);
    procedure IgnoreList_Del(uname:string);

    function FriendList_Selected:string;
    function IgnoreList_Selected:string;

    procedure SendText(to_user,msg:string);

    function isFriend(uname:string):boolean;
    function isIgnore(uname:string):boolean;

    procedure FriendList_Status(uname:string; status:integer);

    procedure make_notify(uname, ntype :string);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
  begin
  Width:=206;

  do_notify:=False;

  myUserName:='';
  oldUserName:='';

  // Assign the method for sending a Text message (used by Chat_Form)
  SendMsg:=SendText;

  MessengerTab.ActivePage:=tabLogin;
  tabLogin.TabVisible:=True;
  tabFriends.TabVisible:=False;
  tabIgnore.TabVisible:=False;
  panLogin.Enabled:=True;
  end;

procedure TForm1.FormShow(Sender: TObject);
  begin
  if tabLogin.TabVisible and tabLogin.Visible then
    eLoginUser.SetFocus;
  end;

procedure TForm1.StartLogin;
  begin
  Client.Disconnect;
  Client.ServerAddr:=eServerAddr.Text;
  Client.ServerPort:=eServerPort.Text;
  Client.UseProxy:=xUseProxy.Checked;
  Client.SkipRequests;
  Client.Session.Close;
  with ClientModule do
    begin
    if xUseXMLRPC.Checked then
      DataFormat:=fmt_XMLRPC
    else
      DataFormat:=fmt_RTC;
    ModuleFileName:=eModulePath.Text;
    if copy(ModuleFileName,length(ModuleFileName),1)<>'/' then
      ModuleFileName:=ModuleFileName+'/';
    ModuleFileName:=ModuleFileName+'$MSG';

    ModuleHost:=eServerAddr.Text;
    end;

  TimerClient.ServerAddr:=eServerAddr.Text;
  TimerClient.ServerPort:=eServerPort.Text;
  TimerClient.UseProxy:=xUseProxy.Checked;
  TimerClient.SkipRequests;
  TimerClient.Session.Close;
  with TimerModule do
    begin
    if xUseXMLRPC.Checked then
      DataFormat:=fmt_XMLRPC
    else
      DataFormat:=fmt_RTC;
    ModuleFileName:=eModulePath.Text;
    if copy(ModuleFileName,length(ModuleFileName),1)<>'/' then
      ModuleFileName:=ModuleFileName+'/';
    ModuleFileName:=ModuleFileName+'$MSG';

    ModuleHost:=eServerAddr.Text;
    end;

  Client.Connect;

  do_notify:=False;

  btnLogin.Enabled:=False;
  btnRegister.Enabled:=False;
  lblLogin.Visible:=True;

  panLogin.Enabled:=False;
  end;

procedure TForm1.btnLoginClick(Sender: TObject);
  begin
  StartLogin;
  with ClientModule, Data.NewFunction('login') do
    begin
    Value['User']:=eLoginUser.Text;
    Value['Pass']:=eLoginPass.Text;
    Call(resLogin);
    end;
  with TimerModule, Data.NewFunction('login2') do
    begin
    Value['User']:=eLoginUser.Text;
    Value['Pass']:=eLoginPass.Text;
    Call(resTimerLogin);
    end;
  end;

procedure TForm1.btnRegisterClick(Sender: TObject);
  begin
  StartLogin;
  with ClientModule, Data.NewFunction('register') do
    begin
    Value['User']:=eLoginUser.Text;
    Value['Pass']:=eLoginPass.Text;
    Call(resLogin);
    end;
  with TimerModule, Data.NewFunction('login2') do
    begin
    Value['User']:=eLoginUser.Text;
    Value['Pass']:=eLoginPass.Text;
    Call(resTimerLogin);
    end;
  end;

procedure TForm1.btnLogoutClick(Sender: TObject);
  begin
  if Sender<>nil then
    begin
    do_notify:=False;
    pingTimer.Enabled:=False;
    with ClientModule, Data.NewFunction('Logout') do
      begin
      Value['User']:=myUserName;
      myUserName:='';
      Call(resLogout);
      end;
    end
  else
    begin
    ClientModule.SkipRequests;
    TimerModule.SkipRequests;

    do_notify:=False;
    pingTimer.Enabled:=False;

    myUserName:='';

    panLogin.Enabled:=True;

    lblLogin.Visible:=False;
    btnLogin.Enabled:=True;
    btnRegister.Enabled:=True;

    tabLogin.TabVisible:=True;
    tabFriends.TabVisible:=False;
    tabIgnore.TabVisible:=False;

    TChatForm.disableAllForms;

    eLoginUser.SetFocus;

    Client.Disconnect;
    TimerClient.Disconnect;
    end;
  end;

procedure TForm1.ClientModuleResponseAbort(Sender: TRtcConnection);
  begin
  with TRtcDataClient(Sender) do
    begin
    btnLogoutClick(nil);
    MessageBeep(0);
    ShowMessage('Error sending a request to the Messenger Server.'#13#10+'Connection to Server lost.');
    end;
  end;

procedure TForm1.resLoginReturn(Sender: TRtcConnection; Data, Result: TRtcValue);
  var
    i:integer;
  begin
  if Result.isType=rtc_Exception then
    begin
    btnLogoutClick(nil);
    MessageBeep(0);
    ShowMessage(Result.asString);
    end
  else if Result.isType<>rtc_Record then
    begin
    btnLogoutClick(nil);
    MessageBeep(0);
    ShowMessage('Invalid Server Response.');
    end
  else
    begin
    TChatForm.enableAllForms;

    myUserName:=Data.asFunction.asString['user'];
    if oldUserName<>myuserName then
      TChatForm.closeAllForms;

    oldUserName:=myUserName;
    with Result.asRecord do
      begin
      FriendList_Clear;
      IgnoreList_Clear;

      if isType['friends']=rtc_Record then
        with asRecord['friends'] do
          for i:=0 to Count-1 do
            FriendList_Add(FieldName[i]);

      if Result.asRecord.isType['ignore']=rtc_Record then
        with asRecord['ignore'] do
          for i:=0 to Count-1 do
            IgnoreList_Add(FieldName[i]);
      end;

    lblLogin.Visible:=False;
    tabFriends.TabVisible:=True;
    tabIgnore.TabVisible:=True;
    tabLogin.TabVisible:=False;
    MessengerTab.ActivePage:=tabFriends;

    TimerClient.Connect;
    msgTimerTimer(nil);

    pingTimer.Enabled:=True;
    end;
  end;

procedure TForm1.resUpdateReturn(Sender: TRtcConnection; Data, Result: TRtcValue);
  begin
  if Result.isType=rtc_Exception then
    begin
    if Sender<>nil then
      PostInteractive; // ShowMessage would block the connection, need to post interactive

    if UpperCase(Data.asFunction.FunctionName)='ADDFRIEND' then
      FriendList_Del(Data.asFunction.asString['name'])
    else if UpperCase(Data.asFunction.FunctionName)='ADDIGNORE' then
      IgnoreList_Add(Data.asFunction.asString['name'])
    else
      btnLogoutClick(nil);

    MessageBeep(0);
    ShowMessage(Result.asString);
    end;
  end;

procedure TForm1.FriendList_Clear;
  begin
  tvFriends.Items.Clear;
  end;

procedure TForm1.IgnoreList_Clear;
  begin
  tvIgnore.Items.Clear;
  end;

procedure TForm1.FriendList_Add(uname: string);
  var
    node:TTreeNode;
  begin
  if isFriend(uname) then Exit;

  uname:=LowerCase(uname);
  node:=tvFriends.Items.Add(nil,uname);
  node.ImageIndex:=MSG_STATUS_UNKNOWN;
  node.SelectedIndex:=MSG_STATUS_UNKNOWN;
  node.StateIndex:=MSG_STATUS_UNKNOWN;
  tvFriends.Update;
  end;

procedure TForm1.IgnoreList_Add(uname: string);
  var
    node:TTreeNode;
  begin
  if isIgnore(uname) then Exit;

  uname:=LowerCase(uname);
  node:=tvIgnore.Items.Add(nil,uname);
  node.ImageIndex:=MSG_STATUS_IGNORE;
  node.SelectedIndex:=MSG_STATUS_IGNORE;
  node.StateIndex:=MSG_STATUS_IGNORE;
  tvIgnore.Update;
  end;

procedure TForm1.FriendList_Del(uname: string);
  var
    i:integer;
    node:TTreeNode;
  begin
  uname:=LowerCase(uname);
  for i:=0 to tvFriends.Items.Count-1 do
    begin
    node:=tvFriends.Items.Item[i];
    if LowerCase(node.Text)=uname then
      begin
      node.Delete;
      Break;
      end;
    end;
  end;

procedure TForm1.IgnoreList_Del(uname: string);
  var
    i:integer;
    node:TTreeNode;
  begin
  uname:=LowerCase(uname);
  for i:=0 to tvIgnore.Items.Count-1 do
    begin
    node:=tvIgnore.Items.Item[i];
    if LowerCase(node.Text)=uname then
      begin
      node.Delete;
      Break;
      end;
    end;
  end;

function TForm1.isFriend(uname: string): boolean;
  var
    i:integer;
    node:TTreeNode;
  begin
  uname:=LowerCase(uname);
  Result:=False;
  for i:=0 to tvFriends.Items.Count-1 do