idsslopenssl.pas

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

begin
  Result := DT + Hrs / 24.0
end;

{function GetLocalTZBias: LongInt;
var
	TZ : TTimeZoneInformation;
begin
	case GetTimeZoneInformation (TZ) of
		TIME_ZONE_ID_STANDARD: Result := TZ.Bias + TZ.StandardBias;
		TIME_ZONE_ID_DAYLIGHT: Result := TZ.Bias + TZ.DaylightBias;
	else
		Result := TZ.Bias;
	end;
end;}

function GetLocalTime (const DT: TDateTime): TDateTime;
begin
  Result := DT - TimeZoneBias{ / (24 * 60)};
end;

procedure SslLockingCallback(mode, n : integer; Afile : PChar; line : integer) cdecl;
var
  Lock : TCriticalSection;
begin
  with CallbackLockList.LockList do
  try
    Lock := TCriticalSection(Items[n]);
  finally
    CallbackLockList.UnlockList;
  end;

  if (mode and OPENSSL_CRYPTO_LOCK) > 0 then
    Lock.Acquire
  else
    Lock.Release;
end;

procedure PrepareOpenSSLLocking;
var
  i, cnt : integer;
begin
  with CallbackLockList.LockList do
  try
    cnt := IdSslCryptoNumLocks;
    for i := 0 to cnt-1 do
      Add(TCriticalSection.Create);
  finally
    CallbackLockList.UnlockList;
  end;
end;

function _GetThreadID : integer cdecl;
begin
  Result := GetCurrentThreadHandle;
end;

function LoadOpenSLLibrary: Boolean;
begin
  if not IdSSLOpenSSLHeaders.Load then begin
    Result := False;
    Exit;
  end;

  InitializeRandom;
  // IdSslRandScreen;
  IdSslLoadErrorStrings;

  // Successful loading if true
  result := IdSslAddSslAlgorithms > 0;

  // Create locking structures, we need them for callback routines
  // they are probably not thread safe
  LockInfoCB := TCriticalSection.Create;
  LockPassCB := TCriticalSection.Create;
  LockVerifyCB := TCriticalSection.Create;

  // Handle internal OpenSSL locking
  CallbackLockList := TThreadList.Create;
  IdSslSetLockingCallback(SslLockingCallback);
  PrepareOpenSSLLocking;
  
  IdSslSetIdCallback(_GetThreadID);
end;

procedure UnLoadOpenSLLibrary;
var
  i : integer;
begin
  FreeAndNil(LockInfoCB);
  FreeAndNil(LockPassCB);
  FreeAndNil(LockVerifyCB);

  if Assigned(CallbackLockList) then
  begin
    with CallbackLockList.LockList do
      try
        for i := 0 to Count-1 do
          TObject(Items[i]).Free;

        Clear;
      finally
        CallbackLockList.UnlockList;
      end;
    FreeAndNil(CallbackLockList);
  end;

  IdSSLOpenSSLHeaders.Unload;
end;

function UTCTime2DateTime(UCTTime: PASN1_UTCTIME):TDateTime;
var
  year  : Word;
  month : Word;
  day   : Word;
  hour  : Word;
  min   : Word;
  sec   : Word;
  tz_h  : Integer;
  tz_m  : Integer;
begin
  Result := 0;
  if IdSslUCTTimeDecode(UCTTime, year, month, day, hour, min, sec, tz_h, tz_m) > 0 Then Begin
    Result := EncodeDate(year, month, day) + EncodeTime(hour, min, sec, 0);
    AddMins(Result, tz_m);
    AddHrs(Result, tz_h);
    Result := GetLocalTime(Result);
  end;
end;

function TranslateInternalVerifyToSLL(Mode: TIdSSLVerifyModeSet): Integer;
begin
  Result := OPENSSL_SSL_VERIFY_NONE;
  if sslvrfPeer in Mode then Result := Result or OPENSSL_SSL_VERIFY_PEER;
  if sslvrfFailIfNoPeerCert in Mode then Result:= Result or OPENSSL_SSL_VERIFY_FAIL_IF_NO_PEER_CERT;
  if sslvrfClientOnce in Mode then Result:= Result or OPENSSL_SSL_VERIFY_CLIENT_ONCE;
end;

{function TranslateSLLVerifyToInternal(Mode: Integer): TIdSSLVerifyModeSet;
begin
  Result := [];
  if LogicalAnd(Mode, OPENSSL_SSL_VERIFY_PEER) then Result := Result + [sslvrfPeer];
  if LogicalAnd(Mode, OPENSSL_SSL_VERIFY_FAIL_IF_NO_PEER_CERT) then Result := Result + [sslvrfFailIfNoPeerCert];
  if LogicalAnd(Mode, OPENSSL_SSL_VERIFY_CLIENT_ONCE) then Result := Result + [sslvrfClientOnce];
end;}

function LogicalAnd(A, B: Integer): Boolean;
begin
  Result := (A and B) = B;
end;

function VerifyCallback(Ok: Integer; ctx: PX509_STORE_CTX): Integer; cdecl;
var
  hcert: PX509;
  Certificate: TIdX509;
  hSSL: PSSL;
  IdSSLSocket: TIdSSLSocket;
  // str: String;
  VerifiedOK: Boolean;
  Depth: Integer;
  // Error: Integer;
begin
  LockVerifyCB.Enter;
  try
    VerifiedOK := True;
    try
      hcert := IdSslX509StoreCtxGetCurrentCert(ctx);
      hSSL := IdSslX509StoreCtxGetAppData(ctx);
      Certificate := TIdX509.Create(hcert);

      if hSSL <> nil then begin
        IdSSLSocket := TIdSSLSocket(IdSslGetAppData(hSSL));
      end
      else begin
        Result := Ok;
        exit;
      end;

      //Error :=
      IdSslX509StoreCtxGetError(ctx);
      Depth := IdSslX509StoreCtxGetErrorDepth(ctx);
    //  str := Format('Certificate: %s', [Certificate.Subject.OneLine]);    {Do not Localize}
    //  str := IdSSLSocket.GetSessionIDAsString;
    //  ShowMessage(str);

      if (IdSSLSocket.fParent is TIdSSLIOHandlerSocket) then begin
        VerifiedOK := TIdSSLIOHandlerSocket(IdSSLSocket.fParent).DoVerifyPeer(Certificate);
      end;

      if (IdSSLSocket.fParent is TIdServerIOHandlerSSL) then begin
        VerifiedOK := TIdServerIOHandlerSSL(IdSSLSocket.fParent).DoVerifyPeer(Certificate);
      end;

      if not ((Ok>0) and (IdSSLSocket.fSSLContext.VerifyDepth>=Depth)) then begin
        Ok := 0;
        {if Error = OPENSSL_X509_V_OK then begin
          Error := OPENSSL_X509_V_ERR_CERT_CHAIN_TOO_LONG;
        end;}
      end;
      FreeAndNil(Certificate);
    except
    end;
    if VerifiedOK and (Ok > 0) then begin
      Result := 1;
    end
    else begin
      Result := 0;
    end;

  //  Result := Ok; // testing
  finally
    LockVerifyCB.Leave;
  end;
end;

//////////////////////////////////////////////////////
//   TIdSSLOptions
///////////////////////////////////////////////////////

procedure TIdSSLOptions.AssignTo(ASource: TPersistent);
begin
  if ASource is TIdSSLOptions then
    with TIdSSLOptions(ASource) do begin
      RootCertFile := Self.RootCertFile;
      CertFile := Self.CertFile;
      KeyFile := Self.KeyFile;
      Method := Self.Method;
      Mode := Self.Mode;
      VerifyMode := Self.VerifyMode;
      VerifyDepth := Self.VerifyDepth;
      VerifyDirs := Self.VerifyDirs;
      CipherList := Self.CipherList;
    end
  else
    inherited AssignTo(ASource);
end;

///////////////////////////////////////////////////////
//   TIdServerIOHandlerSSL
///////////////////////////////////////////////////////

{ TIdServerIOHandlerSSL }

constructor TIdServerIOHandlerSSL.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fIsInitialized := False;
  fxSSLOptions := TIdSSLOptions.Create;
end;

destructor TIdServerIOHandlerSSL.Destroy;
begin
  if fSSLContext <> nil then begin
    FreeAndNil(fSSLContext);
  end;

  FreeAndNil(fxSSLOptions);
  inherited Destroy;
end;

procedure TIdServerIOHandlerSSL.Init;
begin
  // CreateSSLContext(SSLOptions.fMode);
  // CreateSSLContext;
  fSSLContext := TIdSSLContext.Create;
  with fSSLContext do begin
    Parent := self;
    RootCertFile := SSLOptions.RootCertFile;
    CertFile := SSLOptions.CertFile;
    KeyFile := SSLOptions.KeyFile;

    fVerifyDepth := SSLOptions.fVerifyDepth;
    fVerifyMode := SSLOptions.fVerifyMode;
    // fVerifyFile := SSLOptions.fVerifyFile;
    fVerifyDirs := SSLOptions.fVerifyDirs;
    fCipherList := SSLOptions.fCipherList;

    if Assigned(fOnVerifyPeer) then begin
      VerifyOn := True;
    end
    else begin
      VerifyOn := False;
    end;

    if Assigned(fOnStatusInfo) then begin
      StatusInfoOn := True;
    end
    else begin
      StatusInfoOn := False;
    end;

    {if Assigned(fOnGetPassword) then begin
      PasswordRoutineOn := True;
    end
    else begin
      PasswordRoutineOn := False;
    end;}

    fMethod :=  SSLOptions.Method;
    fMode := SSLOptions.Mode;
    fSSLContext.InitContext(sslCtxServer);
  end;

  fIsInitialized := True;
end;

function TIdServerIOHandlerSSL.Accept(ASocket: TIdStackSocketHandle; AThread: TIdThread = nil): TIdIOHandler;
var
  tmpIdCIOpenSSL: TIdSSLIOHandlerSocket;
begin
  if not fIsInitialized then begin
    Init;
  end;

  tmpIdCIOpenSSL := TIdSSLIOHandlerSocket.Create(nil); // Was self
  tmpIdCIOpenSSL.fIsPeer := True;
  tmpIdCIOpenSSL.Open;
  if tmpIdCIOpenSSL.Binding.Accept(ASocket) then begin
    tmpIdCIOpenSSL.fxSSLOptions.Assign(fxSSLOptions);
    tmpIdCIOpenSSL.fSSLSocket := TIdSSLSocket.Create(self);
    tmpIdCIOpenSSL.fSSLContext := fSSLContext;
    result := tmpIdCIOpenSSL;
  end
  else begin
    result := nil;
    FreeAndNil(tmpIdCIOpenSSL);
  end;
end;

procedure TIdServerIOHandlerSSL.DoStatusInfo(Msg: String);
begin
  if Assigned(fOnStatusInfo) then
    fOnStatusInfo(Msg);
end;

procedure TIdServerIOHandlerSSL.DoGetPassword(var Password: String);
begin
  if Assigned(fOnGetPassword) then
    fOnGetPassword(Password);
end;

function TIdServerIOHandlerSSL.DoVerifyPeer(Certificate: TIdX509): Boolean;
begin
  Result := True;
  if Assigned(fOnVerifyPeer) then
    Result := fOnVerifyPeer(Certificate);
end;

///////////////////////////////////////////////////////
//   TIdSSLIOHandlerSocket
///////////////////////////////////////////////////////

{ TIdSSLIOHandlerSocket }

constructor TIdSSLIOHandlerSocket.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fIsPeer := False;
  fxSSLOptions := TIdSSLOptions.Create;
  fSSLLayerClosed := True;
end;

destructor TIdSSLIOHandlerSocket.Destroy;
begin
  FreeAndNil(fxSSLOptions); //Added
  FreeAndNil(fSSLSocket);
  // FreeAndNil(fSSLContext);
  if not fIsPeer then begin
    FreeAndNil(fSSLContext);
  end;
  inherited Destroy;
end;

procedure TIdSSLIOHandlerSocket.ConnectClient(const AHost: string; const APort: Integer; const ABoundIP: string;
     const ABoundPort: Integer; const ABoundPortMin: Integer; const ABoundPortMax: Integer;
     const ATimeout: Integer = IdTimeoutDefault);
begin
  inherited ConnectClient(AHost, APort, ABoundIP, ABoundPort, ABoundPortMin, ABoundPortMax, ATimeout);

  DoBeforeConnect(self);

  // CreateSSLContext(sslmClient);
  // CreateSSLContext(SSLOptions.fMode);

  try
    Init;
  except
    on EIdOSSLCouldNotLoadSSLLibrary do begin
      if not PassThrough then raise;
    end;
  end;

  if not PassThrough then begin
    OpenEncodedConnection;
  end;
end;

procedure TIdSSLIOHandlerSocket.Close;
begin
  FreeAndNil(fSSLSocket);
  if not fIsPeer then begin
    FreeAndNil(fSSLContext);
  end;

  inherited Close;
end;

procedure TIdSSLIOHandlerSocket.Open;
begin
  inherited Open;
end;

function TIdSSLIOHandlerSocket.Recv(var ABuf; ALen: integer): integer;
begin
  if fPassThrough then begin
    result := inherited Recv(ABuf, ALen);
  end
  else begin
    result := RecvEnc(ABuf, ALen);
  end;
end;

function TIdSSLIOHandlerSocket.Send(var ABuf; ALen: integer): integer;
begin
  if fPassThrough then begin
    result := inherited Send(ABuf, ALen);
  end
  else begin
    result := SendEnc(ABuf, ALen);
  end;