{ +-------------------------------------------------------------+ }
{ |                                                             | }
{ |   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

  TGMTlsProtocolVersion = (pvTLSv1, pvTLSv1_1, pvTLSv1_2, pvAuto);

  IGMOpenSslApiCtxPtr = interface(IUnknown)
    ['{7CDF1549-5FC0-43FC-A680-F26990B0F4B9}']
    function ApiCtxPtr: Pointer; stdcall;
  end;


  TGMOpenSSLProtocolSite = (cpsClient, cpsServer, cpsBoth);

  IGMTlsProtocolVersion = interface(IUnknown)
    ['{CA2DB22D-CA7E-4E94-9584-8DC82379A53C}']
    function GetProtocolVersion: TGMTlsProtocolVersion;
    function GetProtocolSite: TGMOpenSSLProtocolSite;
    property ProtocolVersion: TGMTlsProtocolVersion read GetProtocolVersion;
    property ProtocolSite: TGMOpenSSLProtocolSite read GetProtocolSite;
  end;


  //
  // Used for lookup
  //
  TGMOpenSslContextBase = class(TGMRefCountedObj, IGMTlsProtocolVersion)
   protected
    FProtocolVersion: TGMTlsProtocolVersion;
    FProtocolSite: TGMOpenSSLProtocolSite;
   public
    constructor Create(const AProtocolVersion: TGMTlsProtocolVersion = pvAuto; const AProtocolSite: TGMOpenSSLProtocolSite = cpsBoth; const ARefLifeTime: Boolean = True); reintroduce; overload; virtual;
    function GetProtocolVersion: TGMTlsProtocolVersion;
    function GetProtocolSite: TGMOpenSSLProtocolSite;
  end;


  TGMOpenSslContext = class(TGMOpenSslContextBase, IGMOpenSslApiCtxPtr)
   protected
    FSslCtx: PSSL_CTX;
   public                                           //
    constructor Create(const AProtocolVersion: TGMTlsProtocolVersion = pvAuto; const AProtocolSite: TGMOpenSSLProtocolSite = 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: TGMTlsProtocolVersion;
    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;

//  procedure DisplayCertifaceVerifyStatus;
    procedure NotifyCertifateVerifyStatus;

   public
    constructor Create(const ATransportSocket: IGMSocket;
                       const ACertificateStatusNotifySink: IUnknown = nil;
                       const ACertificateData: AnsiString = '';
                       const AProtocolVersion: TGMTlsProtocolVersion = 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 AWinCertStoreFolderPath: TGMString; 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 ACertificateStatusNotifySink: IUnknown = nil;
                       const ACertificateData: AnsiString = '';
                       const AProtocolVersion: TGMTlsProtocolVersion = pvAuto;
                       const AExectTlsNegoatiation: 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 cleanly shut down';
  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 GMTlsCheck(const ASuccess: Boolean; const ACaller: TObject; const ACallingName: AnsiString);
var errorCode: LongWord; errorMsg: AnsiString;
begin
  if ASuccess then Exit;
  errorMsg := '';
  repeat
   errorCode := ERR_get_error;
   if errorCode <> 0 then errorMsg := GMStringJoin(errorMsg, cNewLine, OpenSSLErrorString(errorCode));
  until errorCode = 0;
// ErrClearError;

  if Length(errorMsg) <= 0 then errorMsg := RStrUnknownSSLError;
  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 ACertificateStatusNotifySink: IUnknown;
  const ACertificateData: AnsiString; const AProtocolVersion: TGMTlsProtocolVersion; const AExectTlsNegoatiation: Boolean): IGMSocketIO;
begin
  Result := TGMOpenSslClientSocket.Create(ATransportLayer, ACertificateStatusNotifySink, ACertificateData, AProtocolVersion);
  if AExectTlsNegoatiation 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 GMTlsCheck(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');
   Result := vGMOpenSSLCertStore;
  finally
   vCSSslCertStore.LeaveCriticalSection;
  end;
end;

function GMTlsContext(const AProtocolVersion: TGMTlsProtocolVersion; const AProtocolSite: TGMOpenSSLProtocolSite): 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;
const cStrRoutineName = 'GMCompareTlsContext';
var ctxA, ctxB: IGMTlsProtocolVersion;
begin
  GMCheckQueryInterface(ItemA, IGMTlsProtocolVersion, ctxA, cStrRoutineName);
  GMCheckQueryInterface(ItemB, IGMTlsProtocolVersion, ctxB, cStrRoutineName);

  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;

//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);
//GMTlsCheck(FStore <> nil, Self, 'X509_STORE_new');
end;

constructor TGMOpenSslCertStore.CreateFromWinCerts(const AWinCertStoreFolderPath: TGMString; const ARefLifeTime: Boolean);
begin
  Create(ARefLifeTime);
  LoadFromWinCerts(AWinCertStoreFolderPath);
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;
begin
  if Length(AWinCertStoreFolderPath) <= 0 then Exit;

  winCertStore := CertOpenSystemStore(0, PGMChar(AWinCertStoreFolderPath));
  GMApiCheckObj('CertOpenSystemStore("'+AWinCertStoreFolderPath+'")', '', GetLastError, winCertStore <> nil, Self);
  try
   pWinCertCtx := nil;
   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);
      end;

    until False;

   finally
    if pWinCertCtx <> nil then CertFreeCertificateContext(pWinCertCtx);
   end;
  finally
   CertCloseStore(winCertStore, 0);
  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: TGMTlsProtocolVersion; const AProtocolSite: TGMOpenSSLProtocolSite; const ARefLifeTime: Boolean);
begin
  Create(ARefLifeTime);
  FProtocolVersion := AProtocolVersion;
  FProtocolSite := AProtocolSite;
end;

function TGMOpenSslContextBase.GetProtocolVersion: TGMTlsProtocolVersion;
begin
  Result := FProtocolVersion;
end;

function TGMOpenSslContextBase.GetProtocolSite: TGMOpenSSLProtocolSite;
begin
  Result := FProtocolSite;
end;


{ --------------------------- }
{ ---- TGMOpenSslContext ---- }
{ --------------------------- }

constructor TGMOpenSslContext.Create(const AProtocolVersion: TGMTlsProtocolVersion; const AProtocolSite: TGMOpenSSLProtocolSite; const ARefLifeTime: Boolean);
const cStrMethodName = 'Create';
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, cStrMethodName);
    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, cStrMethodName);
    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, cStrMethodName);
    end;

   else raise EGMTlsException.ObjError(GMFormat(RStrInvalidSSLPtotocolSite, [Ord(AProtocolSite)]), Self, cStrMethodName);
  end;

  GMTlsCheck(FSslCtx <> nil, Self, 'TlsMethodVXxx');
  SSL_CTX_set_verify(FSslCtx, SSL_VERIFY_NONE, nil);
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;
const cStrMethodName = 'TGMOpenSslClientSocket.CheckIORetCode';
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, cStrMethodName);
    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:;
     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(RStrCleanlyShutdown, Self, cStrMethodName);

//   SSL_ERROR_ZERO_RETURN:
     else GMTlsCheck(False, Self, ASSLRoutineName); // <- SSL_ERROR_SYSCALL, SSL_ERROR_SSL
    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 ACertificateStatusNotifySink: IUnknown;
  const ACertificateData: AnsiString; const AProtocolVersion: TGMTlsProtocolVersion; const ARefLifeTime: Boolean);
begin
  inherited Create(ARefLifeTime);
  FTransportSocket := ATransportSocket;
  FProtocolVersion := AProtocolVersion;
  GMQueryInterface(ACertificateStatusNotifySink, IGMShowCertificateVerifyStatus, FCertificateNotifySink);
  FCertificateData := ACertificateData;
  //ExecTlsNegotiation;
end;

destructor TGMOpenSslClientSocket.Destroy;
begin
  try ShutDown; except GMTraceException(GMExceptObject); 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;

  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);
  GMTlsCheck(FSsl <> nil, Self, 'SSL_new');

  if Length(FCertificateData) > 0 then
   if IsFileName(FCertificateData) then
    GMTlsCheck(SSL_use_certificate_file(FSsl, PAnsiChar(FCertificateData), SSL_FILETYPE_PEM) = 1, Self, 'SSL_use_certificate_file')
   else
//  begin
//   GMTlsCheck(SslCtxUseCertificateASN1(tlsCtx.ApiCtxPtr, Length(FCertificateData), PAnsiChar(FCertificateData)) = 1, Self, 'SslCtxUseCertificateASN1');
     GMTlsCheck(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 GMTlsCheck(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;
  GMTlsCheck(SSL_set_fd(FSsl, FTransportSocket.Socket) <> 0, Self, 'SSL_set_fd');
  repeat
   retVal := CheckIORetCode(SSL_connect(FSsl), 'SSL_connect', True);
  until retVal >= 0;
//GMTlsCheck(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.