idsslopenssl.pas

indy的原文件哈!大家可以下来参考和学习之用.也可以用以作组件.开发其他的应用程序.

{ $HDR$}
{**********************************************************************}
{ Unit archived using Team Coherence                                   }
{ Team Coherence is Copyright 2002 by Quality Software Components      }
{                                                                      }
{ For further information / comments, visit our WEB site at            }
{ http://www.TeamCoherence.com                                         }
{**********************************************************************}
{}
{ $Log:  10337: IdSSLOpenSSL.pas 
{
{   Rev 1.3    2004-05-18 21:33:10  Mattias
{ Fixed unload bug
}
{
{   Rev 1.2    2004-05-07 16:33:46  Mattias
{ Minor fix properly releasing locking structure
}
{
{   Rev 1.1    2004-05-07 10:10:44  Mattias
{ Implemented OpenSSL locking callbacks for thread safity
}
{
{   Rev 1.0    2002.11.12 10:52:32 PM  czhower
}
unit IdSSLOpenSSL;
{
  Author: Gregor Ibic ([e-mail])
  Copyright: (c) Gregor Ibic, Intelicom d.o.o and Indy Working Group.
}
interface

uses
  Classes,
  IdException,
  IdStackConsts,
  IdSocketHandle,
  IdSSLOpenSSLHeaders,
  IdComponent,
  IdIOHandler,
  IdGlobal,
  IdTCPServer,
  IdThread,
  IdTCPConnection,
  IdIntercept, SysUtils,
  IdIOHandlerSocket,
  IdServerIOHandler,
  IdSocks;

type
  TIdX509 = class;

  TIdSSLVersion = (sslvSSLv2, sslvSSLv23, sslvSSLv3, sslvTLSv1);
  TIdSSLMode = (sslmUnassigned, sslmClient, sslmServer, sslmBoth);
  TIdSSLVerifyMode = (sslvrfPeer, sslvrfFailIfNoPeerCert, sslvrfClientOnce);
  TIdSSLVerifyModeSet = set of TIdSSLVerifyMode;
  TIdSSLCtxMode = (sslCtxClient, sslCtxServer);
  TIdSSLAction = (sslRead, sslWrite);

  TULong = packed record
    case Byte of
      0: (B1,B2,B3,B4: Byte);
      1: (W1,W2: Word);
      2: (L1: Longint);
      3: (C1: Cardinal);
  end;

  TEVP_MD = record
    Length: Integer;
    MD: Array[0..OPENSSL_EVP_MAX_MD_SIZE-1] of Char;
  end;

  TByteArray = record
    Length: Integer;
    Data: PChar;
  End;

  TIdSSLIOHandlerSocket = class;
  TIdSSLCipher = class;

  TCallbackEvent  = procedure(Msg: String) of object;
  TPasswordEvent  = procedure(var Password: String) of object;
  TVerifyPeerEvent  = function(Certificate: TIdX509): Boolean of object;
  TIOHandlerNotify = procedure(ASender: TIdSSLIOHandlerSocket) of object;

  TIdSSLOptions = class(TPersistent)
  protected
    fsRootCertFile, fsCertFile, fsKeyFile: TFileName;
    fMethod: TIdSSLVersion;
    fMode: TIdSSLMode;

    fVerifyDepth: Integer;
    fVerifyMode: TIdSSLVerifyModeSet;
    //fVerifyFile,
    fVerifyDirs, fCipherList: String;
    procedure AssignTo(ASource: TPersistent); override;
  published
    property RootCertFile: TFileName read fsRootCertFile write fsRootCertFile;
    property CertFile: TFileName read fsCertFile write fsCertFile;
    property KeyFile: TFileName read fsKeyFile write fsKeyFile;
    property Method: TIdSSLVersion read fMethod write fMethod;
    property Mode: TIdSSLMode read fMode write fMode;
    property VerifyMode: TIdSSLVerifyModeSet read fVerifyMode write fVerifyMode;
    property VerifyDepth: Integer read fVerifyDepth write fVerifyDepth;
//    property VerifyFile: String read fVerifyFile write fVerifyFile;
    property VerifyDirs: String read fVerifyDirs write fVerifyDirs;
    property CipherList: String read fCipherList write fCipherList;
  public
    // procedure Assign(ASource: TPersistent); override;
  end;

  TIdSSLContext = class(TObject)
  protected
    fMethod: TIdSSLVersion;
    fMode: TIdSSLMode;
    fsRootCertFile, fsCertFile, fsKeyFile: String;
    fVerifyDepth: Integer;
    fVerifyMode: TIdSSLVerifyModeSet;
//    fVerifyFile: String;
    fVerifyDirs: String;
    fCipherList: String;
    fContext: PSSL_CTX;
    fStatusInfoOn: Boolean;
//    fPasswordRoutineOn: Boolean;
    fVerifyOn: Boolean;
    fSessionId: Integer;
    fCtxMode: TIdSSLCtxMode;
    procedure DestroyContext;
    function SetSSLMethod: PSSL_METHOD;
    procedure SetVerifyMode(Mode: TIdSSLVerifyModeSet; CheckRoutine: Boolean);
    function GetVerifyMode: TIdSSLVerifyModeSet;
    procedure InitContext(CtxMode: TIdSSLCtxMode);
  public
    Parent: TObject;
    constructor Create;
    destructor Destroy; override;
    function LoadRootCert: Boolean;
    function LoadCert: Boolean;
    function LoadKey: Boolean;
    property StatusInfoOn: Boolean read fStatusInfoOn write fStatusInfoOn;
//    property PasswordRoutineOn: Boolean read fPasswordRoutineOn write fPasswordRoutineOn;
    property VerifyOn: Boolean read fVerifyOn write fVerifyOn;
  published
    property Method: TIdSSLVersion read fMethod write fMethod;
    property Mode: TIdSSLMode read fMode write fMode;
    property RootCertFile: String read fsRootCertFile write fsRootCertFile;
    property CertFile: String read fsCertFile write fsCertFile;
    property KeyFile: String read fsKeyFile write fsKeyFile;
//    property VerifyMode: TIdSSLVerifyModeSet read GetVerifyMode write SetVerifyMode;
    property VerifyMode: TIdSSLVerifyModeSet read fVerifyMode write fVerifyMode;
    property VerifyDepth: Integer read fVerifyDepth write fVerifyDepth;
  end;

  TIdSSLSocket = class(TObject)
  private
    fPeerCert: TIdX509;
    //fCipherList: String;
    fSSLCipher: TIdSSLCipher;
    fParent: TObject;
    fSSLContext: TIdSSLContext;
    function GetPeerCert: TIdX509;
    function GetSSLError(retCode: Integer): Integer;
    function GetSSLCipher: TIdSSLCipher;
  public
    fSSL: PSSL;
    //
    constructor Create(Parent: TObject);
    procedure Accept(const pHandle: TIdStackSocketHandle; fSSLContext: TIdSSLContext);
    procedure Connect(const pHandle: TIdStackSocketHandle; fSSLContext: TIdSSLContext);
    function Send(var ABuf; ALen: integer): integer;
    function Recv(var ABuf; ALen: integer): integer;
    destructor Destroy; override;
    function GetSessionID: TByteArray;
    function GetSessionIDAsString:String;
    procedure SetCipherList(CipherList: String);
    //
    property PeerCert: TIdX509 read GetPeerCert;
    property Cipher: TIdSSLCipher read GetSSLCipher;
  end;

  TIdSSLIOHandlerSocket = class(TIdIOHandlerSocket)
  private
    fSSLContext: TIdSSLContext;
    fxSSLOptions: TIdSSLOptions;
    fSSLSocket: TIdSSLSocket;
    fIsPeer: Boolean;
    //fPeerCert: TIdX509;
    fOnStatusInfo: TCallbackEvent;
    fOnGetPassword: TPasswordEvent;
    fOnVerifyPeer: TVerifyPeerEvent;
    fSSLLayerClosed: Boolean;
    fOnBeforeConnect: TIOHandlerNotify;
    // function GetPeerCert: TIdX509;
    //procedure CreateSSLContext(axMode: TIdSSLMode);
    fPassThrough: Boolean;
    //
    procedure SetPassThrough(const Value: Boolean);
    procedure Init;
  protected
    procedure DoBeforeConnect(ASender: TIdSSLIOHandlerSocket); virtual;
    procedure DoStatusInfo(Msg: String); virtual;
    procedure DoGetPassword(var Password: String); virtual;
    function DoVerifyPeer(Certificate: TIdX509): Boolean; virtual;
    function RecvEnc(var ABuf; ALen: integer): integer; virtual;
    function SendEnc(var ABuf; ALen: integer): integer; virtual;
    procedure OpenEncodedConnection; virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure AfterAccept; override;
    procedure ConnectClient(const AHost: string; const APort: Integer; const ABoundIP: string;
     const ABoundPort: Integer; const ABoundPortMin: Integer; const ABoundPortMax: Integer;
     const ATimeout: Integer = IdTimeoutDefault); override;
    procedure Close; override;
    procedure Open; override;

    function Recv(var ABuf; ALen: integer): integer; override;
    function Send(var ABuf; ALen: integer): integer; override;

    property SSLSocket: TIdSSLSocket read fSSLSocket write fSSLSocket;
    property PassThrough: Boolean read fPassThrough write SetPassThrough;

    property OnBeforeConnect: TIOHandlerNotify read fOnBeforeConnect write fOnBeforeConnect;
  published
    property SSLOptions: TIdSSLOptions read fxSSLOptions write fxSSLOptions;
    property OnStatusInfo: TCallbackEvent read fOnStatusInfo write fOnStatusInfo;
    property OnGetPassword: TPasswordEvent read fOnGetPassword write fOnGetPassword;
    property OnVerifyPeer: TVerifyPeerEvent read fOnVerifyPeer write fOnVerifyPeer;
  end;

  TIdServerIOHandlerSSL = class(TIdServerIOHandler)
  private
    fSSLContext: TIdSSLContext;
    fxSSLOptions: TIdSSLOptions;
//    fPeerCert: TIdX509;
//    function GetPeerCert: TIdX509;
    fIsInitialized: Boolean;
    fOnStatusInfo: TCallbackEvent;
    fOnGetPassword: TPasswordEvent;
    fOnVerifyPeer: TVerifyPeerEvent;
    //procedure CreateSSLContext(axMode: TIdSSLMode);
    //procedure CreateSSLContext;
  protected
    procedure DoStatusInfo(Msg: String); virtual;
    procedure DoGetPassword(var Password: String); virtual;
    function DoVerifyPeer(Certificate: TIdX509): Boolean; virtual;
  public
    procedure Init; override;
    function Accept(ASocket: TIdStackSocketHandle; AThread: TIdThread = nil): TIdIOHandler; override;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property SSLOptions: TIdSSLOptions read fxSSLOptions write fxSSLOptions;
    property OnStatusInfo: TCallbackEvent read fOnStatusInfo write fOnStatusInfo;
    property OnGetPassword: TPasswordEvent read fOnGetPassword write fOnGetPassword;
    property OnVerifyPeer: TVerifyPeerEvent read fOnVerifyPeer write fOnVerifyPeer;
  end;

  TIdX509Name = class(TObject)
  private
    fX509Name: PX509_NAME;
    function CertInOneLine: String;
    function GetHash: TULong;
    function GetHashAsString: String;
  public
    constructor Create(aX509Name: PX509_NAME);
    //
    property Hash: TULong read GetHash;
    property HashAsString: string read GetHashAsString;
    property OneLine: string read CertInOneLine;
  end;

  TIdX509 = class(TObject)
  protected
    FX509    : PX509;
    FSubject : TIdX509Name;
    FIssuer  : TIdX509Name;
    function RSubject:TIdX509Name;
    function RIssuer:TIdX509Name;
    function RnotBefore:TDateTime;
    function RnotAfter:TDateTime;
    function RFingerprint:TEVP_MD;
    function RFingerprintAsString:String;
  public
    Constructor Create(aX509: PX509); virtual;
    Destructor Destroy; override;
    //
    property Fingerprint: TEVP_MD read RFingerprint;
    property FingerprintAsString: String read RFingerprintAsString;
    property Subject: TIdX509Name read RSubject;
    property Issuer: TIdX509Name read RIssuer;
    property notBefore: TDateTime read RnotBefore;
    property notAfter: TDateTime read RnotAfter;
  end;

  TIdSSLCipher = class(TObject)
  private
    FSSLSocket: TIdSSLSocket;
    function GetDescription: String;
    function GetName: String;
    function GetBits: Integer;
    function GetVersion: String;
  public
    constructor Create(AOwner: TIdSSLSocket);
    destructor Destroy; override;
  published
    property Description: String read GetDescription;
    property Name: String read GetName;
    property Bits: Integer read GetBits;
    property Version: String read GetVersion;
  end;


  type
    EIdOpenSSLError = class(EIdException);
    EIdOpenSSLLoadError = class(EIdOpenSSLError);
    EIdOSSLCouldNotLoadSSLLibrary = class(EIdOpenSSLLoadError);
    EIdOSSLModeNotSet = class(EIdOpenSSLError);
    EIdOSSLGetMethodError = class(EIdOpenSSLError);
    EIdOSSLCreatingContextError = class(EIdOpenSSLError);
    EIdOSSLLoadingRootCertError = class(EIdOpenSSLLoadError);
    EIdOSSLLoadingCertError = class(EIdOpenSSLLoadError);
    EIdOSSLLoadingKeyError = class(EIdOpenSSLLoadError);
    EIdOSSLSettingCipherError = class(EIdOpenSSLError);
    EIdOSSLDataBindingError = class(EIdOpenSSLError);
    EIdOSSLAcceptError = class(EIdOpenSSLError);
    EIdOSSLConnectError = class(EIdOpenSSLError);

function LogicalAnd(A, B: Integer): Boolean;
procedure InfoCallback(sslSocket: PSSL; where: Integer; ret: Integer); cdecl;
function PasswordCallback(buf:PChar; size:Integer; rwflag:Integer; userdata: Pointer):Integer; cdecl;
function VerifyCallback(Ok: Integer; ctx: PX509_STORE_CTX):Integer; cdecl;

implementation

uses
  IdResourceStrings, SyncObjs;

var
  DLLLoadCount: Integer = 0;
  LockInfoCB: TCriticalSection;
  LockPassCB: TCriticalSection;
  LockVerifyCB: TCriticalSection;
  CallbackLockList: TThreadList;

//////////////////////////////////////////////////////////////
// SSL SUPPORT FUNCTIONS
//////////////////////////////////////////////////////////////

//////////////////////////////////////////////////////////////
// SSL CALLBACK ROUTINES
//////////////////////////////////////////////////////////////

function PasswordCallback(buf:PChar; size:Integer; rwflag:Integer; userdata: Pointer):Integer; cdecl;
var
  Password: String;
  IdSSLContext: TIdSSLContext;
begin
  LockPassCB.Enter;
  try
    Password := '';    {Do not Localize}

    IdSSLContext := TIdSSLContext(userdata);

    if (IdSSLContext.Parent is TIdSSLIOHandlerSocket) then begin
      TIdSSLIOHandlerSocket(IdSSLContext.Parent).DoGetPassword(Password);
    end;

    if (IdSSLContext.Parent is TIdServerIOHandlerSSL) then begin
      TIdServerIOHandlerSSL(IdSSLContext.Parent).DoGetPassword(Password);
    end;

    size := Length(Password);
    StrLCopy(buf, PChar(Password + #0), size + 1);
    Result := size;
  finally
    LockPassCB.Leave;
  end;
end;

procedure InfoCallback(sslSocket: PSSL; where: Integer; ret: Integer); cdecl;
var
  IdSSLSocket: TIdSSLSocket;
  StatusStr : String;
begin
  LockInfoCB.Enter;
  try
    IdSSLSocket := TIdSSLSocket(IdSslGetAppData(sslSocket));

    StatusStr := Format(RSOSSLStatusString, [StrPas(IdSslStateStringLong(sslSocket))]);

    if (IdSSLSocket.fParent is TIdSSLIOHandlerSocket) then begin
      TIdSSLIOHandlerSocket(IdSSLSocket.fParent).DoStatusInfo(StatusStr);
    end;

    if (IdSSLSocket.fParent is TIdServerIOHandlerSSL) then begin
      TIdServerIOHandlerSSL(IdSSLSocket.fParent).DoStatusInfo(StatusStr);
    end;
  finally
    LockInfoCB.Leave;
  end;

end;

{function RSACallback(sslSocket: PSSL; e: Integer; KeyLength: Integer):PRSA; cdecl;
const
  RSA: PRSA = nil;
var
  SSLSocket: TSSLWSocket;
  IdSSLSocket: TIdSSLSocket;
begin
  IdSSLSocket := TIdSSLSocket(IdSslGetAppData(sslSocket));

  if Assigned(IdSSLSocket) then begin
    IdSSLSocket.TriggerSSLRSACallback(KeyLength);
  end;

  if not Assigned(RSA) then begin
    RSA := f_RSA_generate_key(KeyLength, RSA_F4, @RSAProgressCallback, ssl);
  end;
  Result := RSA;
end;}

function AddMins (const DT: TDateTime; const Mins: Extended): TDateTime;
begin
  Result := DT + Mins / (60 * 24)
end;

function AddHrs (const DT: TDateTime; const Hrs: Extended): TDateTime;