{ +-------------------------------------------------------------+ } { | | } { | GM-Software | } { | =========== | } { | | } { | Project: All Projects | } { | | } { | Description: OpenSSL Transport Layer Stream. | } { | | } { | | } { | Copyright (C) - 2013 - Gerrit Moeller. | } { | | } { | Source code dstributed under MIT license. | } { | | } { | See: https://www.gm-software.de | } { | | } { +-------------------------------------------------------------+ } {$INCLUDE GMCompilerSettings.inc} unit GMOpenSSL; interface uses {$IFDEF JEDIAPI}{$IFNDEF FPC}jwaWinType,{$ENDIF}{$ENDIF} GMStrDef, GMCollections, GMIntf, GMCommon, GMSockets, GMOpenSSLApi; type EGMOpenSSLProtocolSite = (cpsClient, cpsServer, cpsBoth); EGMTlsProtocolVersion = (pvAuto, pvTLSv1, pvTLSv1_1, pvTLSv1_2); IGMOpenSslApiCtxPtr = interface(IUnknown) ['{7CDF1549-5FC0-43FC-A680-F26990B0F4B9}'] function ApiCtxPtr: Pointer; stdcall; end; IGMTlsProtocolVersionAndSite = interface(IUnknown) ['{CA2DB22D-CA7E-4E94-9584-8DC82379A53C}'] function GetProtocolVersion: EGMTlsProtocolVersion; function GetProtocolSite: EGMOpenSSLProtocolSite; property ProtocolVersion: EGMTlsProtocolVersion read GetProtocolVersion; property ProtocolSite: EGMOpenSSLProtocolSite read GetProtocolSite; end; // // Used for lookup // TGMOpenSslContextBase = class(TGMRefCountedObj, IGMTlsProtocolVersionAndSite) protected FProtocolVersion: EGMTlsProtocolVersion; FProtocolSite: EGMOpenSSLProtocolSite; public constructor Create(const AProtocolVersion: EGMTlsProtocolVersion = pvAuto; const AProtocolSite: EGMOpenSSLProtocolSite = cpsBoth; const ARefLifeTime: Boolean = True); reintroduce; overload; virtual; function GetProtocolVersion: EGMTlsProtocolVersion; function GetProtocolSite: EGMOpenSSLProtocolSite; end; TGMOpenSslContext = class(TGMOpenSslContextBase, IGMOpenSslApiCtxPtr) protected FSslCtx: PSSL_CTX; public // constructor Create(const AProtocolVersion: EGMTlsProtocolVersion = pvAuto; const AProtocolSite: EGMOpenSSLProtocolSite = cpsBoth; const ARefLifeTime: Boolean = True); override; destructor Destroy; override; function ApiCtxPtr: Pointer; stdcall; end; IGMShowCertificateVerifyStatus = interface(IUnknown) ['{40E5752A-E010-4B54-BE12-C00679AB6745}'] procedure ShowCertificateVerifyStatus(const AHost: TGMString; const ACertCode: Int64); end; IGMTlsSocket = interface(IGMOpenSslApiCtxPtr) ['{21D4912C-B9FA-47C9-BD47-4792FE285BDE}'] procedure ExecTlsNegotiation; stdcall; procedure Initialize; stdcall; function Initialized: Boolean; stdcall; // procedure CopySession(const ASrcTlsSocket: IUnknown); end; TGMOpenSslSocketBase = class(TGMRefCountedObj, IGMSocketIO, IGMOpenSslApiCtxPtr) protected FTransportSocket: IGMSocket; FCertificateData: AnsiString; FSsl: PSSL; FProtocolVersion: EGMTlsProtocolVersion; FCheckNonBlockingErrorCode: IGMCheckNonBlockingErrorCode; function CheckIORetCode(const ARetCode: LongInt; const ASSLRoutineName: TGMString; const ARaiseIfShutdown: Boolean = False): LongInt; public function SendData(const AData: Pointer; const ADataSize: LongInt): LongInt; stdcall; function ReceiveData(const AData: Pointer; const ADataSize: LongInt): LongInt; stdcall; // function IsDataAvailable: Boolean; stdcall; function ApiCtxPtr: Pointer; stdcall; end; TGMOpenSslClientSocket = class(TGMOpenSslSocketBase, IGMTlsSocket) protected FCertificateNotifySink: IGMShowCertificateVerifyStatus; FNegotiated: Boolean; FTargetHostName: AnsiString; // procedure DisplayCertifaceVerifyStatus; procedure NotifyCertifateVerifyStatus; public constructor Create(const ATransportSocket: IGMSocket; const ATargetHostName: TGMString; const ACertificateStatusNotifySink: IUnknown = nil; const ACertificateData: AnsiString = ''; const AProtocolVersion: EGMTlsProtocolVersion = pvAuto; const ARefLifeTime: Boolean = True); reintroduce; destructor Destroy; override; // procedure CopySession(const ASrcSocket: IUnknown); procedure ShutDown; procedure Initialize; stdcall; function Initialized: Boolean; stdcall; procedure ExecTlsNegotiation; stdcall; end; TGMOpenSslCertStore = class(TGMRefCountedObj, IGMAssignToObj) protected FCertStore: PX509_STORE; public constructor Create(const ARefLifeTime: Boolean = True); override; constructor CreateFromWinCerts(const AWinCertStoreFolderPaths: TGMStringArray; const ARefLifeTime: Boolean = True); destructor Destroy; override; procedure LoadFromWinCerts(const AWinCertStoreFolderPath: TGMString); procedure AssignToObj(const ADest: TObject); stdcall; end; // // Use an seprate object to avoid circular refernces to object containing the sockets // TGMCertMessageEmitter = class(TGMRefCountedObj, IGMShowCertificateVerifyStatus) protected FAppendText: IGMAppendText; FCertMessagesShown: IGMIntfCollection; public constructor Create(const AUnkProtocol: IUnknown; const ARefLifeTime: Boolean = True); reintroduce; procedure ShowCertificateVerifyStatus(const AHost: TGMString; const ACertCode: Int64); end; EGMTlsException = class(EGMException); EGMTlsConnectionShutdown = class(EGMTlsException, IGMGetHRCode) public function GetHRCode: HResult; stdcall; end; procedure GMExecTlsNegotiation(const ATransportLayer: IUnknown); function GMAddTlsLayer(const ATransportLayer: IGMSocket; const ATargetHostName: TGMString; const ACertificateStatusNotifySink: IUnknown = nil; const ACertificateData: AnsiString = ''; const AProtocolVersion: EGMTlsProtocolVersion = pvAuto; const AExecuteTlsNegoatiation: Boolean = True): IGMSocketIO; procedure GMCopyTlsSession(const ASrcTlsSocket, ADstTlsSocket: IUnknown; const ACaller: TObject = nil); //procedure EmitCertificateVerifyStatus(const AProtokolUnk: IUnknown; const ACertCode: Int64); implementation uses GMSocketAPI {$IFDEF JEDIAPI},jwaWinBase, jwaWinCrypt{$ENDIF}; resourcestring RStrUnknownSSLError = 'Unknown SSL Error'; RStrInvalidSSLPtotocolVersion = 'Invalid SSL/TLS protocol version: %d'; RStrInvalidSSLPtotocolSite = 'Invalid SSL/TLS protocol site: %d'; RStrCleanlyShutdown = 'The SSL/TLS connection has been shut down cleanly'; RStrNoServerCertificate = 'The server did not send a certificate'; RStrAnonymousDiffieHellman = 'Anonymous Diffie-Hellman (ADH)'; RStrUnknownCertificateErrCode = 'Unknown server certificate validation error code: %d'; //X509_V_OK = 0; //X509_V_ILLEGAL = 1; RStrX509_V_ERR_UNABLE_TO_GET_ISSUER_CERT = 'The issuer certificate could not be found: this occurs if the issuer certificate of an untrusted certificate cannot be found'; RStrX509_V_ERR_UNABLE_TO_GET_CRL = 'The certificate revocation list of a certificate could not be found'; RStrX509_V_ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE = 'Unable to decrypt certificate''s signature'; RStrX509_V_ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE = 'Unable to decrypt the signature of the certifacte revocation list'; RStrX509_V_ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY = 'Unable to decode issuer public key'; RStrX509_V_ERR_CERT_SIGNATURE_FAILURE = 'The signature of the certificate is invalid'; RStrX509_V_ERR_CRL_SIGNATURE_FAILURE = 'The signature of the certificate revocation list is invalid'; RStrX509_V_ERR_CERT_NOT_YET_VALID = 'The certificate is not yet valid'; RStrX509_V_ERR_CERT_HAS_EXPIRED = 'The certificate has expired'; RStrX509_V_ERR_CRL_NOT_YET_VALID = 'The certificate revocation list is not yet valid'; RStrX509_V_ERR_CRL_HAS_EXPIRED = 'The certificate revocation list has expired'; RStrX509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD = 'The "notBefore" field of the certificate contains an invalid time value'; RStrX509_V_ERR_ERROR_IN_CERT_NOT_AFTER_FIELD = 'The "notAfter" field of the certificate contains an invalid time value'; RStrX509_V_ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD = 'The "lastUpdate" field of the certificate revocation list contains an invalid time value'; RStrX509_V_ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD = 'The "nextUpdate" field of the certificate revocation list contains an invalid time value'; RStrX509_V_ERR_OUT_OF_MEM = 'Out of memory'; RStrX509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT = 'The passed certificate is self signed and the same certificate cannot be found in the list of trusted certificates'; RStrX509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN = 'The certificate chain could be built up using the untrusted certificates but the root could not be found locally'; RStrX509_V_ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY = 'The issuer certificate of a locally looked up certificate could not be found. This normally means the list of trusted certificates is not complete'; RStrX509_V_ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE = 'No signatures could be verified because the chain contains only one certificate and it is not self signed'; RStrX509_V_ERR_CERT_CHAIN_TOO_LONG = 'Certificate chain too long'; RStrX509_V_ERR_CERT_REVOKED = 'The certificate has been revoked'; RStrX509_V_ERR_INVALID_CA = 'Invalid authority certificate'; RStrX509_V_ERR_PATH_LENGTH_EXCEEDED = 'The "basicConstraints" pathlength parameter has been exceeded'; RStrX509_V_ERR_INVALID_PURPOSE = 'The supplied certificate cannot be used for the specified purpose'; RStrX509_V_ERR_CERT_UNTRUSTED = 'The root authority is not marked as trusted for the specified purpose'; RStrX509_V_ERR_CERT_REJECTED = 'The root authority is marked to reject the specified purpose'; //These are 'informational' when looking for issuer cert RStrX509_V_ERR_SUBJECT_ISSUER_MISMATCH = 'The current candidate issuer certificate was rejected because its subject name did not match the issuer name of the current certificate'; RStrX509_V_ERR_AKID_SKID_MISMATCH = 'The current candidate issuer certificate was rejected because its subject key identifier was present and did not match the authority key identifier current certificate'; RStrX509_V_ERR_AKID_ISSUER_SERIAL_MISMATCH = 'the current candidate issuer certificate was rejected because its issuer name and serial number was present and did not match the authority key identifier of the current certificate'; RStrX509_V_ERR_KEYUSAGE_NO_CERTSIGN = 'The current candidate issuer certificate was rejected because its keyUsage extension does not permit certificate signing'; RStrX509_V_ERR_UNABLE_TO_GET_CRL_ISSUER = 'Unable to get certificate revocation list issuer'; RStrX509_V_ERR_UNHANDLED_CRITICAL_EXTENSION = 'Unhandeled critical extension'; //The application is not happy RStrX509_V_ERR_APPLICATION_VERIFICATION = 'Application verification failure'; RStrSSLVeriyPrefix = 'SSL/TLS certificate verification'; RStrCertiVerifyOK = 'The server certificate is valid'; RStrForHostFmt = 'for host %s'; RStrOpenSSLRoutineFailedFmt = 'OpenSSL routine "%s" failed'; RStrExecutingTLSNegotiation = 'Executing SSL/TLS negotiation'; const cNoServerCert = -1; var vCSSslContext: IGMCriticalSection = nil; vCSSslCertStore: IGMCriticalSection = nil; vGMTlsContexts: IGMIntfCollection = nil; vGMOpenSSLCertStore: IGMAssignToObj = nil; { ------------------------- } { ---- Global Routines ---- } { ------------------------- } function OpenSSLErrorString(const AErrorCode: LongWord): AnsiString; begin SetLength(Result, 2048); ERR_error_string_n(AErrorCode, PAnsiChar(Result), Length(Result)+1); Result := PAnsiChar(Result); end; procedure GMSslCheck(const ASuccess: Boolean; const ACaller: TObject; const ACallingName: TGMString; const APrefix: TGMString = ''); var errorCode: LongWord; errorMsg, stateStr: AnsiString; begin if ASuccess then Exit; errorMsg := ''; repeat errorCode := ERR_get_error; if errorCode <> 0 then errorMsg := GMStringJoin(errorMsg, cNewLine, GMStringJoin('('+GMIntToStr(errorCode)+')', ' ', OpenSSLErrorString(errorCode))); until errorCode = 0; // ErrClearError; if Length(errorMsg) <= 0 then errorMsg := RStrUnknownSSLError; errorMsg := GMStringJoin(APrefix, ': ', errorMsg); if ACaller is TGMOpenSslSocketBase then begin stateStr := SSL_state_string_long(TGMOpenSslSocketBase(ACaller).FSsl); if Length(stateStr) > 0 then stateStr := 'SSL State: ' + stateStr; errorMsg := GMStringJoin(errorMsg, cNewLine, stateStr); end; raise EGMTlsException.ObjError(errorMsg, ACaller, ACallingName); end; procedure GMOpenSSLRoutineFailed(ARoutineName: TGMString; const ACaller: TObject = nil; const ACallingName: AnsiString = ''); begin ARoutineName := GMStrip(ARoutineName); if (Length(ARoutineName) > 0) and (ARoutineName[Length(ARoutineName)] <> ')') then ARoutineName := ARoutineName + '(...)'; raise EGMTlsException.ObjError(GMFormat(RStrOpenSSLRoutineFailedFmt, [ARoutineName]), ACaller, ACallingName); end; function GMCertValidateMsgFromCode(const ACertVerifyCode: Int64): TGMSTring; begin case ACertVerifyCode of // X509_V_ILLEGAL = 1; cNoServerCert: Result := RStrNoServerCertificate + ' (' + RStrAnonymousDiffieHellman + ')'; X509_V_OK: Result := RStrCertiVerifyOK; X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT: Result := RStrX509_V_ERR_UNABLE_TO_GET_ISSUER_CERT; X509_V_ERR_UNABLE_TO_GET_CRL: Result := RStrX509_V_ERR_UNABLE_TO_GET_CRL; X509_V_ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE: Result := RStrX509_V_ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE; X509_V_ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE: Result := RStrX509_V_ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE; X509_V_ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY: Result := RStrX509_V_ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY; X509_V_ERR_CERT_SIGNATURE_FAILURE: Result := RStrX509_V_ERR_CERT_SIGNATURE_FAILURE; X509_V_ERR_CRL_SIGNATURE_FAILURE: Result := RStrX509_V_ERR_CRL_SIGNATURE_FAILURE; X509_V_ERR_CERT_NOT_YET_VALID: Result := RStrX509_V_ERR_CERT_NOT_YET_VALID; X509_V_ERR_CERT_HAS_EXPIRED: Result := RStrX509_V_ERR_CERT_HAS_EXPIRED; X509_V_ERR_CRL_NOT_YET_VALID: Result := RStrX509_V_ERR_CRL_NOT_YET_VALID; X509_V_ERR_CRL_HAS_EXPIRED: Result := RStrX509_V_ERR_CRL_HAS_EXPIRED; X509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD: Result := RStrX509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD; X509_V_ERR_ERROR_IN_CERT_NOT_AFTER_FIELD: Result := RStrX509_V_ERR_ERROR_IN_CERT_NOT_AFTER_FIELD; X509_V_ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD: Result := RStrX509_V_ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD; X509_V_ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD: Result := RStrX509_V_ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD; X509_V_ERR_OUT_OF_MEM: Result := RStrX509_V_ERR_OUT_OF_MEM; X509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT: Result := RStrX509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT; X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN: Result := RStrX509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN; X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY: Result := RStrX509_V_ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY; X509_V_ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE: Result := RStrX509_V_ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE; X509_V_ERR_CERT_CHAIN_TOO_LONG: Result := RStrX509_V_ERR_CERT_CHAIN_TOO_LONG; X509_V_ERR_CERT_REVOKED: Result := RStrX509_V_ERR_CERT_REVOKED; X509_V_ERR_INVALID_CA: Result := RStrX509_V_ERR_INVALID_CA; X509_V_ERR_PATH_LENGTH_EXCEEDED: Result := RStrX509_V_ERR_PATH_LENGTH_EXCEEDED; X509_V_ERR_INVALID_PURPOSE: Result := RStrX509_V_ERR_INVALID_PURPOSE; X509_V_ERR_CERT_UNTRUSTED: Result := RStrX509_V_ERR_CERT_UNTRUSTED; X509_V_ERR_CERT_REJECTED: Result := RStrX509_V_ERR_CERT_REJECTED; //These are 'informational' when looking for issuer cert X509_V_ERR_SUBJECT_ISSUER_MISMATCH: Result := RStrX509_V_ERR_SUBJECT_ISSUER_MISMATCH; X509_V_ERR_AKID_SKID_MISMATCH: Result := RStrX509_V_ERR_AKID_SKID_MISMATCH; X509_V_ERR_AKID_ISSUER_SERIAL_MISMATCH: Result := RStrX509_V_ERR_AKID_ISSUER_SERIAL_MISMATCH; X509_V_ERR_KEYUSAGE_NO_CERTSIGN: Result := RStrX509_V_ERR_KEYUSAGE_NO_CERTSIGN; X509_V_ERR_UNABLE_TO_GET_CRL_ISSUER: Result := RStrX509_V_ERR_UNABLE_TO_GET_CRL_ISSUER; X509_V_ERR_UNHANDLED_CRITICAL_EXTENSION: Result := RStrX509_V_ERR_UNHANDLED_CRITICAL_EXTENSION; //The application is not happy X509_V_ERR_APPLICATION_VERIFICATION: Result := RStrX509_V_ERR_APPLICATION_VERIFICATION; else Result := GMFormat(RStrUnknownCertificateErrCode, [ACertVerifyCode]); end; end; procedure GMExecTlsNegotiation(const ATransportLayer: IUnknown); var tlsSocket: IGMTlsSocket; begin GMCheckQueryInterface(ATransportLayer, IGMTlsSocket, tlsSocket); tlsSocket.ExecTlsNegotiation; end; function GMAddTlsLayer(const ATransportLayer: IGMSocket; const ATargetHostName: TGMString; const ACertificateStatusNotifySink: IUnknown; const ACertificateData: AnsiString; const AProtocolVersion: EGMTlsProtocolVersion; const AExecuteTlsNegoatiation: Boolean): IGMSocketIO; begin if ATransportLayer = nil then Exit(nil); Result := TGMOpenSslClientSocket.Create(ATransportLayer, ATargetHostName, ACertificateStatusNotifySink, ACertificateData, AProtocolVersion); if AExecuteTlsNegoatiation then GMExecTlsNegotiation(Result); end; procedure GMCopyTlsSession(const ASrcTlsSocket, ADstTlsSocket: IUnknown; const ACaller: TObject); var srcTls, dstTls: IGMTlsSocket; session: Pointer; begin if GMQueryInterface(ASrcTlsSocket, IGMTlsSocket, srcTls) and srcTls.Initialized and GMQueryInterface(ADstTlsSocket, IGMTlsSocket, dstTls) then begin dstTls.Initialize; session := SSL_get_session(srcTls.ApiCtxPtr); if session <> nil then GMSslCheck(SSL_set_session(dstTls.ApiCtxPtr, session) <> 0, ACaller, 'SSL_set_session'); // SSLCopySessionId(FSsl, ApiCtxPtr.ApiCtxPtr); end; end; function GMOpenSSLCertStore: IGMAssignToObj; begin vCSSslCertStore.EnterCriticalSection; try if vGMOpenSSLCertStore = nil then vGMOpenSSLCertStore := TGMOpenSslCertStore.CreateFromWinCerts(['ROOT', 'CA', 'AuthRoot', 'MY']); Result := vGMOpenSSLCertStore; finally vCSSslCertStore.LeaveCriticalSection; end; end; function GMTlsContext(const AProtocolVersion: EGMTlsProtocolVersion; const AProtocolSite: EGMOpenSSLProtocolSite): IGMOpenSslApiCtxPtr; var toFind, unkFound: IUnknown; // syncLock: IUnknown; begin //syncLock := TGMCriticalSectionLock.Create(vCSSslContext); vCSSslContext.EnterCriticalSection; try toFind := TGMOpenSslContextBase.Create(AProtocolVersion, AProtocolSite); if not vGMTlsContexts.Find(toFind, unkFound) then begin unkFound := vGMTlsContexts.Add(TGMOpenSslContext.Create(AProtocolVersion, AProtocolSite, True)); GMOpenSSLCertStore.AssignToObj(GMObjFromIntf(unkFound)); end; GMCheckQueryInterface(unkFound, IGMOpenSslApiCtxPtr, Result); finally vCSSslContext.LeaveCriticalSection; end; end; function GMCompareTlsContext(const ItemA, ItemB: IUnknown): TGMCompareResult; var ctxA, ctxB: IGMTlsProtocolVersionAndSite; begin GMCheckQueryInterface(ItemA, IGMTlsProtocolVersionAndSite, ctxA, {$I %CurrentRoutine%}); GMCheckQueryInterface(ItemB, IGMTlsProtocolVersionAndSite, ctxB, {$I %CurrentRoutine%}); if ctxA.ProtocolVersion > ctxB.ProtocolVersion then Result := crAGreaterThanB else if ctxA.ProtocolVersion = ctxB.ProtocolVersion then Result := crAEqualToB else Result := crALessThanB; if Result = crAEqualToB then begin if ctxA.ProtocolSite > ctxB.ProtocolSite then Result := crAGreaterThanB else if ctxA.ProtocolSite = ctxB.ProtocolSite then Result := crAEqualToB else Result := crALessThanB; end; end; function SSLSybolicErrorName(const AErrorCode: LongInt) : TGMString; begin case AErrorCode of SSL_ERROR_NONE: Result := 'SSL_ERROR_NONE'; SSL_ERROR_SSL: Result := 'SSL_ERROR_SSL'; SSL_ERROR_WANT_READ: Result := 'SSL_ERROR_WANT_READ'; SSL_ERROR_WANT_WRITE: Result := 'SSL_ERROR_WANT_WRITE'; SSL_ERROR_WANT_X509_LOOKUP: Result := 'SSL_ERROR_WANT_X509_LOOKUP'; SSL_ERROR_SYSCALL: Result := 'SSL_ERROR_SYSCALL'; //look at error stack/return value/errno SSL_ERROR_ZERO_RETURN: Result := 'SSL_ERROR_ZERO_RETURN'; SSL_ERROR_WANT_CONNECT: Result := 'SSL_ERROR_WANT_CONNECT'; SSL_ERROR_WANT_ACCEPT: Result := 'SSL_ERROR_WANT_ACCEPT'; SSL_ERROR_WANT_ASYNC: Result := 'SSL_ERROR_WANT_ASYNC'; SSL_ERROR_WANT_ASYNC_JOB: Result := 'SSL_ERROR_WANT_ASYNC_JOB'; SSL_ERROR_WANT_CLIENT_HELLO_CB: Result := 'SSL_ERROR_WANT_CLIENT_HELLO_CB'; else Result := 'SSL error code ('+GMIntToStr(AErrorCode)+')'; end; end; //procedure EmitCertificateVerifyStatus(const AProtokolUnk: IUnknown; const ACertCode: Int64); //const clrOrange = $0080FF; cGreen = $008000; //var rprtText: IGMAppendText; msg: TGMString; //begin //if GMQueryInterface(AProtokolUnk, IGMAppendText ,rprtText) then // begin // msg := GMTerminateStr(GMCertValidateMsgFromCode(ACertCode)); // case ACertCode of // 0: rprtText.AppendText(' '+RStrSSLVeriyPrefix+': '+msg, cGreen, True) // else rprtText.AppendText(' '+RStrSSLVeriyPrefix+' '+GMSeverityName(svWarning)+': '+msg, clrOrange, True); // end; // end; //end; { ---------------------------------- } { ---- EGMTlsConnectionShutdown ---- } { ---------------------------------- } function EGMTlsConnectionShutdown.GetHRCode: HResult; begin Result := GMSocketHrResult(WSAECONNABORTED); end; { ----------------------------- } { ---- TGMOpenSslCertStore ---- } { ----------------------------- } constructor TGMOpenSslCertStore.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FCertStore := X509_STORE_new; if FCertStore = nil then GMOpenSSLRoutineFailed('X509_STORE_new', Self); //GMSslCheck(FStore <> nil, Self, 'X509_STORE_new'); end; constructor TGMOpenSslCertStore.CreateFromWinCerts(const AWinCertStoreFolderPaths: TGMStringArray; const ARefLifeTime: Boolean); var certPath: TGMString; begin Create(ARefLifeTime); for certPath in AWinCertStoreFolderPaths do LoadFromWinCerts(certPath); //LoadFromWinCerts(AWinCertStoreFolderPaths); end; destructor TGMOpenSslCertStore.Destroy; begin if FCertStore <> nil then begin X509_STORE_free(FCertStore); FCertStore := nil; end; inherited; end; procedure TGMOpenSslCertStore.LoadFromWinCerts(const AWinCertStoreFolderPath: TGMString); // https://stackoverflow.com/questions/39772878/reliable-way-to-get-root-ca-certificates-on-windows/40710806#40710806 // //#include <boost/asio/ssl/context.hpp> //#include <wincrypt.h> // //void add_windows_root_certs(boost::asio::ssl::context &ctx) //{ // HCERTSTORE hStore = CertOpenSystemStore(0, "ROOT"); // if (hStore == NULL) { // return; // } // // X509_STORE *store = X509_STORE_new(); // PCCERT_CONTEXT pContext = NULL; // while ((pContext = CertEnumCertificatesInStore(hStore, pContext)) != NULL) { // X509 *x509 = d2i_X509(NULL, // (const unsigned char **)&pContext->pbCertEncoded, // pContext->cbCertEncoded); // if(x509 != NULL) { // X509_STORE_add_cert(store, x509); // X509_free(x509); // } // } // // CertFreeCertificateContext(pContext); // CertCloseStore(hStore, 0); // // SSL_CTX_set_cert_store(ctx.native_handle(), store); //} var winCertStore: HCERTSTORE; pWinCertCtx: PCCERT_CONTEXT; p_x509: PX509; n: Integer; begin if Length(AWinCertStoreFolderPath) <= 0 then Exit; winCertStore := CertOpenSystemStore(0, PGMChar(AWinCertStoreFolderPath)); GMApiCheckObj('CertOpenSystemStore("'+AWinCertStoreFolderPath+'")', '', GetLastError, winCertStore <> nil, Self); try pWinCertCtx := nil; n := 0; try repeat pWinCertCtx := CertEnumCertificatesInStore(winCertStore, pWinCertCtx); if pWinCertCtx = nil then Break; p_x509 := d2i_X509(nil, @pWinCertCtx.pbCertEncoded, pWinCertCtx.cbCertEncoded); if p_x509 <> nil then begin X509_STORE_add_cert(FCertStore, p_x509); X509_free(p_x509); Inc(n); end; until False; finally if pWinCertCtx <> nil then CertFreeCertificateContext(pWinCertCtx); end; finally CertCloseStore(winCertStore, 0); vfGMTrace(GMIntToStr(n) + ' Certificates in "'+AWinCertStoreFolderPath+'"', 'CERTIFICATE'); end; end; procedure TGMOpenSslCertStore.AssignToObj(const ADest: TObject); begin if ADest is TGMOpenSslContext then begin // SSL_CTX_set1_cert_store(TGMOpenSslContext(ADest).ApiCtxPtr, FCertStore); <- not in DLL file .. SSL_CTX_set_cert_store(TGMOpenSslContext(ADest).ApiCtxPtr, FCertStore); X509_STORE_up_ref(FCertStore); end; end; { ------------------------------- } { ---- TGMCertMessageEmitter ---- } { ------------------------------- } constructor TGMCertMessageEmitter.Create(const AUnkProtocol: IUnknown; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); GMQueryInterface(AUnkProtocol, IGMAppendText, FAppendText); end; procedure TGMCertMessageEmitter.ShowCertificateVerifyStatus(const AHost: TGMString; const ACertCode: Int64); var nameObj: IUnknown; procedure EmitCertMsg; const clrOrange = $0080FF; cGreen = $008000; var msg, hostPart: TGMString; begin if FAppendText = nil then Exit; msg := GMTerminateStr(GMCertValidateMsgFromCode(ACertCode)); hostPart := ' ' + GMFormat(RStrForHostFmt, [AHost]); case ACertCode of 0: FAppendText.AppendText(' '+RStrSSLVeriyPrefix+hostPart+': '+msg, cGreen, True) else FAppendText.AppendText(' '+RStrSSLVeriyPrefix+' '+GMSeverityName(svWarning)+hostPart+': '+msg, clrOrange, True); end; end; begin if FAppendText = nil then Exit; if FCertMessagesShown = nil then FCertMessagesShown := TGMIntfArrayCollection.Create(False, True, GMCompareByName); nameObj := TGMNameObj.Create(GMIntToStr(ACertCode) + '-' + AHost); if not GMCollectionContains(FCertMessagesShown, nameObj) then begin EmitCertMsg; FCertMessagesShown.Add(nameObj); end; end; { ------------------------------- } { ---- TGMOpenSslContextBase ---- } { ------------------------------- } constructor TGMOpenSslContextBase.Create(const AProtocolVersion: EGMTlsProtocolVersion; const AProtocolSite: EGMOpenSSLProtocolSite; const ARefLifeTime: Boolean); begin Create(ARefLifeTime); FProtocolVersion := AProtocolVersion; FProtocolSite := AProtocolSite; end; function TGMOpenSslContextBase.GetProtocolVersion: EGMTlsProtocolVersion; begin Result := FProtocolVersion; end; function TGMOpenSslContextBase.GetProtocolSite: EGMOpenSSLProtocolSite; begin Result := FProtocolSite; end; { --------------------------- } { ---- TGMOpenSslContext ---- } { --------------------------- } constructor TGMOpenSslContext.Create(const AProtocolVersion: EGMTlsProtocolVersion; const AProtocolSite: EGMOpenSSLProtocolSite; const ARefLifeTime: Boolean); //var retVal: Int64; options: QWord; begin inherited Create(AProtocolVersion, AProtocolSite, ARefLifeTime); case AProtocolSite of cpsClient: case AProtocolVersion of pvTLSv1: FSslCtx := SSL_CTX_new(TLSv1_client_method); pvTLSv1_1: FSslCtx := SSL_CTX_new(TLSv1_1_client_method); pvTLSv1_2: FSslCtx := SSL_CTX_new(TLSv1_2_client_method); pvAuto: FSslCtx := SSL_CTX_new(TLS_client_method); else raise EGMTlsException.ObjError(GMFormat(RStrInvalidSSLPtotocolVersion, [Ord(FProtocolVersion)]), Self, {$I %CurrentRoutine%}); end; cpsServer: case AProtocolVersion of pvTLSv1: FSslCtx := SSL_CTX_new(TLSv1_server_method); pvTLSv1_1: FSslCtx := SSL_CTX_new(TLSv1_1_server_method); pvTLSv1_2: FSslCtx := SSL_CTX_new(TLSv1_2_server_method); pvAuto: FSslCtx := SSL_CTX_new(TLS_server_method); else raise EGMTlsException.ObjError(GMFormat(RStrInvalidSSLPtotocolVersion, [Ord(FProtocolVersion)]), Self, {$I %CurrentRoutine%}); end; cpsBoth: case AProtocolVersion of pvTLSv1: FSslCtx := SSL_CTX_new(TLSv1_method); pvTLSv1_1: FSslCtx := SSL_CTX_new(TLSv1_1_method); pvTLSv1_2: FSslCtx := SSL_CTX_new(TLSv1_2_method); pvAuto: FSslCtx := SSL_CTX_new(TLS_method); else raise EGMTlsException.ObjError(GMFormat(RStrInvalidSSLPtotocolVersion, [Ord(FProtocolVersion)]), Self, {$I %CurrentRoutine%}); end; else raise EGMTlsException.ObjError(GMFormat(RStrInvalidSSLPtotocolSite, [Ord(AProtocolSite)]), Self, {$I %CurrentRoutine%}); end; GMSslCheck(FSslCtx <> nil, Self, 'TlsMethod_Xxx'); SSL_CTX_set_verify(FSslCtx, SSL_VERIFY_NONE, nil); //options := SSL_CTX_set_options(FSslCtx, SSL_OP_ALLOW_CLIENT_RENEGOTIATION); //options := SSL_CTX_set_options(FSslCtx, SSL_OP_NO_SSLv3 or SSL_OP_NO_TLSv1 or SSL_OP_NO_TLSv1_1); // SSL_OP_NO_TLSv1_1 //options := 0; //retVal := SSL_CTX_ctrl(FSslCtx, SSL_CTRL_SET_MIN_PROTO_VERSION, TLS1_3_VERSION, nil); //retVal := 0; end; destructor TGMOpenSslContext.Destroy; begin if FSslCtx <> nil then begin SSL_CTX_free(FSslCtx); FSslCtx := nil; ERR_remove_thread_state(nil); end; // ERR_remove_state(0); inherited; end; function TGMOpenSslContext.ApiCtxPtr: Pointer; begin Result := FSslCtx; end; { ------------------------------ } { ---- TGMOpenSslSocketBase ---- } { ------------------------------ } function TGMOpenSslSocketBase.ApiCtxPtr: Pointer; begin Result := FSsl; end; function TGMOpenSslSocketBase.CheckIORetCode(const ARetCode: LongInt; const ASSLRoutineName: TGMString; const ARaiseIfShutdown: Boolean): LongInt; var errCode: LongInt; procedure CheckNonBlockingErrorCode(const AIOErrorCode: LongInt; const AOperation: TSockOperation; const ASuccesCodes: array of PtrInt; const ASocketAPIRoutineName: TGMString); begin if FCheckNonBlockingErrorCode = nil then GMCheckQueryInterface(FTransportSocket, IGMCheckNonBlockingErrorCode, FCheckNonBlockingErrorCode, {$I %CurrentRoutine%}); FCheckNonBlockingErrorCode.CheckNonBlockingErrorCode(AIOErrorCode, AOperation, ASuccesCodes, ASocketAPIRoutineName); end; begin Result := ARetCode; if Result <= 0 then begin errCode := SSL_get_error(FSsl, ARetCode); case errCode of // SSL_ERROR_WANT_CONNECT SSL_ERROR_NONE: ; // <- nothing (success), only possible if ARetCode > 0 SSL_ERROR_WANT_READ: CheckNonBlockingErrorCode(WSAEWOULDBLOCK, ioReceive, [], ASSLRoutineName); SSL_ERROR_WANT_WRITE: CheckNonBlockingErrorCode(WSAEWOULDBLOCK, ioSend, [], ASSLRoutineName); // SSL_ERROR_WANT_ACCEPT: FTransportSocket.Obj.CheckNonBlockingErrorCode(WSAEWOULDBLOCK, ioAccept, [], ASSLRoutineName); SSL_ERROR_ZERO_RETURN: if not ARaiseIfShutdown then Result := 0 else raise EGMTlsConnectionShutdown.ObjError(GMStringJoin(SSLSybolicErrorName(errCode), ': ', RStrCleanlyShutdown), Self, {$I %CurrentRoutine%}); //SSL_ERROR_SYSCALL, SSL_ERROR_SSL: GMSslCheck(False, Self, ASSLRoutineName); // <- SSL_ERROR_SYSCALL, SSL_ERROR_SSL else GMSslCheck(False, Self, ASSLRoutineName, SSLSybolicErrorName(errCode)); end; end; end; //function TGMOpenSslSocketBase.IsDataAvailable: Boolean; //begin //Result := (FTransportSocket <> nil) and FTransportSocket.IsDataAvailable; //end; function TGMOpenSslSocketBase.ReceiveData(const AData: Pointer; const ADataSize: LongInt): LongInt; begin repeat Result := CheckIORetCode(SSL_read(FSsl, AData, ADataSize), 'SSL_read'); until Result >= 0; end; function TGMOpenSslSocketBase.SendData(const AData: Pointer; const ADataSize: LongInt): LongInt; begin repeat Result := CheckIORetCode(SSL_write(FSsl, AData, ADataSize), 'SSL_write'); until Result >= 0; end; { -------------------------------- } { ---- TGMOpenSslClientSocket ---- } { -------------------------------- } constructor TGMOpenSslClientSocket.Create(const ATransportSocket: IGMSocket; const ATargetHostName: TGMString; const ACertificateStatusNotifySink: IUnknown; const ACertificateData: AnsiString; const AProtocolVersion: EGMTlsProtocolVersion; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FTransportSocket := ATransportSocket; FProtocolVersion := AProtocolVersion; GMQueryInterface(ACertificateStatusNotifySink, IGMShowCertificateVerifyStatus, FCertificateNotifySink); FCertificateData := ACertificateData; FTargetHostName := ATargetHostName; //ExecTlsNegotiation; end; destructor TGMOpenSslClientSocket.Destroy; begin try ShutDown; except on ex: TObject do GMTraceException(ex); end; if FSsl <> nil then begin SSL_free(FSsl); FSsl := nil; end; inherited; end; procedure TGMOpenSslClientSocket.ShutDown; var retVal: LongInt; begin if not FNegotiated then Exit; repeat retVal := SSL_shutdown(FSsl); if retVal < 0 then CheckIORetCode(retVal, 'SSL_shutdown'); until retVal >= 0; FNegotiated := False; end; procedure TGMOpenSslClientSocket.Initialize; // // The creation of the Context may take some time, so better dont do this directly in the constructor. // var tlsCtx: IGMOpenSslApiCtxPtr; retVal: Int64; // options: QWord; function IsLetter(ACh: AnsiChar): Boolean; begin Result := ((ACh >= 'A') and (ACh <= 'Z')) or ((ACh >= 'a') and (ACh <= 'z')); end; function IsFileName(const AValue: AnsiString): Boolean; begin Result := (Length(AValue) > 2) and IsLetter(AValue[1]) and (AValue[2] = ':') and (AValue[3] = '\'); end; begin if FSsl <> nil then Exit; tlsCtx := GMTlsContext(FProtocolVersion, cpsClient); FSsl := SSL_new(tlsCtx.ApiCtxPtr); GMSslCheck(FSsl <> nil, Self, 'SSL_new'); //GMSslCheck(SSL_ctrl(FSsl, SSL_CTRL_SET_MIN_PROTO_VERSION, TLS1_2_VERSION, nil) = 1, Self, 'SSL_CTRL_SET_MIN_PROTO_VERSION'); //options := SSL_set_options(FSsl, SSL_OP_NO_SSLv3 or SSL_OP_NO_TLSv1 or SSL_OP_NO_TLSv1_1); // SSL_OP_NO_TLSv1_1 //SSL_set_options(FSsl, ); if Length(FTargetHostName) > 0 then begin retVal := SSL_ctrl(FSsl, SSL_CTRL_SET_TLSEXT_HOSTNAME, TLSEXT_NAMETYPE_host_name, PAnsiChar(FTargetHostName)); end; if Length(FCertificateData) > 0 then if IsFileName(FCertificateData) then GMSslCheck(SSL_use_certificate_file(FSsl, PAnsiChar(FCertificateData), SSL_FILETYPE_PEM) = 1, Self, 'SSL_use_certificate_file') else // begin // GMSslCheck(SslCtxUseCertificateASN1(tlsCtx.ApiCtxPtr, Length(FCertificateData), PAnsiChar(FCertificateData)) = 1, Self, 'SslCtxUseCertificateASN1'); GMSslCheck(SSL_use_certificate_ASN1(FSsl, PAnsiChar(FCertificateData), Length(FCertificateData)) = 1, Self, 'SSL_use_certificate_ASN1'); // end; end; function TGMOpenSslClientSocket.Initialized: Boolean; begin Result := FSsl <> nil; end; //procedure TGMOpenSslClientSocket.CopySession(const ASrcSocket: IUnknown); //var ApiCtxPtr: IGMOpenSslApiCtxPtr; session: Pointer; //begin //Initialize; //if (FSsl <> nil) and GMQueryInterface(ASrcSocket, IGMOpenSslApiCtxPtr, ApiCtxPtr) and (ApiCtxPtr.ApiCtxPtr <> nil) then // begin // session := SSL_get_session(ApiCtxPtr.ApiCtxPtr); // if session <> nil then GMSslCheck(SSL_set_session(FSsl, session) <> 0, Self, 'SSL_set_session'); //// SSLCopySessionId(FSsl, ApiCtxPtr.ApiCtxPtr); // end; //end; procedure TGMOpenSslClientSocket.NotifyCertifateVerifyStatus; var host: TGMString; verifyCode: Int64; pServerCert: PX509; begin if FNegotiated and (FCertificateNotifySink <> nil) then begin if (FTransportSocket <> nil) and (FTransportSocket.RemoteAddress <> nil) then host := FTransportSocket.RemoteAddress.Obj.ResolvedHost else host := '?'; pServerCert := SSL_get_peer_certificate(FSsl); try if pServerCert = nil then verifyCode := cNoServerCert else verifyCode := SSL_get_verify_result(FSsl); FCertificateNotifySink.ShowCertificateVerifyStatus(host, verifyCode); finally if pServerCert <> nil then X509_free(pServerCert); end; end; end; procedure TGMOpenSslClientSocket.ExecTlsNegotiation; var retVal: LongInt; begin if FNegotiated then Exit; vfGMTrace(RStrExecutingTLSNegotiation, 'SSL/TLS'); Initialize; GMSslCheck(SSL_set_fd(FSsl, FTransportSocket.Socket) = 1, Self, 'SSL_set_fd'); repeat retVal := CheckIORetCode(SSL_connect(FSsl), 'SSL_connect', True); until retVal >= 0; //GMSslCheck(retVal > 0, Self, 'SslConnect'); FNegotiated := True; //DisplayCertifaceVerifyStatus; NotifyCertifateVerifyStatus; end; initialization vCSSslContext := TGMCriticalSection.Create; vCSSslCertStore := TGMCriticalSection.Create; vGMTlsContexts := TGMIntfArrayCollection.Create(False, True, GMCompareTlsContext, True); //InitializeOpenSSL; end.