rtcmessenger.pas

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

      end;
  finally
    userCS.Leave;
    end;
  end;

procedure TRtcMessengerUsers.TriggerCallback(uname: string);
  var
    cb:TRtcDelayedCall;
  begin
  cb:=GetCallback(uname);
  if assigned(cb) then
    cb.WakeUp;
  end;

procedure TRtcMessengerUsers.Login(uname,upass,sessid:string);
  begin
  userCS.Enter;
  try
    if uname='' then
      raise Exception.Create('Username required for Login.')
    else if upass='' then
      raise Exception.Create('Password required for Login.')
    else
      begin
      if UserList.isType[uname]<>rtc_Record then // user doesn't exist
        raise Exception.Create('User "'+uname+'" not registered.')
      else
        begin
        with UserList.asRecord[uname] do
          if asString['pass']<>upass then
            raise Exception.Create('Wrong password for user "'+uname+'".')
          else
            doLogIn(uname,sessid);
        end;
      end;
  finally
    userCS.Leave;
    end;
  end;

procedure TRtcMessengerUsers.Login2(uname,upass,sessid:string);
  begin
  userCS.Enter;
  try
    if uname='' then
      raise Exception.Create('Username required for Login.')
    else if upass='' then
      raise Exception.Create('Password required for Login.')
    else
      begin
      if UserList.isType[uname]<>rtc_Record then // user doesn't exist
        raise Exception.Create('User "'+uname+'" not registered.')
      else
        begin
        with UserList.asRecord[uname] do
          if asString['pass']<>upass then
            raise Exception.Create('Wrong password for user "'+uname+'".')
          else
            doLogIn2(uname,sessid);
        end;
      end;
  finally
    userCS.Leave;
    end;
  end;

function TRtcMessengerUsers.Exists(uname:string):boolean;
  begin
  userCS.Enter;
  try
    Result:=False;
    if uname<>'' then
      if UserList.isType[uname]=rtc_Record then // user exists
        Result:=True;
  finally
    userCS.Leave;
    end;
  end;

procedure TRtcMessengerUsers.RegUser(uname,upass,sessid:string);
  begin
  userCS.Enter;
  try
    if uname='' then
      raise Exception.Create('Username required to Register.')
    else if upass='' then
      raise Exception.Create('Password required to Register.')
    else if not isValidUserName(uname) then
      raise Exception.Create('"'+uname+'" is not a valid username.')
    else
      begin
      if UserList.isType[uname]<>rtc_Null then
        raise Exception.Create('Username "'+uname+'" already taken.'#13#10+
                               'Can not register a new user with the same name.')
      else // user doesn't exists
        begin
        with UserList.NewRecord(uname) do
          begin
          asString['pass']:=upass;
          SaveUserList;
          doLogIn(uname,sessid);
          end;
        end;
      end;
  finally
    userCS.Leave;
    end;
  end;

procedure TRtcMessengerUsers.DelUser(uname:string);
  begin
  userCS.Enter;
  try
    UserList.isNull[uname]:=True; // das entfernt den Record aus UserList
    SaveUserList; // Das speichert die neue UserList
  finally
    userCS.Leave;
    end;
  end;

procedure TRtcMessengerUsers.ChangePass(uname,oldpass,newpass:string);
  begin
  userCS.Enter;
  try
    if uname='' then
      raise Exception.Create('Username required to change Password.')
    else if oldpass='' then
      raise Exception.Create('Old Password required to change Password.')
    else if newpass='' then
      raise Exception.Create('New Password required to change Password.')
    else
      begin
      if UserList.isType[uname]<>rtc_Record then
        raise Exception.Create('User "'+uname+'" not registered.')
      else // user exists
        begin
        with UserList.NewRecord(uname) do
          if asString['pass']<>oldpass then
            raise Exception.Create('Wrong password for user "'+uname+'".')
          else
            begin
            asString['pass']:=newpass;
            SaveUserList;
            end;
        end;
      end;
  finally
    userCS.Leave;
    end;
  end;

procedure TRtcMessengerUsers.Logout(uname, sessid: string);
  begin
  doLogOut(uname, sessid);
  end;

procedure TRtcMessengerUsers.SendData(const to_name:string; data:TRtcValueObject);
  var
    mydata:TRtcValue;
    s,fname:string;
  begin
  s:=data.toCode;
  Crypt(s, MSG_DATA_CRYPT_KEY);

  mydata:=TRtcValue.Create;
  try
    mydata.asString:=s;
    s:=mydata.toCode;
  finally
    mydata.Free;
    end;
  fname:=UserDataFileName+'User.'+to_name+'.msg.data';

  msgCS.Enter;
  try
    Write_File(fname,s,File_Size(fname));
  finally
    msgCS.Leave;
    end;

  TriggerCallback(to_name);
  end;

function TRtcMessengerUsers.GetData(const uname:string; lastcheck:TDateTime; var thischeck:TDateTime): TRtcArray;
  var
    fname,
    s,code:string;
    old:boolean;
    at,i:integer;
    rec:TRtcValue;
  begin
  thischeck:=0;
  Result:=nil;

  old:=True;

  { On first call, before we start reading newly received data, we will rename the
    original ".data" file to ".old", so that we can read the file without having to
    worry about concurrent file access, in case someone sends us a new message while
    we're getting the "old" data. This function will return he content of the old file
    together with the "old" file age, so we can delete the old file on next call,
    only if file time is less or equal to "lastcheck" time. If last send operation failed,
    we will be able to resend the "old" file, without loosing anything. }

  // Delete Old file if file is older or equal to "lastcheck" time
  fname:=UserDataFileName+'User.'+uname+'.msg.old';
  if not File_Exists(fname) then
    begin
    fname:=UserDataFileName+'User.'+uname+'.msg.data';
    old:=False;
    end
  else if File_Age(fname)<=lastcheck then
    begin
    Delete_File(fname);
    fname:=UserDataFileName+'User.'+uname+'.msg.data';
    old:=False;
    end;

  msgCS.Enter;
  try
    if not File_Exists(fname) then // nothing to get
      Exit
    else
      begin
      if old then
        // resending old file, update time
        thischeck:=File_Age(fname)
      else
        begin
        // sending new file, rename file to ".old" and update time
        Rename_File(fname, UserDataFileName+'User.'+uname+'.msg.old');
        fname:=UserDataFileName+'User.'+uname+'.msg.old';
        thischeck:=File_Age(fname);
        end;
      end;
  finally
    msgCS.Leave;
    end;

  // Read file content and create an array of mesages
  s:=Read_File(fname);
  at:=0; i:=0;

  Result:=TRtcArray.Create;
  while at<length(s) do
    begin
    rec:=TRtcValue.FromCode(s,at);
    try
      code:=rec.asString;
    finally
      rec.Free;
      end;
    DeCrypt(code, MSG_DATA_CRYPT_KEY);
    Result.asCode[i]:=code;
    Inc(i);
    end;
  end;

procedure TRtcMessengerUsers.AddFriend(uname, friend_name: string);
  var
    info,rec:TRtcRecord;
  begin
  if not Exists(friend_name) then
    raise Exception.Create('User "'+friend_name+'" not registered.');

  info:=LoadInfo(uname);
  try
    info.asRecord['friends'].asBoolean[friend_name]:=True;
    SaveInfo(uname,info);
  finally
    info.Free;
    end;

  info:=LoadInfo(friend_name);
  try
    if info.isType['friends']=rtc_Record then
      begin
      if info.asRecord['friends'].asBoolean[uname] then
        begin
        rec:=TRtcRecord.Create;
        try
          // Send me info about friend's status.
          if isLoggedIn(friend_name) then
            rec.asString['login']:=friend_name
          else
            rec.asString['logout']:=friend_name;
          SendData(uname, rec);
          // Send friend info about my status.
          rec.asString['login']:=uname;
          SendData(friend_name,rec);
        finally
          rec.Free;
          end;
        end;
      end;
  finally
    info.Free;
    end;

  rec:=TRtcRecord.Create;
  try
    rec.asString['addfriend']:=uname;
    SendData(friend_name, rec);
  finally
    rec.Free;
    end;
  end;

procedure TRtcMessengerUsers.AddIgnore(uname, ignore_name: string);
  var
    info,rec:TRtcRecord;
  begin
  if not Exists(ignore_name) then
    raise Exception.Create('User "'+ignore_name+'" not registered.');

  info:=LoadInfo(uname);
  try
    info.asRecord['ignore'].asBoolean[ignore_name]:=True;
    SaveInfo(uname,info);
  finally
    info.Free;
    end;

  rec:=TRtcRecord.Create;
  try
    rec.asString['addignore']:=uname;
    SendData(ignore_name, rec);
  finally
    rec.Free;
    end;
  end;

procedure TRtcMessengerUsers.DelFriend(uname, friend_name: string);
  var
    info,rec:TRtcRecord;
  begin
  if not Exists(friend_name) then
    raise Exception.Create('User "'+friend_name+'" not registered.');

  info:=LoadInfo(uname);
  try
    info.asRecord['friends'].isNull[friend_name]:=True;
    SaveInfo(uname,info);
  finally
    info.Free;
    end;

  rec:=TRtcRecord.Create;
  try
    rec.asString['delfriend']:=uname;
    SendData(friend_name, rec);
  finally
    rec.Free;
    end;
  end;

procedure TRtcMessengerUsers.DelIgnore(uname, ignore_name: string);
  var
    info,rec:TRtcRecord;
  begin
  if not Exists(ignore_name) then
    raise Exception.Create('User "'+ignore_name+'" not registered.');

  info:=LoadInfo(uname);
  try
    info.asRecord['ignore'].isNull[ignore_name]:=True;
    SaveInfo(uname,info);
  finally
    info.Free;
    end;

  rec:=TRtcRecord.Create;
  try
    rec.asString['delignore']:=uname;
    SendData(ignore_name, rec);
  finally
    rec.Free;
    end;
  end;

procedure TRtcMessengerUsers.SendText(const from_name, to_name, text:string);
  var
    rec:TRtcRecord;
  begin
  rec:=TRtcRecord.Create;
  try
    rec.asString['from']:=from_name;
    rec.asString['text']:=text;
    SendData(to_name,rec);
  finally
    rec.Free;
    end;
  end;

function TRtcMessengerUsers.isValidUserName(const uname: string): boolean;
  var
    a:integer;
  begin
  Result:=True;
  for a:=1 to length(uname) do
    if not (uname[a] in ['a'..'z','A'..'Z','0'..'9','_',' ','.']) then
      begin
      Result:=False;
      Break;
      end;
  end;

end.