aksdb
/
restemplate
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
restemplate/indy/Protocols/IdSSLOpenSSLUtils.pas

1088 lines
30 KiB
Plaintext
Raw Blame History

unit IdSSLOpenSSLUtils;
interface
{$I IdCompilerDefines.inc}
uses
IdCTypes,
IdSSLOpenSSLHeaders,
Classes;
type
TIdSSLULong = packed record
case Byte of
0: (B1, B2, B3, B4: Byte);
1: (W1, W2: Word);
2: (L1: Longint);
3: (C1: LongWord);
end;
TIdSSLEVP_MD = record
Length: TIdC_UINT;
MD: Array [0 .. EVP_MAX_MD_SIZE - 1] of AnsiChar;
end;
TIdSSLByteArray = record
Length: TIdC_INT;
Data: PAnsiChar;
End;
function LoadOpenSSLLibrary: Boolean;
procedure UnLoadOpenSSLLibrary;
// locking callback stuff
procedure LockPasswordCB_Enter;
procedure LockPasswordCB_Leave;
procedure LockInfoCB_Enter;
procedure LockInfoCB_Leave;
procedure LockVerifyCB_Enter;
procedure LockVerifyCB_Leave;
//
function AddMins(const DT: TDateTime; const Mins: Extended): TDateTime;
function AddHrs(const DT: TDateTime; const Hrs: Extended): TDateTime;
function GetLocalTime(const DT: TDateTime): TDateTime;
function IndySSL_load_client_CA_file(const AFileName: String) : PSTACK_OF_X509_NAME;
function IndySSL_CTX_use_PrivateKey_file(ctx: PSSL_CTX; const AFileName: String;
AType: Integer): Boolean;
function IndySSL_CTX_use_certificate_file(ctx: PSSL_CTX;
const AFileName: String; AType: Integer): Boolean;
function IndyX509_STORE_load_locations(ctx: PX509_STORE;
const AFileName, APathName: String): TIdC_INT;
function IndySSL_CTX_load_verify_locations(ctx: PSSL_CTX;
const ACAFile, ACAPath: String): TIdC_INT;
procedure DumpCert(AOut: TStrings; AX509: PX509);
procedure SslLockingCallback(mode, n: TIdC_INT; Afile: PAnsiChar;
line: TIdC_INT)cdecl;
procedure PrepareOpenSSLLocking;
{$IFNDEF WIN32_OR_WIN64}
function _GetThreadID: TIdC_ULONG; cdecl;
{$ENDIF}
// Note that I define UCTTime as PASN1_STRING
function UTCTime2DateTime(UCTTime: PASN1_UTCTIME): TDateTime;
{ function RSACallback(sslSocket: PSSL; e: Integer; KeyLength: Integer):PRSA; cdecl;
}
function LogicalAnd(A, B: Integer): Boolean;
function BytesToHexString(APtr: Pointer; ALen: Integer): String;
function MDAsString(const AMD: TIdSSLEVP_MD): String;
procedure GetStateVars(const sslSocket: PSSL; AWhere, Aret: TIdC_INT; var VTypeStr, VMsg : String);
{$IFDEF STRING_IS_UNICODE}
{$IFDEF WINDOWS}
{
This is for some file lookup definitions for a LOOKUP method that
uses Unicode filesnames instead of ASCII or UTF8. It is not meant to be portable
at all.
}
function by_Indy_unicode_file_ctrl(ctx: PX509_LOOKUP; cmd: TIdC_INT;
const argc: PAnsiChar; argl: TIdC_LONG; out ret: PAnsiChar): TIdC_INT;
cdecl; forward;
const
Indy_x509_unicode_file_lookup: X509_LOOKUP_METHOD =
(name: PAnsiChar('Load file into cache'); new_item: nil; // * new */
free: nil; // * free */
init: nil; // * init */
shutdown: nil; // * shutdown */
ctrl: by_Indy_unicode_file_ctrl; // * ctrl */
get_by_subject: nil; // * get_by_subject */
get_by_issuer_serial: nil; // * get_by_issuer_serial */
get_by_fingerprint: nil; // * get_by_fingerprint */
get_by_alias: nil // * get_by_alias */
);
{$ENDIF}
{$ENDIF}
implementation
uses
{$IFDEF WIN32_OR_WIN64}
Windows,
{$ENDIF}
{$IFDEF USE_VCL_POSIX}
Posix.Glue,
Posix.SysTime,
Posix.Time,
Posix.Unistd,
{$ENDIF}
IdGlobal,
IdGlobalProtocols,
IdResourceStrings,
IdResourceStringsCore,
IdResourceStringsProtocols,
IdThreadSafe,
SyncObjs,
SysUtils;
var
SSLIsLoaded: TIdThreadSafeBoolean = nil;
LockInfoCB: TIdCriticalSection = nil;
LockPassCB: TIdCriticalSection = nil;
LockVerifyCB: TIdCriticalSection = nil;
CallbackLockList: TThreadList = nil;
procedure LockPasswordCB_Enter;
begin
LockPassCB.Enter;
end;
procedure LockPasswordCB_Leave;
begin
LockPassCB.Leave;
end;
procedure LockInfoCB_Enter;
begin
LockInfoCB.Enter;
end;
procedure LockInfoCB_Leave;
begin
LockInfoCB.Leave;
end;
procedure LockVerifyCB_Enter;
begin
LockVerifyCB.Enter;
end;
procedure LockVerifyCB_Leave;
begin
LockVerifyCB.Leave;
end;
{
IMPORTANT!!!
OpenSSL can not handle Unicode file names at all. On Posix systems, UTF8 File
names can be used with OpenSSL. The Windows operating system does not accept
UTF8 file names at all so we have our own routines that will handle Unicode
filenames. Most of this section of code is based on code in the OpenSSL .DLL
which is copyrighted by the OpenSSL developers. Come of it is translated into
Pascal and made some modifications so that it will handle Unicode filenames.
}
{$IFDEF STRING_IS_UNICODE}
{$IFDEF WINDOWS}
function Indy_unicode_X509_load_cert_crl_file(ctx: PX509_LOOKUP; const AFileName: String;
const _type: TIdC_INT): TIdC_INT; forward;
function Indy_unicode_X509_load_cert_file(ctx: PX509_LOOKUP; const AFileName: String;
_type: TIdC_INT): TIdC_INT; forward;
function Indy_Unicode_X509_LOOKUP_file(): PX509_LOOKUP_METHOD cdecl;
{$IFDEF USE_INLINE} inline; {$ENDIF}
begin
Result := @Indy_x509_unicode_file_lookup;
end;
function by_Indy_unicode_file_ctrl(ctx: PX509_LOOKUP; cmd: TIdC_INT;
const argc: PAnsiChar; argl: TIdC_LONG; out ret: PAnsiChar): TIdC_INT; cdecl;
var
LOk: TIdC_INT;
LFileName: String;
begin
LOk := 0;
case cmd of
X509_L_FILE_LOAD:
begin
case argl of
X509_FILETYPE_DEFAULT:
begin
LFileName := GetEnvironmentVariable
(String(X509_get_default_cert_file_env));
if LFileName <> '' then begin
Result := Indy_unicode_X509_load_cert_crl_file(ctx, LFileName,
X509_FILETYPE_PEM);
end else begin
Result := Indy_unicode_X509_load_cert_crl_file(ctx,
String(X509_get_default_cert_file), X509_FILETYPE_PEM);
end;
if Result = 0 then begin
X509err(X509_F_BY_FILE_CTRL, X509_R_LOADING_DEFAULTS);
end;
end;
X509_FILETYPE_PEM:
begin
// Note that typecasting an AnsiChar as a WideChar is normally a crazy
// thing to do. The thing is that the OpenSSL API is based on ASCII or
// UTF8, not Unicode and we are writing this just for Unicode filenames.
LFileName := PWideChar(argc);
LOk := Indy_unicode_X509_load_cert_crl_file(ctx, LFileName,
X509_FILETYPE_PEM);
end;
else
LFileName := PWideChar(argc);
LOk := Indy_unicode_X509_load_cert_file(ctx, LFileName, TIdC_INT(argl));
end;
end;
end;
{Do it this way because 1 must be returned for success and unfortunately, some
routines return the number of certificates that were loaded which could be
more than 1}
if LOk > 0 then begin
Result := 1;
end else begin
Result := 0;
end;
end;
function Indy_unicode_X509_load_cert_file(ctx: PX509_LOOKUP; const AFileName: String;
_type: TIdC_INT): TIdC_INT;
var
LM: TMemoryStream;
Lin: PBIO;
LX: PX509;
i: Integer;
begin
Result := 0;
Lin := nil;
LM := TMemoryStream.Create;
try
LM.LoadFromFile(AFileName);
Lin := BIO_new_mem_buf(LM.Memory, LM.Size);
if Assigned(Lin) then begin
case _type of
X509_FILETYPE_PEM:
begin
repeat
LX := PEM_read_bio_X509_AUX(Lin, nil, nil, nil);
if not Assigned(LX) then begin
if ((ERR_GET_REASON(ERR_peek_last_error())
= PEM_R_NO_START_LINE) and (Result > 0)) then begin
ERR_clear_error();
Break;
end else begin
X509err(X509_F_X509_LOAD_CERT_FILE, ERR_R_PEM_LIB);
// goto err;
end;
end;
until False;
end;
X509_FILETYPE_ASN1:
begin
LX := d2i_X509_bio(Lin, nil);
if not Assigned(LX) then begin
X509err(X509_F_X509_LOAD_CERT_FILE, ERR_R_ASN1_LIB);
// goto err;
end else begin
i := X509_STORE_add_cert(ctx^.store_ctx, LX);
if i <> 0 then begin
Result := i;
end;
end;
end;
else
X509err(X509_F_X509_LOAD_CERT_FILE, X509_R_BAD_X509_FILETYPE);
// goto err;
end;
end else begin
X509err(X509_F_X509_LOAD_CERT_FILE, ERR_R_SYS_LIB);
// goto err;
end;
finally
BIO_free(Lin);
FreeAndNil(LM);
end;
end;
function Indy_unicode_X509_load_cert_crl_file(ctx: PX509_LOOKUP; const AFileName: String;
const _type: TIdC_INT): TIdC_INT;
var
LM: TMemoryStream;
Linf: PSTACK_OF_X509_INFO;
Litmp: PX509_INFO;
Lin: PBIO;
i: Integer;
begin
Result := 0;
Linf := nil;
Lin := nil;
if _type <> X509_FILETYPE_PEM then begin
Result := Indy_unicode_X509_load_cert_file(ctx, AFileName, _type);
exit;
end;
LM := TMemoryStream.Create;
try
LM.LoadFromFile(AFileName);
Lin := BIO_new_mem_buf(LM.Memory, LM.Size);
if Assigned(Lin) then begin
Linf := PEM_X509_INFO_read_bio(Lin, nil, nil, nil);
end else begin
X509err(X509_F_X509_LOAD_CERT_CRL_FILE, ERR_R_SYS_LIB);
end;
BIO_free(Lin);
FreeAndNil(LM);
// Surpress exception here since it's going to be called by the OpenSSL .DLL
// Follow the OpenSSL .DLL Error conventions.
except
X509err(X509_F_X509_LOAD_CERT_CRL_FILE, ERR_R_SYS_LIB);
BIO_free(Lin);
FreeAndNil(LM);
exit;
end;
if not Assigned(Linf) then begin
X509err(X509_F_X509_LOAD_CERT_CRL_FILE, ERR_R_PEM_LIB);
exit;
end;
try
for i := 0 to sk_X509_INFO_num(Linf) - 1 do begin
Litmp := sk_X509_INFO_value(Linf, i);
if Assigned(Litmp^.x509) then begin
X509_STORE_add_cert(ctx^.store_ctx, Litmp^.x509);
Inc(Result);
end;
if Assigned(Litmp^.crl) then begin
X509_STORE_add_crl(ctx^.store_ctx, Litmp^.crl);
Inc(Result);
end;
end;
finally
sk_X509_INFO_pop_free(Linf, @X509_INFO_free);
end;
end;
procedure IndySSL_load_client_CA_file_err(var VRes: PSTACK_OF_X509_NAME);
{$IFDEF USE_INLINE} inline; {$ENDIF}
begin
if Assigned(VRes) then begin
sk_X509_NAME_pop_free(VRes, @X509_NAME_free);
VRes := nil;
end;
end;
function IndySSL_load_client_CA_file(const AFileName: String): PSTACK_OF_X509_NAME;
var
LM: TMemoryStream;
LB: PBIO;
Lsk: PSTACK_OF_X509_NAME;
LX: PX509;
LXN, LXNDup: PX509_NAME;
begin
Result := nil;
LX := nil;
Lsk := sk_X509_NAME_new(nil); // (xname_cmp);
if Assigned(Lsk) then begin
try
LM := TMemoryStream.Create;
try
LM.LoadFromFile(AFileName);
LB := BIO_new_mem_buf(LM.Memory, LM.Size);
if Assigned(LB) then begin
try
while (PEM_read_bio_X509(LB, @LX, nil, nil) <> nil) do begin
try
if not Assigned(Result) then begin
Result := sk_X509_NAME_new_null;
// RLebeau: exit here if not Assigned??
if not Assigned(Result) then begin
SSLerr(SSL_F_SSL_LOAD_CLIENT_CA_FILE, ERR_R_MALLOC_FAILURE);
end;
end;
LXN := X509_get_subject_name(LX);
if not Assigned(LXN) then begin
// error
IndySSL_load_client_CA_file_err(Result);
// RLebeau: exit here??
// goto err;
end;
// * check for duplicates */
LXNDup := X509_NAME_dup(LXN);
if not Assigned(LXNDup) then begin
// error
IndySSL_load_client_CA_file_err(Result);
// RLebeau: exit here??
// goto err;
end;
if (sk_X509_NAME_find(Lsk, LXNDup) >= 0) then begin
X509_NAME_free(LXNDup);
end else begin
sk_X509_NAME_push(Result, LXNDup);
end;
finally
X509_free(LX);
end;
end;
finally
BIO_free(LB);
end;
end else begin
SSLerr(SSL_F_SSL_LOAD_CLIENT_CA_FILE, ERR_R_MALLOC_FAILURE);
end;
finally
FreeAndNil(LM);
end;
finally
sk_X509_NAME_free(Lsk);
end;
end else begin
SSLerr(SSL_F_SSL_LOAD_CLIENT_CA_FILE, ERR_R_MALLOC_FAILURE);
end;
if Assigned(Result) then begin
ERR_clear_error;
end;
end;
function IndySSL_CTX_use_PrivateKey_file(ctx: PSSL_CTX; const AFileName: String;
AType: Integer): Boolean;
var
LM: TMemoryStream;
B: PBIO;
LKey: PEVP_PKEY;
j: TIdC_INT;
begin
Result := False;
LM := TMemoryStream.Create;
try
LM.LoadFromFile(AFileName);
B := BIO_new_mem_buf(LM.Memory, LM.Size);
if Assigned(B) then begin
try
LKey := nil;
case AType of
SSL_FILETYPE_PEM:
begin
j := ERR_R_PEM_LIB;
LKey := PEM_read_bio_PrivateKey(B, nil,
ctx^.default_passwd_callback,
ctx^.default_passwd_callback_userdata);
end;
SSL_FILETYPE_ASN1:
begin
j := ERR_R_ASN1_LIB;
LKey := d2i_PrivateKey_bio(B, nil);
end;
else
j := SSL_R_BAD_SSL_FILETYPE;
end;
if Assigned(LKey) then begin
Result := SSL_CTX_use_PrivateKey(ctx, LKey) > 0;
EVP_PKEY_free(LKey);
end else begin
SSLerr(SSL_F_SSL_CTX_USE_PRIVATEKEY_FILE, j);
end;
finally
if Assigned(B) then begin
BIO_free(B);
end;
end;
end else begin
SSLerr(SSL_F_SSL_CTX_USE_PRIVATEKEY_FILE, ERR_R_BUF_LIB);
end;
finally
FreeAndNil(LM);
end;
end;
function IndySSL_CTX_use_certificate_file(ctx: PSSL_CTX;
const AFileName: String; AType: Integer): Boolean;
var
LM: TMemoryStream;
B: PBIO;
LX: PX509;
j: TIdC_INT;
begin
Result := False;
LM := TMemoryStream.Create;
try
LM.LoadFromFile(AFileName);
B := BIO_new_mem_buf(LM.Memory, LM.Size);
if Assigned(B) then begin
try
LX := nil;
case AType of
SSL_FILETYPE_ASN1:
begin
j := ERR_R_ASN1_LIB;
LX := d2i_X509_bio(B, nil);
end;
SSL_FILETYPE_PEM:
begin
j := ERR_R_PEM_LIB;
LX := PEM_read_bio_X509(B, nil, ctx^.default_passwd_callback,
ctx^.default_passwd_callback_userdata);
end
else
j := SSL_R_BAD_SSL_FILETYPE;
end;
if Assigned(LX) then begin
Result := SSL_CTX_use_certificate(ctx, LX) > 0;
X509_free(LX);
end else begin
SSLerr(SSL_F_SSL_CTX_USE_CERTIFICATE_FILE, j);
end;
finally
BIO_free(B);
end;
end else begin
SSLerr(SSL_F_SSL_CTX_USE_CERTIFICATE_FILE, ERR_R_BUF_LIB);
end;
finally
FreeAndNil(LM);
end;
end;
function IndyX509_STORE_load_locations(ctx: PX509_STORE;
const AFileName, APathName: String): TIdC_INT;
var
lookup: PX509_LOOKUP;
begin
Result := 0;
if AFileName <> '' then begin
lookup := X509_STORE_add_lookup(ctx, Indy_Unicode_X509_LOOKUP_file);
if Assigned(lookup) then begin
if (X509_LOOKUP_load_file(lookup, PAnsiChar(@AFileName[1]),
X509_FILETYPE_PEM) <> 1) then begin
exit;
end;
Result := 1;
end else begin
exit;
end;
end;
{ To do: Figure out how to do the hash dir lookup with Unicode. }
if APathName <> '' then begin
Result := X509_STORE_load_locations(ctx, nil, PAnsiChar(AnsiString(APathName)));
end;
end;
function IndySSL_CTX_load_verify_locations(ctx: PSSL_CTX;
const ACAFile, ACAPath: String): TIdC_INT;
{$IFDEF USE_INLINE} inline; {$ENDIF}
begin
Result := IndyX509_STORE_load_locations(ctx^.cert_store, ACAFile, ACAPath);
end;
{$ENDIF} // WINDOWS
{$IFDEF UNIX}
function IndySSL_load_client_CA_file(const AFileName: String) : PSTACK_OF_X509_NAME;
begin
Result := SSL_load_client_CA_file(PAnsiChar(UTF8String(AFileName)));
end;
function IndySSL_CTX_use_PrivateKey_file(ctx: PSSL_CTX; const AFileName: String;
AType: Integer): Boolean;
{$IFDEF USE_INLINE} inline; {$ENDIF}
begin
Result := SSL_CTX_use_PrivateKey_file(ctx, PAnsiChar(UTF8String(AFileName)),
AType) > 0;
end;
function IndySSL_CTX_use_certificate_file(ctx: PSSL_CTX;
const AFileName: String; AType: Integer): Boolean;
{$IFDEF USE_INLINE} inline; {$ENDIF}
begin
Result := SSL_CTX_use_certificate_file(ctx, PAnsiChar(UTF8String(AFileName)),
AType) > 0;
end;
function IndyX509_STORE_load_locations(ctx: PX509_STORE;
const AFileName, APathName: String): TIdC_INT;
{$IFDEF USE_INLINE} inline; {$ENDIF}
begin
// RLebeau 4/18/2010: X509_STORE_load_locations() expects nil pointers
// for unused values, but casting a string directly to a PAnsiChar
// always produces a non-nil pointer, which causes X509_STORE_load_locations()
// to fail. Need to cast the string to an intermediate Pointer so the
// PAnsiChar cast is applied to the raw data and thus can be nil...
//
Result := X509_STORE_load_locations(ctx,
PAnsiChar(Pointer(UTF8String(AFileName))),
PAnsiChar(Pointer(UTF8String(APathName))));
end;
function IndySSL_CTX_load_verify_locations(ctx: PSSL_CTX;
const ACAFile, ACAPath: String): TIdC_INT;
{$IFDEF USE_INLINE} inline; {$ENDIF}
begin
Result := IndyX509_STORE_load_locations(ctx^.cert_store, ACAFile, ACAPath);
end;
{$ENDIF} // UNIX
{$ELSE} // STRING_IS_UNICODE
function IndySSL_load_client_CA_file(const AFileName: String) : PSTACK_OF_X509_NAME;
{$IFDEF USE_INLINE} inline; {$ENDIF}
begin
Result := SSL_load_client_CA_file(PAnsiChar(AFileName));
end;
function IndySSL_CTX_use_PrivateKey_file(ctx: PSSL_CTX; const AFileName: String;
AType: Integer): Boolean;
{$IFDEF USE_INLINE} inline; {$ENDIF}
begin
Result := SSL_CTX_use_PrivateKey_file(ctx, PAnsiChar(AFileName), AType) > 0;
end;
function IndySSL_CTX_use_certificate_file(ctx: PSSL_CTX;
const AFileName: String; AType: Integer): Boolean;
{$IFDEF USE_INLINE} inline; {$ENDIF}
begin
Result := SSL_CTX_use_certificate_file(ctx, PAnsiChar(AFileName), AType) > 0;
end;
function IndyX509_STORE_load_locations(ctx: PX509_STORE;
const AFileName, APathName: String): TIdC_INT;
{$IFDEF USE_INLINE} inline; {$ENDIF}
begin
// RLebeau 4/18/2010: X509_STORE_load_locations() expects nil pointers
// for unused values, but casting a string directly to a PAnsiChar
// always produces a non-nil pointer, which causes X509_STORE_load_locations()
// to fail. Need to cast the string to an intermediate Pointer so the
// PAnsiChar cast is applied to the raw data and thus can be nil...
//
Result := X509_STORE_load_locations(ctx,
PAnsiChar(Pointer(AFileName)),
PAnsiChar(Pointer(APathName)));
end;
function IndySSL_CTX_load_verify_locations(ctx: PSSL_CTX;
const ACAFile, ACAPath: String): TIdC_INT;
begin
// RLebeau 4/18/2010: X509_STORE_load_locations() expects nil pointers
// for unused values, but casting a string directly to a PAnsiChar
// always produces a non-nil pointer, which causes X509_STORE_load_locations()
// to fail. Need to cast the string to an intermediate Pointer so the
// PAnsiChar cast is applied to the raw data and thus can be nil...
//
Result := SSL_CTX_load_verify_locations(ctx,
PAnsiChar(Pointer(ACAFile)),
PAnsiChar(Pointer(ACAPath)));
end;
{$ENDIF}
function AddMins(const DT: TDateTime; const Mins: Extended): TDateTime;
{$IFDEF USE_INLINE} inline; {$ENDIF}
begin
Result := DT + Mins / (60 * 24)
end;
function AddHrs(const DT: TDateTime; const Hrs: Extended): TDateTime;
{$IFDEF USE_INLINE} inline; {$ENDIF}
begin
Result := DT + Hrs / 24.0;
end;
function GetLocalTime(const DT: TDateTime): TDateTime;
{$IFDEF USE_INLINE} inline; {$ENDIF}
begin
Result := DT - TimeZoneBias { / (24 * 60) } ;
end;
{$IFDEF OPENSSL_SET_MEMORY_FUNCS}
function IdMalloc(num: Cardinal): Pointer cdecl;
begin
Result := AllocMem(num);
end;
function IdRealloc(addr: Pointer; num: Cardinal): Pointer cdecl;
begin
Result := addr;
ReallocMem(Result, num);
end;
procedure IdFree(addr: Pointer)cdecl;
begin
FreeMem(addr);
end;
procedure IdSslCryptoMallocInit;
// replaces the actual alloc routines
// this is useful if you are using a memory manager that can report on leaks
// at shutdown time.
var
r: Integer;
begin
r := CRYPTO_set_mem_functions(@IdMalloc, @IdRealloc, @IdFree);
Assert(r <> 0);
end;
{$ENDIF}
{$IFNDEF OPENSSL_NO_BIO}
procedure DumpCert(AOut: TStrings; AX509: PX509);
{$IFDEF USE_INLINE} inline; {$ENDIF}
var
LMem: PBIO;
LLen : TIdC_INT;
LBufPtr : Pointer;
begin
if Assigned(X509_print) then begin
LMem := BIO_new(BIO_s_mem);
try
X509_print(LMem, AX509);
LLen := BIO_get_mem_data( LMem, LBufPtr);
if (LLen > 0) and Assigned(LBufPtr) then begin
{
We could have used RawToBytes() but that would have made a copy of the
output buffer.
}
AOut.Text := TIdTextEncoding.UTF8.GetString( TIdBytes(LBufPtr^), 0, LLen);
end;
finally
if Assigned(LMem) then begin
BIO_free(LMem);
end;
end;
end;
end;
{$ELSE}
procedure DumpCert(AOut: TStrings; AX509: PX509);
begin
end;
{$ENDIF}
{$IFNDEF WIN32_OR_WIN64}
procedure _threadid_func(id : PCRYPTO_THREADID) cdecl;
begin
if Assigned(CRYPTO_THREADID_set_numeric) then begin
CRYPTO_THREADID_set_numeric(id, TIdC_ULONG(CurrentThreadId));
end;
end;
function _GetThreadID: TIdC_ULONG; cdecl;
begin
// TODO: Verify how well this will work with fibers potentially running from
// thread to thread or many on the same thread.
Result := TIdC_ULONG(CurrentThreadId);
end;
{$ENDIF}
function LoadOpenSSLLibrary: Boolean;
begin
Assert(SSLIsLoaded <> nil);
SSLIsLoaded.Lock;
try
if SSLIsLoaded.Value then begin
Result := True;
exit;
end;
Result := IdSSLOpenSSLHeaders.Load;
if not Result then begin
exit;
end;
{$IFDEF OPENSSL_SET_MEMORY_FUNCS}
// has to be done before anything that uses memory
IdSslCryptoMallocInit;
{$ENDIF}
// required eg to encrypt a private key when writing
OpenSSL_add_all_ciphers;
OpenSSL_add_all_digests;
InitializeRandom;
// IdSslRandScreen;
SSL_load_error_strings;
// Successful loading if true
Result := SSLeay_add_ssl_algorithms > 0;
if not Result then begin
exit;
end;
// Create locking structures, we need them for callback routines
Assert(LockInfoCB = nil);
LockInfoCB := TIdCriticalSection.Create;
LockPassCB := TIdCriticalSection.Create;
LockVerifyCB := TIdCriticalSection.Create;
// Handle internal OpenSSL locking
CallbackLockList := TThreadList.Create;
PrepareOpenSSLLocking;
CRYPTO_set_locking_callback(SslLockingCallback);
{$IFNDEF WIN32_OR_WIN64}
if Assigned(CRYPTO_THREADID_set_callback) then begin
CRYPTO_THREADID_set_callback( _threadid_func );
end else begin
CRYPTO_set_id_callback(_GetThreadID);
end;
{$ENDIF}
SSLIsLoaded.Value := True;
Result := True;
finally
SSLIsLoaded.Unlock;
end;
end;
procedure UnLoadOpenSSLLibrary;
// allow the user to call unload directly?
// will then need to implement reference count
var
i: Integer;
begin
// ssl was never loaded
if LockInfoCB = nil then begin
exit;
end;
CRYPTO_set_locking_callback(nil);
IdSSLOpenSSLHeaders.Unload;
FreeAndNil(LockInfoCB);
FreeAndNil(LockPassCB);
FreeAndNil(LockVerifyCB);
if Assigned(CallbackLockList) then begin
with CallbackLockList.LockList do
try
for i := 0 to Count - 1 do begin
TObject(Items[i]).free;
end;
Clear;
finally
CallbackLockList.UnlockList;
end;
FreeAndNil(CallbackLockList);
end;
SSLIsLoaded.Value := False;
end;
procedure SslLockingCallback(mode, n: TIdC_INT; Afile: PAnsiChar;
line: TIdC_INT)cdecl;
var
Lock: TIdCriticalSection;
begin
Assert(CallbackLockList <> nil);
Lock := nil;
with CallbackLockList.LockList do
try
if n < Count then begin
Lock := TIdCriticalSection(Items[n]);
end;
finally
CallbackLockList.UnlockList;
end;
Assert(Lock <> nil);
if (mode and CRYPTO_LOCK) = CRYPTO_LOCK then begin
Lock.Acquire;
end else begin
Lock.Release;
end;
end;
procedure PrepareOpenSSLLocking;
var
i, cnt: Integer;
Lock: TIdCriticalSection;
begin
with CallbackLockList.LockList do
try
cnt := _CRYPTO_num_locks;
for i := 0 to cnt - 1 do begin
Lock := TIdCriticalSection.Create;
try
Add(Lock);
except
Lock.free;
raise ;
end;
end;
finally
CallbackLockList.UnlockList;
end;
end;
// Note that I define UCTTime as PASN1_STRING
function UTCTime2DateTime(UCTTime: PASN1_UTCTIME): TDateTime;
{$IFDEF USE_INLINE} inline; {$ENDIF}
var
year: Word;
month: Word;
day: Word;
hour: Word;
min: Word;
sec: Word;
tz_h: Integer;
tz_m: Integer;
begin
Result := 0;
if UTC_Time_Decode(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 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;
Result := RSA_generate_key(KeyLength, RSA_F4, @RSAProgressCallback, ssl);
end;
}
function LogicalAnd(A, B: Integer): Boolean;
{$IFDEF USE_INLINE} inline; {$ENDIF}
begin
Result := (A and B) = B;
end;
function BytesToHexString(APtr: Pointer; ALen: Integer): String;
{$IFDEF USE_INLINE} inline; {$ENDIF}
var
i: PtrInt;
LPtr: PByte;
begin
Result := '';
LPtr := PByte(APtr);
for i := 0 to (ALen - 1) do begin
if i <> 0 then begin
Result := Result + ':'; { Do not Localize }
end;
Result := Result + IndyFormat('%.2x', [LPtr^]);
Inc(LPtr);
end;
end;
function MDAsString(const AMD: TIdSSLEVP_MD): String;
{$IFDEF USE_INLINE} inline; {$ENDIF}
var
i: Integer;
begin
Result := '';
for i := 0 to AMD.Length - 1 do begin
if i <> 0 then begin
Result := Result + ':'; { Do not Localize }
end;
Result := Result + IndyFormat('%.2x', [Byte(AMD.MD[i])]);
{ do not localize }
end;
end;
procedure GetStateVars(const sslSocket: PSSL; AWhere, Aret: TIdC_INT; var VTypeStr, VMsg : String);
{$IFDEF USE_INLINE}inline;{$ENDIF}
begin
case AWhere of
SSL_CB_ALERT :
begin
VTypeStr := IndyFormat( RSOSSLAlert,[SSL_alert_type_string_long(Aret)]);
VMsg := String(SSL_alert_type_string_long(Aret));
end;
SSL_CB_READ_ALERT :
begin
VTypeStr := IndyFormat(RSOSSLReadAlert,[SSL_alert_type_string_long(Aret)]);
VMsg := String( SSL_alert_desc_string_long(Aret));
end;
SSL_CB_WRITE_ALERT :
begin
VTypeStr := IndyFormat(RSOSSLWriteAlert,[SSL_alert_type_string_long(Aret)]);
VMsg := String( SSL_alert_desc_string_long(Aret));
end;
SSL_CB_ACCEPT_LOOP :
begin
VTypeStr := RSOSSLAcceptLoop;
VMsg := String( SSL_state_string_long(sslSocket));
end;
SSL_CB_ACCEPT_EXIT :
begin
if ARet < 0 then begin
VTypeStr := RSOSSLAcceptError;
end else begin
if ARet = 0 then begin
VTypeStr := RSOSSLAcceptFailed;
end else begin
VTypeStr := RSOSSLAcceptExit;
end;
end;
VMsg := String( SSL_state_string_long(sslSocket) );
end;
SSL_CB_CONNECT_LOOP :
begin
VTypeStr := RSOSSLConnectLoop;
VMsg := String( SSL_state_string_long(sslSocket) );
end;
SSL_CB_CONNECT_EXIT :
begin
if ARet < 0 then begin
VTypeStr := RSOSSLConnectError;
end else begin
if ARet = 0 then begin
VTypeStr := RSOSSLConnectFailed
end else begin
VTypeStr := RSOSSLConnectExit;
end;
end;
VMsg := String( SSL_state_string_long(sslSocket) );
end;
SSL_CB_HANDSHAKE_START :
begin
VTypeStr := RSOSSLHandshakeStart;
VMsg := String( SSL_state_string_long(sslSocket) );
end;
SSL_CB_HANDSHAKE_DONE :
begin
VTypeStr := RSOSSLHandshakeDone;
VMsg := String( SSL_state_string_long(sslSocket) );
end;
end;
{var LW : TIdC_INT;
begin
VMsg := '';
LW := Awhere and (not SSL_ST_MASK);
if (LW and SSL_ST_CONNECT) > 0 then begin
VWhereStr := 'SSL_connect:';
end else begin
if (LW and SSL_ST_ACCEPT) > 0 then begin
VWhereStr := ' SSL_accept:';
end else begin
VWhereStr := ' undefined:';
end;
end;
// IdSslStateStringLong
if (Awhere and SSL_CB_LOOP) > 0 then begin
VMsg := IdSslStateStringLong(sslSocket);
end else begin
if (Awhere and SSL_CB_ALERT) > 0 then begin
if (Awhere and SSL_CB_READ > 0) then begin
VWhereStr := VWhereStr + ' read:'+ IdSslAlertTypeStringLong(Aret);
end else begin
VWhereStr := VWhereStr + 'write:'+ IdSslAlertTypeStringLong(Aret);
end;;
VMsg := IdSslAlertDescStringLong(Aret);
end else begin
if (Awhere and SSL_CB_EXIT) > 0 then begin
if ARet = 0 then begin
VWhereStr := VWhereStr +'failed';
VMsg := IdSslStateStringLong(sslSocket);
end else begin
if ARet < 0 then begin
VWhereStr := VWhereStr +'error';
VMsg := IdSslStateStringLong(sslSocket);
end;
end;
end;
end;
end; }
end;
initialization
Assert(SSLIsLoaded=nil);
SSLIsLoaded := TIdThreadSafeBoolean.Create;
finalization
UnLoadOpenSSLLibrary;
//free the lock last as unload makes calls that use it
FreeAndNil(SSLIsLoaded);
end.
Reference in New Issue View Git Blame Copy Permalink