msgserver.pas

Delphi MsgCommunicator 2-10 component.I ve used, really good job. can be Server-Client message appl

{******************************************************************************}
{                                                                              }
{ Server component                                                             }
{                                                                              }
{******************************************************************************}

unit MsgServer;

interface

{$I MsgVer.inc}
{$WARNINGS OFF}
{$HINTS OFF}

uses Db, SysUtils, Classes, IniFiles,

// MsgCommunicator units

{$IFDEF DEBUG_LOG}
     MsgDebug,
{$ENDIF}
{$IFNDEF D6H}
     FileCtrl,
{$ENDIF}
     MsgConnection,
     MsgExcept,
     MsgMemory,
     MsgCompression,
     MsgCrypto,
     MsgDatabase,
     MsgTypes,
     MsgComMain,
     MsgComBase,
     MsgCriticalSection,
     MsgConst;

const

  MSG_USERS_FILE = 'users.all';
  MSG_UCL_EXT = '.ucl';
  MSG_FILE_EXT = '.msg';
  MSG_USER_MESSAGES_EXT = '.ums';

  MSG_MAX_CARDINAL = 4294967295;

type

  TMsgClientInfo = packed record
   UserID:           Cardinal;
   Host:             ShortString;
   Port:             Integer;
   Application:      ShortString;
   SessionID:        TMsgSessionID;
  end; // TMsgClientInfo

  TMsgClientInfoArray = array of TMsgClientInfo;

  TMsgUserContacts = array of Cardinal;

  TMsgOnUserRegistered = procedure (const UserID: Cardinal) of object;
  TMsgOnUserInfoChanged = procedure (const UserID: Cardinal) of object;

////////////////////////////////////////////////////////////////////////////////
//
// TMsgServerNetworkSettingsEditor
//
////////////////////////////////////////////////////////////////////////////////


  TMsgServerNetworkSettingsEditor = class (TMsgNetworkSettingsEditor)
   private
    FServerReceiveTimeOut:           Integer;
    FServerReceiveSleep:             Integer;
    FMinServerSendTimeOut:           Integer;
    FServerSendTimeOut:              Integer;
    FServerWaitForSendSleep:            Integer;
    FServerResendDelay:              Integer;
    FServerRequestDelay:             Integer;
    FWaitForMessagesSend:            Integer;
    FWaitForServerSessionThreadTimeOut: Integer;
    FServerThreadsTerminateDelay:    Integer;
    FServerSessionTerminatorSleep:   Integer;
    FWaitForPingAnswer:              Integer;
    FServerPingSleep:                Integer;
    FPingClients:                       Boolean;
   public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure CopySettingsToConnectParams(var ConnectParams: TMsgConnectParams); override;
   published
    property ServerReceiveTimeOut:           Integer read FServerReceiveTimeOut write FServerReceiveTimeOut;
    property ServerReceiveSleep:             Integer read FServerReceiveSleep write FServerReceiveSleep;
    property MinServerSendTimeOut:           Integer read FMinServerSendTimeOut write FMinServerSendTimeOut;
    property ServerSendTimeOut:              Integer read FServerSendTimeOut write FServerSendTimeOut;
    property ServerWaitForSendSleep:         Integer read FServerWaitForSendSleep write FServerWaitForSendSleep;
    property ServerResendDelay:              Integer read FServerResendDelay write FServerResendDelay;
    property ServerRequestDelay:             Integer read FServerRequestDelay write FServerRequestDelay;
    property WaitForMessagesSend:            Integer read FWaitForMessagesSend write FWaitForMessagesSend;
    property WaitForServerSessionThreadTimeOut: Integer read FWaitForServerSessionThreadTimeOut write FWaitForServerSessionThreadTimeOut;
    property ServerThreadsTerminateDelay:    Integer read FServerThreadsTerminateDelay write FServerThreadsTerminateDelay;
    property ServerSessionTerminatorSleep:   Integer read FServerSessionTerminatorSleep write FServerSessionTerminatorSleep;
    property WaitForPingAnswer:              Integer read FWaitForPingAnswer write FWaitForPingAnswer;
    property ServerPingSleep:                Integer read FServerPingSleep write FServerPingSleep;
    property PingClients:                    Boolean read FPingClients write FPingClients;
  end; // TMsgServerNetworkSettingsEditor



////////////////////////////////////////////////////////////////////////////////
//
// TMsgServerConnectParamsEditor
//
////////////////////////////////////////////////////////////////////////////////

  TMsgServerConnectParamsEditor = class (TMsgConnectionParamsEditor)
   private
    FNetworkSettings:           TMsgServerNetworkSettingsEditor;
   public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function GetConnectParams: TMsgConnectParams; override;
   published
    property NetworkSettings: TMsgServerNetworkSettingsEditor read FNetworkSettings write FNetworkSettings;
  end;


  TMsgServer = class;

////////////////////////////////////////////////////////////////////////////////
//
// TMsgServerSession
//
////////////////////////////////////////////////////////////////////////////////


  TMsgServerSession = class (TMsgNetworkSession)
   private
//    FConnectParams:             TMsgClientConnectParams;
    FServer:                    TMsgServer;
   public
    FCSect:                     TRTLCriticalSection;
   protected
    procedure SetLogged(value: boolean); override;
    procedure SetConnected(value: boolean); override;
   public
    constructor Create(aServer: TComponent);
    destructor Destroy; override;
    // call OnError event handler
    procedure DoOnError(ErrorCode: Integer; NativeError: Integer = -1; ErrorMessage: String = ''); override;
    procedure DoCloseSessionOnNetworkError; override;
(*****************************************************************************)
(*  COMMANDS to execute                                                      *)
(*****************************************************************************)
   public
    // connect user to this server
    function ConnectUser: Boolean;
    // disconnect user from this server
    procedure DisconnectUser;
   protected
(*****************************************************************************)
(*  COMMANDS to send                                                         *)
(*****************************************************************************)
    function OnLineUser(UserID: Cardinal): Boolean;
    function OffLineUser(UserID: Cardinal): Boolean;
(*****************************************************************************)
    function SendCommand(
                                Command: TMsgMessageType;
                                Buffer: PChar;
                                Size: Integer
                                        ): Integer;
    procedure ExecuteReceivedCommand(var Buffer: PChar; BufferSize: Integer);
    procedure ExecuteGetUserInfo(var CommandHeader: TMsgCommandHeader; Stream: TMsgMemoryStream);
    procedure ExecuteGetUserID(var CommandHeader: TMsgCommandHeader; Stream: TMsgMemoryStream);
    procedure ExecuteGetContacts(var CommandHeader: TMsgCommandHeader; Stream: TMsgMemoryStream);
    procedure ExecuteIsUserExisting(var CommandHeader: TMsgCommandHeader; Stream: TMsgMemoryStream);
    procedure ExecuteIsUserOnline(var CommandHeader: TMsgCommandHeader; Stream: TMsgMemoryStream);
    procedure ExecuteRegisterNewUser(var CommandHeader: TMsgCommandHeader; Stream: TMsgMemoryStream);
    procedure ExecuteUpdateUserInfo(var CommandHeader: TMsgCommandHeader; Stream: TMsgMemoryStream);
    procedure ExecuteAddUserToContacts(var CommandHeader: TMsgCommandHeader; Stream: TMsgMemoryStream);
    procedure ExecuteUpdateUserInContacts(var CommandHeader: TMsgCommandHeader; Stream: TMsgMemoryStream);
    procedure ExecuteRemoveUserFromContacts(var CommandHeader: TMsgCommandHeader; Stream: TMsgMemoryStream);
    procedure ExecuteFindUsers(var CommandHeader: TMsgCommandHeader; Stream: TMsgMemoryStream);
    procedure ExecuteFindMessages(var CommandHeader: TMsgCommandHeader; Stream: TMsgMemoryStream);
    procedure ExecuteLogon(var CommandHeader: TMsgCommandHeader; Stream: TMsgMemoryStream);
    procedure ExecuteLogoff(var CommandHeader: TMsgCommandHeader; Stream: TMsgMemoryStream);
   public
    // receive data from network and move it to ReceivedCommandHeader and ReceivedCommandDataStream
    procedure ReceiveData(var Buffer: PChar; var BufferSize: Integer); override;
    // send buffer via established connection using connection manager
    procedure SendBuffer(Buffer: PChar; BufferSize: Integer; Code: Integer = MsgNewRequest); override;
    // receive custom message from client
    procedure ReceiveMessage(Buffer: PChar; BufferSize: Integer); override;
   protected
    // send custom message to client
    procedure SendMessage(Buffer: PChar; BufferSize: Integer);
    function GetClientInfo: TMsgClientInfo;
  end; // TMsgServerSession

  TMsgServerSessionsArray = array of PMsgSrvrSession;



////////////////////////////////////////////////////////////////////////////////
//
// TMsgServer
//
////////////////////////////////////////////////////////////////////////////////


  TMsgServer = class (TMsgComponent)
   private
    FDatabase:                      TMsgDatabase;
    FTempTable:                     TMsgTempTable;
    FMaxConnections:                Integer;
    FUsers:                         TThreadList;
    FGuestID:                       Cardinal;
    FMinUserID:                     Cardinal;
    FUseConfigFile:                 Boolean;
    FConnectedUsers:                TMsgThreadIntArray;
    FConnectionParams:              TMsgServerConnectParamsEditor;
    FBeforeServerStart:             TNotifyEvent;
    FAfterServerStart:              TNotifyEvent;
    FBeforeServerStop:              TNotifyEvent;
    FAfterServerStop:               TNotifyEvent;
    FAfterConnect:                  TNotifyEvent;
    FAfterDisconnect:               TNotifyEvent;
    FBeforeConnect:                 TNotifyEvent;
    FBeforeDisconnect:              TNotifyEvent;
    FCurrentVersion:                String;
    FActive:                        Boolean;
    FConfigFileName:                String;
    FDataPath:                      String;
    FConnectionManager:             TMsgServerConnectionManager;
    FServerID:                      Integer;
    FStoreMessageHistory:           Boolean;
    FOnReceiveTextMessage:          TMsgOnReceiveTextMessage;
    FOnReceiveBinaryMessage:        TMsgOnReceiveBinaryMessage;
    FOnReceiveStreamMessage:        TMsgOnReceiveStreamMessage;
    FOnReceiveCommand:              TMsgOnReceiveCommand;
    FOnUserRegistered:              TMsgOnUserRegistered;
    FOnUserInfoChanged:             TMsgOnUserInfoChanged;
    FCryptoParamsEditor:            TMsgCryptoParamsEditor;
    FCSect:                         TRTLCriticalSection;
   protected
    function GetNetworkSettings: TMsgServerNetworkSettingsEditor;
    function GetMaxConnections: Integer;
    procedure SetServerID(Value: Integer);
    function GetUserFileName(UserID: Cardinal): String;
    function GetLocalHost: String;
    function GetLocalPort: Integer;
    procedure StartServer;
    procedure StopServer;
    function FindSessionWithUser(UserID: Cardinal): TMsgServerSession;
    function FindSessionsWithUser(UserID: Cardinal): TMsgServerSessionsArray;
    function FindSessionsWithUserInContacts(UserID: Cardinal): TMsgServerSessionsArray;
   public
    procedure GetUserContacts(UserID: Cardinal; var Contacts: TMsgContactInfoArray);
    procedure AddUserToContacts(
                            const OwnerUserID:        Cardinal;
                            const ContactUserID:      Cardinal;
                            const ContactNameSource:  TMsgContactNameSource = mcnsUserName;
                            const ContactCustomName:  String = ''
                               );
    procedure UpdateUserInContacts(
                            const OwnerUserID:        Cardinal;
                            const ContactUserID:      Cardinal;
                            const ContactNameSource:  TMsgContactNameSource = mcnsUserName;
                            const ContactCustomName:  String = ''
                               );
    procedure RemoveUserFromContacts(OwnerUserID: Cardinal; ContactUserID: Cardinal);
   protected
    procedure LoadUsers;
    procedure SaveUsers;
    procedure DeleteUsers;
    function ConnectSession(Session: TMsgServerSession): Boolean;
    procedure DisconnectSession(Session: TMsgServerSession);
    procedure AddUser(UserInfo: TMsgUserInfo; Password: String = '');
    procedure RemoveUser(const UserID: Cardinal);
    procedure DeleteContacts(const UserID: Cardinal);
    procedure ChangeUserInfo(const UserInfo: TMsgUserInfo; ChangePassword: Boolean; Password: String);
    function GetPasswordHeader(const UserID: Cardinal): TMsgCryptoHeader;
    function IsPasswordValid(const UserID: Cardinal; const Password: String): Boolean;
    procedure OnLineUser(Session: TMsgServerSession);
    procedure OffLineUser(Session: TMsgServerSession);
   public
    procedure InsertUser(const UserInfo: TMsgUserInfo; Password: String = '');
    procedure DeleteUser(const UserID: Cardinal);
    procedure UpdateUser(const UserInfo: TMsgUserInfo; ChangePassword: Boolean; Password: String = '');
    procedure DisconnectUser(const UserID: Cardinal);
    function IsUserExisting(const UserID: Cardinal): Boolean;
    function IsClientConnected(const Client: TMsgClientInfo): Boolean;
    function IsUserConnected(const UserID: Cardinal): Boolean;
    function IsUserLogged(const UserID: Cardinal): Boolean;
    function GetUserInfo(const UserID: Cardinal): TMsgUserInfo;
    function GetNewUserID: Cardinal;
    procedure LoadDefaultSettings;
    procedure LoadSettingsFromConfigFile;
    procedure SaveSettingsToConfigFile;
    procedure DoOnConnectionError(
                       const ErrorCode:    Integer;
                       const NativeError:  Integer;