rtcmessenger.pas

来自「Delphi快速开发Web Server」· PAS 代码 · 共 820 行 · 第 1/2 页

unit rtcMessenger;

interface

uses
  SysUtils,

{$IFDEF VER120}
  FileCtrl,
{$ENDIF}
{$IFDEF VER130}
  FileCtrl,
{$ENDIF}

  rtcSyncObjs,
  rtcInfo, rtcCrypt,
  rtcSrvModule;

const
  MSG_LIST_CRYPT_KEY:string='$RtcMessenger_UserList';
  MSG_DATA_CRYPT_KEY:string='$RtcMessenger_UserData';
  MSG_INFO_CRYPT_KEY:string='$RtcMessenger_UserInfo';

  // Sub-Folder relative to AppFileName, inside which Messenger Data files will be stored
  MSG_DATA_FOLDER:string='RtcMessengerData';

type
  TRtcMessengerUsers=class
  private
    UserListFileName:string;
    UserDataFileName:string;
    UserList:tRtcRecord;

    UserInfo:tRtcInfo;

    userCS:TRtcCritSec;
    msgCS:TRtcCritSec;

    procedure doLogIn(uname,sessid:string);
    procedure doLogIn2(uname,sessid:string); // 2nd connnection
    procedure doLogOut(uname,sessid:string);

    function isValidUserName(const uname:string):boolean;

    procedure SendData(const to_name:string; data:TRtcValueObject);

    function GetCallback(uname:string):TRtcDelayedCall;

    procedure TriggerCallback(uname:string);

  public
    constructor Create;
    destructor Destroy; override;

    procedure SetCallback(uname:string; cb:TRtcDelayedCall);

    procedure LoadUserList;
    procedure SaveUserList;

    function isLoggedIn(uname,sessid:string):boolean; overload;
    function isLoggedIn(uname:string):boolean; overload;

    procedure Login(uname,upass,sessid:string);
    procedure Login2(uname,upass,sessid:string); // 2nd connection
    procedure Logout(uname,sessid:string);

    procedure RegUser(uname,upass,sessid:string);
    procedure ChangePass(uname,oldpass,newpass:string);
    procedure DelUser(uname:string);

    procedure AddFriend(uname,friend_name:string);
    procedure DelFriend(uname,friend_name:string);
    procedure AddIgnore(uname,ignore_name:string);
    procedure DelIgnore(uname,ignore_name:string);

    function LoadInfo(uname:string):TRtcRecord;
    procedure SaveInfo(uname:string; info:TRtcRecord);

    function Exists(uname:string):boolean;

    procedure SendText(const from_name,to_name,text:string);

    function GetData(const uname:string; lastcheck:TDateTime; var thischeck:TDateTime): TRtcArray;
    end;

implementation

{ TRtcMessengerUsers }

constructor TRtcMessengerUsers.Create;
  begin
  inherited;

  userCS:=TRtcCritSec.Create;
  msgCS:=TRtcCritSec.Create;

  UserDataFileName:=ExtractFilePath(AppFileName);
  if Copy(UserDataFileName,length(UserDataFileName),1)<>'\' then
    UserDataFileName:=UserDataFileName+'\';

  if MSG_DATA_FOLDER<>'' then
    begin
    UserDataFileName:=UserDataFileName+MSG_DATA_FOLDER;
    if not DirectoryExists(UserDataFileName) then
      if not CreateDir(UserDataFileName) then
        begin
        UserDataFileName:=GetTempDirectory;
        if Copy(UserDataFileName,length(UserDataFileName),1)<>'\' then
          UserDataFileName:=UserDataFileName+'\';
        UserDataFileName:=UserDataFileName+MSG_DATA_FOLDER;
        if not DirectoryExists(UserDataFileName) then
          CreateDir(UserDataFileName);
        end;
    end;

  UserListFileName:=UserDataFileName+'\Users.list';
  UserDataFileName:=UserDataFileName+'\';

  UserInfo:=TRtcInfo.Create;
  LoadUserList;
  end;

destructor TRtcMessengerUsers.Destroy;
  begin
  UserInfo.Free;
  UserList.Free;
  userCS.Free;
  msgCS.Free;
  inherited;
  end;

procedure TRtcMessengerUsers.LoadUserList;
  var
    s:string;
  begin
  userCS.Enter;
  try
    if File_Exists(UserListFileName) then
      begin
      s:=Read_File(UserListFileName);
      DeCrypt(s,MSG_LIST_CRYPT_KEY);
      end
    else
      s:='';
    if assigned(UserList) then
      UserList.Free;
    if s<>'' then
      UserList:=TRtcRecord.FromCode(s)
    else
      UserList:=TRtcRecord.Create;
  finally
    userCS.Leave;
    end;
  end;

procedure TRtcMessengerUsers.SaveUserList;
  var
    s:string;
  begin
  userCS.Enter;
  try
    s:=UserList.toCode;
    Crypt(s,MSG_LIST_CRYPT_KEY);
    if not Write_File(UserListFileName,s) then
      raise Exception.Create('Error writing UserList to "'+UserListFileName+'".');
  finally
    userCS.Leave;
    end;
  end;

function TRtcMessengerUsers.LoadInfo(uname:string):TRtcRecord;
  var
    s:string;
  begin
  userCS.Enter;
  try
    if File_Exists(UserDataFileName+'User.'+uname+'.info') then
      begin
      s:=Read_File(UserDataFileName+'User.'+uname+'.info');
      DeCrypt(s, MSG_INFO_CRYPT_KEY);
      Result:=TRtcRecord.FromCode(s);
      end
    else
      Result:=TRtcRecord.Create;
    Result.AutoCreate:=True;
  finally
    userCS.Leave;
    end;
  end;

procedure TRtcMessengerUsers.SaveInfo(uname:string; info:TRtcRecord);
  var
    s:string;
  begin
  userCS.Enter;
  try
    s:=info.toCode;
    Crypt(s, MSG_INFO_CRYPT_KEY);
    Write_File(UserDataFileName+'User.'+uname+'.info',s);
  finally
    userCS.Leave;
    end;
  end;

procedure TRtcMessengerUsers.doLogIn2(uname,sessid:string);
  begin
  userCS.Enter;
  try
    // Remember new session ID
    if UserInfo.Child[uname]=nil then
      raise Exception.Create('Not logged in.')
    else with UserInfo.Child[uname] do
      asString['Session2']:=sessid;
  finally
    userCS.Leave;
    end;
  end;

procedure TRtcMessengerUsers.doLogIn(uname,sessid:string);
  var
    info,info2,rec,rec2:TRtcRecord;
    cb:TRtcDelayedCall;
    fname:string;
    i:integer;
    log_in:boolean;
  begin
  userCS.Enter;
  try
    // Get callback info, if exists
    cb:=GetCallback(uname);
    // Remove existing info.
    UserInfo.SetNil(uname);
    // Remember new session ID
    with UserInfo.NewChild(uname) do
      asString['Session']:=sessid;
  finally
    userCS.Leave;
    end;

  // Trigger calback, if it was set (second connectin was open and is now waiting).
  // This will signal the waiting connection to execute,
  // which will end in an exception "not logged in" and close the connection.
  if assigned(cb) then
    cb.WakeUp;

  info:=LoadInfo(uname);
  try
    if info.isType['friends']=rtc_Record then
      with info.asRecord['friends'] do
        begin
        rec:=TRtcRecord.Create;
        rec2:=TRtcRecord.Create;
        try
          for i:=0 to Count-1 do // Send "login" message to all friends.
            begin
            fname:=FieldName[i];
            info2:=LoadInfo(fname);
            try
              if info2.isType['friends']=rtc_Record then
                if not info2.asRecord['friends'].isNull[uname] then // we are in our friend's list
                  begin
                  userCS.Enter;
                  try
                    log_in:=UserInfo.Child[fname]<>nil;
                  finally
                    userCS.Leave;
                    end;
                  if log_in then // friend logged in
                    begin
                    // Send ourself info that friend is logged in.
                    rec.asString['login']:=fname;
                    SendData(uname, rec);

                    // Send friend info that we're logging in.
                    rec.asString['login']:=uname;
                    SendData(fname, rec);
                    end
                  else
                    begin
                    // Send ourself info that friend is NOT logged in.
                    rec2.asString['logout']:=fname;
                    SendData(uname, rec2);
                    end;
                  end;
            finally
              info2.Free;
              end;
            end;
        finally
          rec.Free;
          rec2.Free;
          end;
        end;
  finally
    info.Free;
    end;
  end;

procedure TRtcMessengerUsers.doLogOut(uname,sessid:string);
  var
    info,rec:TRtcRecord;
    log_out,log_in:boolean;
    cb:TRtcDelayedCall;
    i:integer;
    fname:string;
  begin
  cb:=nil;
  log_out:=False;
  userCS.Enter;
  try
    // If logged in under this session ID, remove info
    if UserInfo.Child[uname]<>nil then
      if UserInfo.Child[uname]['session']=sessid then
        begin
        cb:=GetCallback(uname);
        UserInfo.SetNil(uname);
        log_out:=True;
        end;
  finally
    userCS.Leave;
    end;

  if log_out then
    begin
    // Triger Callback after Logout, to signal the second connection to check user status.
    // This will end in "user not logged in" exception and close the connection.
    if assigned(cb) then
      cb.WakeUp;

    info:=LoadInfo(uname);
    try
      if info.isType['friends']=rtc_Record then
        with info.asRecord['friends'] do
          begin
          rec:=TRtcRecord.Create;
          try
            for i:=0 to Count-1 do // for all Friends in out list ...
              begin
              fname:=FieldName[i];
              userCS.Enter;
              try
                log_in:=UserInfo.Child[fname]<>nil;
              finally
                userCS.Leave;
                end;
              if log_in then // friend logged in
                begin
                // Send friend info that we're logging out.
                rec.asString['logout']:=uname;
                SendData(fname, rec);
                end;
              end;
          finally
            rec.Free;
            end;
          end;
    finally
      info.Free;
      end;
    end;
  end;

function TRtcMessengerUsers.isLoggedIn(uname,sessid:string):boolean;
  begin
  userCS.Enter;
  try
    Result:=False;
    // If logged in under this session ID, return True
    if UserInfo.Child[uname]<>nil then
      if (UserInfo.Child[uname]['session']=sessid) or
         (UserInfo.Child[uname]['session2']=sessid) then
        Result:=True;
  finally
    userCS.Leave;
    end;
  end;

function TRtcMessengerUsers.isLoggedIn(uname:string):boolean;
  begin
  userCS.Enter;
  try
    Result:=UserInfo.Child[uname]<>nil;
  finally
    userCS.Leave;
    end;
  end;

procedure TRtcMessengerUsers.SetCallback(uname: string; cb: TRtcDelayedCall);
  begin
  userCS.Enter;
  try
    if UserInfo.Child[uname]<>nil then
      UserInfo.Child[uname].Obj['callback']:=cb;
  finally
    userCS.Leave;
    end;
  end;

function TRtcMessengerUsers.GetCallback(uname: string): TRtcDelayedCall;
  begin
  Result:=nil;
  userCS.Enter;
  try
    if UserInfo.Child[uname]<>nil then
      begin
      Result:=TRtcDelayedCall(UserInfo.Child[uname].Obj['callback']);
      if Assigned(Result) then
        // We can not call the calback function more than once,
        // so we will clear its assignment here.
        UserInfo.Child[uname].Obj['callback']:=nil;