idsslopenssl.pas

photo.163.com 相册下载器 多线程下载

{ $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:  11759: IdSSLOpenSSL.pas
{
{   Rev 1.37    7/27/2004 1:54:26 AM  JPMugaas
{ Now should use the Intercept property for sends.
}
{
{   Rev 1.36    2004-05-18 21:38:36  Mattias
{ Fixed unload bug
}
{
{   Rev 1.35    2004-05-07 16:34:26  Mattias
{ Implemented  OpenSSL locking callbacks
}
{
{   Rev 1.34    27/04/2004 9:38:48  HHariri
{ Added compiler directive so it works in BCB
}
{
{   Rev 1.33    4/26/2004 12:41:10 AM  BGooijen
{ Fixed WriteDirect
}
{
{   Rev 1.32    2004.04.08 10:55:30 PM  czhower
{ IOHandler chanegs.
}
{
{   Rev 1.31    3/7/2004 9:02:58 PM  JPMugaas
{ Fixed compiler warning about visibility.
}
{
{   Rev 1.30    2004.03.07 11:46:40 AM  czhower
{ Flushbuffer fix + other minor ones found
}
{
{   Rev 1.29    2/7/2004 5:50:50 AM  JPMugaas
{ Fixed Copyright.
}
{
{   Rev 1.28    2/6/2004 3:45:56 PM  JPMugaas
{ Only a start on NET porting.  This is not finished and will not compile on
{ DotNET>
}
{
{   Rev 1.27    2004.02.03 5:44:24 PM  czhower
{ Name changes
}
{
{   Rev 1.26    1/21/2004 4:03:48 PM  JPMugaas
{ InitComponent
}
{
{   Rev 1.25    1/14/2004 11:39:10 AM  JPMugaas
{ Server IOHandler now works.  Accept was commented out.
}
{
{   Rev 1.24    2003.11.29 10:19:28 AM  czhower
{ Updated for core change to InputBuffer.
}
{
{   Rev 1.23    10/21/2003 10:09:14 AM  JPMugaas
{ Intercept enabled.
}
{
{   Rev 1.22    10/21/2003 09:41:38 AM  JPMugaas
{ Updated for new API.  Verified with TIdFTP with active and passive transfers
{ as well as clear and protected data channels.
}
{
{   Rev 1.21    10/21/2003 07:32:38 AM  JPMugaas
{ Checked in what I have.  Porting still continues.
}
{
    Rev 1.20    10/17/2003 1:08:08 AM  DSiders
  Added localization comments.
}
{
{   Rev 1.19    2003.10.12 6:36:44 PM  czhower
{ Now compiles.
}
{
{   Rev 1.18    9/19/2003 11:24:58 AM  JPMugaas
{ Should compile.
}
{
{   Rev 1.17    9/18/2003 10:20:32 AM  JPMugaas
{ Updated for new API.
}
{
{   Rev 1.16    2003.07.16 3:26:52 PM  czhower
{ Fixed for a core change.
}
{
    Rev 1.15    6/30/2003 1:52:22 PM  BGooijen
  Changed for new buffer interface
}
{
    Rev 1.14    6/29/2003 5:42:02 PM  BGooijen
  fixed probelm in TIdSSLIOHandlerSocketOpenSSL.SetPassThrough that Henrick
  Hellstr鰉 reported
}
{
    Rev 1.13    5/7/2003 7:13:00 PM  BGooijen
  changed Connected to BindingAllocated in ReadFromSource
}
{
    Rev 1.12    3/30/2003 12:16:40 AM  BGooijen
  bugfixed+ added MakeFTPSvrPort/MakeFTPSvrPasv
}
{
{   Rev 1.11    3/14/2003 06:56:08 PM  JPMugaas
{ Added a clone method to the SSLContext.
}
{
{   Rev 1.10    3/14/2003 05:29:10 PM  JPMugaas
{ Change to prevent an AV when shutting down the FTP Server.
}
{
    Rev 1.9    3/14/2003 10:00:38 PM  BGooijen
  Removed TIdServerIOHandlerSSLBase.PeerPassthrough, the ssl is now enabled in
  the server-protocol-files
}
{
{   Rev 1.8    3/13/2003 11:55:38 AM  JPMugaas
{ Updated registration framework to give more information.
}
{
{   Rev 1.7    3/13/2003 11:07:14 AM  JPMugaas
{ OpenSSL classes renamed.
}
{
{   Rev 1.6    3/13/2003 10:28:16 AM  JPMugaas
{ Forgot the reegistration - OOPS!!!
}
{
{   Rev 1.5    3/13/2003 09:49:42 AM  JPMugaas
{ Now uses an abstract SSL base class instead of OpenSSL so 3rd-party vendors
{ can plug-in their products.
}
{
    Rev 1.4    3/13/2003 10:20:08 AM  BGooijen
  Server side fibers
}
{
{   Rev 1.3    2003.02.25 3:56:22 AM  czhower
}
{
    Rev 1.2    2/5/2003 10:27:46 PM  BGooijen
  Fixed bug in OpenEncodedConnection
}
{
    Rev 1.1    2/4/2003 6:31:22 PM  BGooijen
  Fixed for Indy 10
}
{
{   Rev 1.0    11/13/2002 08:01:24 AM  JPMugaas
}
unit IdSSLOpenSSL;
{
  Author: Gregor Ibic ([e-mail])
  Copyright: (c) Gregor Ibic, Intelicom d.o.o and Indy Working Group.
}
interface
{$TYPEDADDRESS OFF}
{$I IdCompilerDefines.inc}
uses
  Classes,
  IdGlobal,
  IdException,
  IdStackConsts,
  IdSocketHandle,
  {$IFNDEF DOTNET}
  IdSSLOpenSSLHeaders,
  {$ELSE}
  IdSSLOpenSSLHeadersNET,
  {$ENDIF}
  IdComponent,
  IdIOHandler,
  IdGlobalProtocols,
  IdTCPServer,
  IdThread,
  IdTCPConnection,
  IdIntercept, SysUtils,
  IdIOHandlerSocket,
  IdSSL,
  IdSocks,
  IdScheduler,
  IdYarn;

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;

  TIdSSLIOHandlerSocketOpenSSL = 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: TIdSSLIOHandlerSocketOpenSSL) 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 Clone : TIdSSLContext;
    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(const ABuf : TIdBytes): integer;
    function Recv(var ABuf : TIdBytes): 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;

  TIdSSLIOHandlerSocketOpenSSL = class(TIdSSLIOHandlerSocketBase)
  private
    fSSLContext: TIdSSLContext;
    fxSSLOptions: TIdSSLOptions;
    fSSLSocket: TIdSSLSocket;
    //fPeerCert: TIdX509;
    fOnStatusInfo: TCallbackEvent;
    fOnGetPassword: TPasswordEvent;
    fOnVerifyPeer: TVerifyPeerEvent;
    fSSLLayerClosed: Boolean;
    fOnBeforeConnect: TIOHandlerNotify;
    // function GetPeerCert: TIdX509;
    //procedure CreateSSLContext(axMode: TIdSSLMode);
    //

  protected
    procedure SetPassThrough(const Value: Boolean); override;
    procedure DoBeforeConnect(ASender: TIdSSLIOHandlerSocketOpenSSL); virtual;
    procedure DoStatusInfo(Msg: String); virtual;
    procedure DoGetPassword(var Password: String); virtual;
    function DoVerifyPeer(Certificate: TIdX509): Boolean; virtual;
    function RecvEnc(var ABuf : TIdBytes): integer; virtual;
    function SendEnc(const ABuf : TIdBytes): integer; virtual;
    procedure Init;
    procedure OpenEncodedConnection; virtual;
    //some overrides from base classes
    procedure InitComponent; override;

    procedure ConnectClient; override;
    function ReadFromSource(ARaiseExceptionIfDisconnected: Boolean = True;
     ATimeout: Integer = IdTimeoutDefault;
     ARaiseExceptionOnTimeout: Boolean = True): Integer; override;
  public
    procedure WriteDirect(
      ABuffer: TIdBytes
      ); override;
    destructor Destroy; override;
    function Clone :  TIdSSLIOHandlerSocketBase; override;
    procedure StartSSL; override;

    procedure AfterAccept; override;

    procedure Close; override;
    procedure Open; override;

    function Recv(var ABuf : TIdBytes): integer;
    function Send(const ABuf : TIdBytes): integer;

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

    property OnBeforeConnect: TIOHandlerNotify read fOnBeforeConnect write fOnBeforeConnect;
    property SSLContext: TIdSSLContext read fSSLContext write fSSLContext;
  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;

  TIdServerIOHandlerSSLOpenSSL = class(TIdServerIOHandlerSSLBase)
  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;
    procedure InitComponent; override;
  public
    procedure Init; override;
    function Accept(
      ASocket: TIdSocketHandle;
      // This is a thread and not a yarn. Its the listener thread.
      AListenerThread: TIdThread;
      AYarn: TIdYarn
      ): TIdIOHandler; override;
//    function Accept(ASocket: TIdSocketHandle; AThread: TIdThread) : TIdIOHandler;  override;

    destructor Destroy; override;
    function MakeClientIOHandler : TIdSSLIOHandlerSocketBase; override;

    //
    function MakeFTPSvrPort : TIdSSLIOHandlerSocketBase; override;
    function MakeFTPSvrPasv : TIdSSLIOHandlerSocketBase; override;
    //
    property SSLContext: TIdSSLContext read fSSLContext;
  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
  IdResourceStringsCore, IdResourceStringsProtocols, IdStack, IdStackBSDBase, IdAntiFreezeBase,
  IdExceptionCore, 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;