preximtrans.pas

一个很好的学习例子,有需要的请下载研究,

{
********************************************************************************
*                                                                              * 
*             (c) China Systems 1999 - 2003                                    *   
*                                                                              * 
*               Prexim Imaging development team.                               * 
*                                                                              * 
********************************************************************************
*
* Unit Name: PrEximTrans.pas
* Author:    Licwing
* Purpose:   Provides two components to support transfer data use TCP/IP mode
********************************************************************************
}
unit PrEximTrans;
//==============================================================================
{* |<PRE>
 Unit name: PrEximTrans.pas
 Author:    Licwing
 Purpose: 
 Develop Platform: Win2K pro & sp3 + delphi6 & patch2 + Indy 9.0.14
 Test Platform: 
 History:
   08-19-2003  V1.0  by Licwing
     -> first version
   08-26-2003  V1.1  by Licwing
     -> Transfer error messag from server to client 
|</PRE>}         
//==============================================================================

interface

uses
  SysUtils, Classes,
  idBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdTCPServer,
  CryptImpt, PrEximFileUtils;

type
//------------------------------------------------------------------------------
// User rights type defines
//------------------------------------------------------------------------------
  TUserRightKind = (
  {* User rights defines}
                urScan,     // Scanner operator, scans paper and send it to server
                urRelease,  // Releaser, audits transactions whether is correct or not
                urManager); // Manager,

  TUserRight = set of TUserRightKind;


//------------------------------------------------------------------------------
// Transferring Protocol defines
//------------------------------------------------------------------------------
const
  MAX_USERNAME = 16;
  MAX_PWDCRYPT = 64;
type
  TUsername = string[MAX_USERNAME];
  TPwdCrypt = string[MAX_PWDCRYPT];

  TOperate = (opOperateNone, opLogin, opLogout, opGetUserProfile, opSend, opRetrieve,
              opControl, opGetLastError);


  TLoginData = record
  {* client log information structure}
    Username: TUsername;                // username
    PwdCrypt: TPwdCrypt;                // password，encrypted
  end;

  TLoginResponse = record
  {* Server response structure for logging}
    EncryptType: TEncryptType;          // encryt type for this session
    EncryptKey: TPrivateKey;            // Session private's key
  end;

  TRequestHead = record
  {* Client request head}
    Operate: TOperate;                  // Operate type
    Length:  Int64;                     // return data size。-1 means no data
  end;

  TResponseHead = record
  {* Server response head}
    VResult:    integer;                // Operate result
    Length:     Int64;                  // return data size。-1 means no data
  end;
  
//------------------------------------------------------------------------------
// Event defines
//------------------------------------------------------------------------------
  TImageServerThread = class;

  TOnLoginEvent = procedure (const Username, Password: string;
    var Logged: boolean; var UserRight: TUserRight; var ErrorMsg: string) of object;
  TOnLogoutEvent = procedure (const Username: string) of object;
  TOnNoParamEvent = procedure(Thread: TImageServerThread) of object;
  TOnDataEvent = procedure (Stream: TStream; var Flag: boolean; var
                 ErrorMsg: string) of object;
  TOnDataExEvent = procedure (Stream: TStream; const User: string;
                 var Flag: boolean; var ErrorMsg: string) of object;

  TOnGetUserProfileEvent = procedure (const Username: string;
    UserProfile: TStream; var ErrorMsg: string) of object;
//------------------------------------------------------------------------------
// TImageServerThread defines
//------------------------------------------------------------------------------
  // Image client connection's state
  TClientState = (csAuth,         // only connected, wait to be authorized
                  csTrans);       // authorized by server

  TImageServerThread = class(TIdPeerThread)
  {* Client thread in Server}
  private
    fUsername : string;         // login username
    fLastError : string;         // Last error message
    fEncryptType: TEncryptType; // encrypted type
    fState :    TClientState;   // current connected state
    fCryptKey:  TPrivateKey;    // public encrypted key for session
    fUserRight: TUserRight;     // user's rights
  protected
    procedure BeforeRun; override;
  public
    property Username : string read fUsername write fUsername;
    property LastErrorMsg : string read fLastError write fLastError;
    property EncryptType: TEncryptType read fEncryptType write fEncryptType;
    property State    : TClientState read fState write fState;
    property CryptKey: TPrivateKey read fCryptKey write fCryptKey;
    property UserRight: TUserRight read fUserRight write fUserRight;
  end;

  TImageTransServer = class (TidTCPServer)
  private
    FErrorMsg: string;
    FOnLogin: TOnLoginEvent;
    FOnLogout: TOnLogoutEvent;
    FOnGetUserProfile: TOnGetUserProfileEvent;

    FOnOperate: TOnDataExEvent;
    FOnReceived: TOnDataExEvent;
    FOnRetrieve: TOnDataExEvent;
    FOnUnknown: TOnNoParamEvent;
    function GetCryptKey(hSeed: integer): TPrivateKey;
    function GetEncryptType(hSeed: integer): TEncryptType;
    function CheckStateIsAuth(AThread: TImageServerThread): boolean;
  protected
    procedure DoConnect(AThread: TIdPeerThread); override;
    procedure DoDisconnect(AThread: TIdPeerThread); override;
    function DoExecute(AThread: TIdPeerThread): boolean; override;

    procedure DoLogin(AThread: TImageServerThread);
    procedure DoLogout(AThread: TImageServerThread);
    procedure DoReceived(AThread: TImageServerThread; DataSize: integer);
    procedure DoRetrieve(AThread: TImageServerThread; DataSize: integer);
    procedure DoGetUserProfile(AThread: TImageServerThread);
    procedure DoOperate(AThread: TImageServerThread; DataSize: integer);
    procedure DoUnknown(AThread: TImageServerThread);
  public
    constructor Create(AOwner: TComponent); override;
//    destructor Destroy; override;
    function GetLastError: string;
  published
    property OnLogin: TOnLoginEvent read FOnLogin write FOnLogin;
    property OnLogout: TOnLogoutEvent read FOnLogout write FOnLogout;
    property OnGetUserProfile: TOnGetUserProfileEvent read FOnGetUserProfile write FOnGetUserProfile;

    property OnOperate: TOnDataExEvent read FOnOperate write FOnOperate;
    property OnReceived: TOnDataExEvent read FOnReceived write FOnReceived;
    property OnRetrieve: TOnDataExEvent read FOnRetrieve write FOnRetrieve;
    property OnUnknownEvent: TOnNoParamEvent read FOnUnknown write FOnUnknown;
  end;

  TImageTransClient = class (TidTCPClient)
  private
    FErrorCode: integer;
    FErrorMsg: string;
    fRequest : TRequestHead;
    fConnRep: TLoginResponse;
    fResponse: TResponseHead;
    procedure GetErrorMsg;
  protected
    procedure DoOnConnected; override;
  public
    constructor Create(AOwner: TComponent); override;
//    destructor Destroy; override;
    function GetLastError(var ErrorCode: integer): string;
    function Login(const Username, Password: string; var UserRight: TUserRight): Boolean;
    function GetUserProfile(Stream: TStream): boolean;
    procedure Logout;
    function Send(Stream: TStream): boolean;
    function Retrieve(Stream: TStream): boolean;
    function Operate(Stream: TStream): Boolean;
  end;
  

implementation

const
  BaseKey: TPrivateKey=($11, $FB, $ED, $2B, $01, $98, $6D, $E5,
                        $00, $05, $00, $06, $00, $07, $00, $08);
  Zero_Length  = 0;

  Default_Port = 5100;  // ImageTransServer default port is 5100

//------------------------------------------------------------------------------
// Transferring portocol code
//------------------------------------------------------------------------------
  VR_SUCCESS            = 0;            // process successful
  VR_FAILURE            = -1;           // process failure
  VR_STATEERROR         = -2;           // current state error
  VR_UNKNOWN            = -3;           // unknown command
  VR_UNIMPLEMENTATION   = -4;           // Evevnt unimplemented

procedure ReadUserRightFromStream(Stream: TStream; var UserRight: TUserRight);
var
  Count: integer;
  AUserRightKind: TUserRightKind;
begin
  Count := 0;
  Stream.Read(Count, Sizeof(integer));

  while Count>0 do
  begin
    Stream.Read(AUserRightKind, Sizeof(TUserRightKind));
    UserRight := UserRight + [AUserRightKind];
    Dec(Count);
  end;
end;

procedure WriteUserRightToStream(Stream: TStream; UserRight: TUserRight);
var
  Count: integer;
  AUserRightKind: TUserRightKind;
begin
  Count := 0;
  for AUserRightKind:=Low(TUserRightKind) to High(TUserRightKind) do
    if AUserRightKind in UserRight then Inc(Count);

  Stream.Write(Count, Sizeof(integer));

  if Count<1 then exit;
  
  for AUserRightKind:=Low(TUserRightKind) to High(TUserRightKind) do
    if AUserRightKind in UserRight then
      Stream.Write(AUserRightKind, Sizeof(TUserRightKind));
end;

{ TImageServerThread }

procedure TImageServerThread.BeforeRun;
begin
  fUsername := '';
  fLastError := '';
  fState := csAuth;
  fEncryptType := etECB;
  fUserRight := [];
  FillChar(fCryptKey, 16, 0);
  inherited BeforeRun;
end;

{ TImageTransServer }

function TImageTransServer.CheckStateIsAuth(
  AThread: TImageServerThread): boolean;
begin
  Result := AThread.State = csAuth;
end;

constructor TImageTransServer.Create(AOwner: TComponent);
begin
  inherited;
  DefaultPort := Default_Port;
  ThreadClass := TImageServerThread;

  CommandHandlersEnabled := false;
end;

procedure TImageTransServer.DoConnect(AThread: TIdPeerThread);
var
  ALgnResponse: TLoginResponse;
begin
  FillChar(ALgnResponse, Sizeof(ALgnResponse), 0);

  ALgnResponse.EncryptType := GetEncryptType(AThread.ThreadID); //etECB;
  ALgnResponse.EncryptKey := GetCryptKey(AThread.ThreadID);

  TImageServerThread(AThread).CryptKey := ALgnResponse.EncryptKey;
  TImageServerThread(AThread).EncryptType := ALgnResponse.EncryptType;

  AThread.Connection.WriteBuffer(ALgnResponse, Sizeof(ALgnResponse));

  if Assigned(OnConnect) then
  begin
    OnConnect(AThread);
  end;
end;

procedure TImageTransServer.DoDisconnect(AThread: TIdPeerThread);
begin
  if assigned(FOnLogout) then FOnLogout(TImageServerThread(AThread).Username);
  inherited;
end;

function TImageTransServer.DoExecute(AThread: TIdPeerThread): boolean;
var
  AImgThread: TImageServerThread;
  ARequest: TRequestHead;
begin
  result := true;
  AImgThread := TImageServerThread(AThread);
  while AImgThread.Connection.Connected do
  begin
    FillChar(ARequest, Sizeof(ARequest), 0);

    AImgThread.Connection.ReadBuffer(ARequest, Sizeof(ARequest));
    case ARequest.Operate of
      opLogout: DoLogout(AImgThread);
      opLogin:  DoLogin(AImgThread);
      opSend:   DoReceived(AImgThread, ARequest.Length);
      opGetUserProfile: DoGetUserProfile(AImgThread);
      opControl: DoOperate(AImgThread, ARequest.Length);
      opRetrieve: DoRetrieve(AImgThread, ARequest.Length);
      opGetLastError: AImgThread.Connection.Writeln(AImgThread.LastErrorMsg);
    else DoUnknown(AImgThread)
    end;
  end;
end;

{-------------------------------------------------------------------------------
  ProceName:  TImageTransServer.DoGetUserProfile
  Purpose:    Get a special user's profile, the OnGetUserProfile is only available
              while it has a implementation
  Author:     Licwing
  Date:       08-19-2003
-------------------------------------------------------------------------------}
procedure TImageTransServer.DoGetUserProfile(AThread: TImageServerThread);
var
  AUserProfile: TTempFileStream;
  AResponse: TResponseHead;
  AErrMsg: string;
begin
  // check current state
  if CheckStateIsAuth(AThread) then
  begin
    AResponse.VResult := VR_STATEERROR;
    AResponse.Length := Zero_Length;
    AThread.Connection.WriteBuffer(AResponse, Sizeof(AResponse));
    exit;
  end;

  // process request
  if assigned(OnGetUserProfile) then
  begin
    AUserProfile := TTempFileStream.Create(Temp_Prefix);
    try
      FOnGetUserProfile(AThread.Username, AUserProfile,AErrMsg);
      AThread.LastErrorMsg := AErrMsg;
      AUserProfile.Position := 0;

      AResponse.VResult := VR_SUCCESS;
      AResponse.Length := AUserProfile.Size;

      with AThread.Connection do
      begin
        WriteBuffer(AResponse, Sizeof(AResponse));
        WriteStream(AUserProfile);
      end;
    finally
      AUserProfile.Free;
    end;
  end
  else begin
    AResponse.VResult := VR_UNIMPLEMENTATION;
    AResponse.Length := Zero_Length;
    AThread.Connection.WriteBuffer(AResponse, Sizeof(AResponse));
  end;
end;

{-------------------------------------------------------------------------------
  ProceName:  TImageTransServer.DoLogin
  Author:     Licwing
  Date:       08-25-2003
-------------------------------------------------------------------------------}
procedure TImageTransServer.DoLogin(AThread: TImageServerThread);
var
  ALgnData: TLoginData;
  AResponse: TResponseHead;
  ALogged: boolean;
  APwd: string;
  AErrMsg: string;
  AStream: TMemoryStream;
begin
  FillChar(aLgnData, Sizeof(TLoginData), 0);
  AThread.Connection.ReadBuffer(ALgnData, Sizeof(ALgnData));

  // check current state
  if not CheckStateIsAuth(AThread) then
  begin
    AResponse.VResult := VR_STATEERROR;
    AResponse.Length := Zero_Length;
    AThread.Connection.WriteBuffer(AResponse, Sizeof(AResponse));
    exit;
  end;

  ALogged := false;
  // decrypt password
  Decrypt(@AThread.CryptKey, Sizeof(AThread.CryptKey),
           ALgnData.PwdCrypt, Length(ALgnData.PwdCrypt),
           AThread.EncryptType, APwd);
  // notify a LoginEvent
  if Assigned(FOnLogin) then
    FOnLogin(ALgnData.Username, APwd, ALogged, AThread.FUserRight,
             AErrMsg);
  AThread.LastErrorMsg := AErrMsg;

  if ALogged then
  begin
    // keeps client information if client logged
    AThread.State := csTrans;
    AThread.Username := ALgnData.Username;

    AStream := TMemoryStream.Create;
    try
      WriteUserRightToStream(AStream, AThread.UserRight);

      AResponse.VResult := VR_Success;
      AResponse.Length := AStream.Size;

      // return
      with AThread.Connection do
      begin
        WriteBuffer(AResponse, Sizeof(AResponse));
        if AResponse.Length > Zero_Length
          then WriteStream(AStream);
      end;
    finally
      AStream.Free;
    end;
  end
  else begin
    AResponse.VResult := VR_FAILURE;
    AResponse.Length := Zero_Length;
    
    // return
    AThread.Connection.WriteBuffer(AResponse, Sizeof(AResponse));
  end;
end;

procedure TImageTransServer.DoLogout(AThread: TImageServerThread);
begin
//  if assigned(FOnLogout) then FOnLogout(AThread.Username);
  
  AThread.Connection.Disconnect;
end;

procedure TImageTransServer.DoOperate(AThread: TImageServerThread;