- new support for TLS SNI in OpenSSL.

- improved certificate verification
- improved Cryptlib support

git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@139 7c85be65-684b-0410-a082-b2ed4fbef004

blcksock.pas

@@ -204,7 +204,13 @@ type
    insert your code after TCP socket has been sucessfully connected.}
   THookAfterConnect = procedure(Sender: TObject) of object;
 
-  {:This procedural type is used for hook OnHeartbeat. By this hook you can
+  {:This procedural type is used for hook OnVerifyCert. By this hook you can
+   insert your additional certificate verification code. Usefull to verify server
+   CN against URL. }
+
+  THookVerifyCert = function(Sender: TObject):boolean of object;
+
+ {:This procedural type is used for hook OnHeartbeat. By this hook you can
    call your code repeately during long socket operations.
    You must enable heartbeats by @Link(HeartbeatRate) property!}
   THookHeartbeat = procedure(Sender: TObject) of object;
@@ -1199,7 +1205,9 @@ type
    Warning: not all methods and propertis can work in all existing SSL plugins!
    Please, read documentation of used SSL plugin.}
   TCustomSSL = class(TObject)
+  private
   protected
+    FOnVerifyCert: THookVerifyCert;
     FSocket: TTCPBlockSocket;
     FSSLEnabled: Boolean;
     FLastError: integer;
@@ -1223,7 +1231,11 @@ type
     FSSHChannelType: string;
     FSSHChannelArg1: string;
     FSSHChannelArg2: string;
+    FCertComplianceLevel: integer;
+    FSNIHost: string;
     procedure ReturnError;
+    procedure SetCertCAFile(const Value: string); virtual;
+    function DoVerifyCert:boolean;
     function CreateSelfSignedCert(Host: string): Boolean; virtual;
   public
     {: Create plugin class. it is called internally from @link(TTCPBlockSocket)}
@@ -1378,7 +1390,7 @@ type
 
     {:Used for loading CA certificates from disk file. See to plugin documentation
      if this method is supported and how!}
-    property CertCAFile: string read FCertCAFile write FCertCAFile;
+    property CertCAFile: string read FCertCAFile write SetCertCAFile;
 
     {:If @true, then is verified client certificate. (it is good for writing
      SSL/TLS servers.) When you are not server, but you are client, then if this
@@ -1393,6 +1405,20 @@ type
 
     {:Second argument of channel type for possible SSH connections}
     property SSHChannelArg2: string read FSSHChannelArg2 write FSSHChannelArg2;
+
+    {: Level of standards compliance level
+      (CryptLib: values in cryptlib.pas, -1: use default value )  }
+    property CertComplianceLevel:integer read FCertComplianceLevel write FCertComplianceLevel;
+
+    {:This event is called when verifying the server certificate immediatally after
+     a successfull verification in the ssl library.}
+    property OnVerifyCert: THookVerifyCert read FOnVerifyCert write FOnVerifyCert;
+
+    {: Server Name Identification. Host name to send to server. If empty the host name
+       found in URL will be used, which should be the normal use (http Header Host = SNI Host).
+       The value is cleared after the connection is established.
+      (SNI support requires OpenSSL 0.9.8k or later. Cryptlib not supported, yet )  }
+    property SNIHost:string read FSNIHost write FSNIHost;
   end;
 
   {:@abstract(Default SSL plugin with no SSL support.)
@@ -4094,6 +4120,8 @@ begin
   FSSHChannelType := '';
   FSSHChannelArg1 := '';
   FSSHChannelArg2 := '';
+  FCertComplianceLevel := -1; //default
+  FSNIHost := '';
 end;
 
 procedure TCustomSSL.Assign(const Value: TCustomSSL);
@@ -4114,6 +4142,8 @@ begin
   FPrivateKey := Value.PrivateKey;
   FPFX := Value.PFX;
   FPFXfile := Value.PFXfile;
+  FCertComplianceLevel := Value.CertComplianceLevel;
+  FSNIHost := Value.FSNIHost;
 end;
 
 procedure TCustomSSL.ReturnError;
@@ -4167,6 +4197,11 @@ begin
   Result := integer(SOCKET_ERROR);
 end;
 
+procedure TCustomSSL.SetCertCAFile(const Value: string);
+begin
+  FCertCAFile := Value;
+end;
+
 function TCustomSSL.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
 begin
   ReturnError;
@@ -4229,6 +4264,17 @@ begin
   Result := 1;
 end;
 
+function TCustomSSL.DoVerifyCert:boolean;
+begin
+  if assigned(OnVerifyCert) then
+  begin
+    result:=OnVerifyCert(Self);
+  end
+  else
+    result:=true;
+end;
+
+
 {======================================================================}
 
 function TSSLNone.LibVersion: String;

httpsend.pas

@@ -352,7 +352,10 @@ begin
     Exit;
   if needssl then
   begin
+    if (FSock.SSL.SNIHost='') then
+      FSock.SSL.SNIHost:=FTargetHost;
     FSock.SSLDoConnect;
+    FSock.SSL.SNIHost:=''; //don't need it anymore and don't wan't to reuse it in next connection
     if FSock.LastError <> 0 then
       Exit;
   end;

ssl_cryptlib.pas

@@ -98,6 +98,7 @@ type
     FPrivateKeyLabel: string;
     FDelCert: Boolean;
     FReadBuffer: string;
+    FTrustedCAs: array of integer;
     function SSLCheck(Value: integer): Boolean;
     function Init(server:Boolean): Boolean;
     function DeInit: Boolean;
@@ -109,6 +110,8 @@ type
     {:See @inherited}
     constructor Create(const Value: TTCPBlockSocket); override;
     destructor Destroy; override;
+    {:Load trusted CA's in PEM format}
+    procedure SetCertCAFile(const Value: string); override;
     {:See @inherited}
     function LibVersion: String; override;
     {:See @inherited}
@@ -139,6 +142,8 @@ type
     function GetPeerName: string; override;
     {:See @inherited}
     function GetPeerFingerprint: string; override;
+    {:See @inherited}
+    function GetVerifyCert: integer; override;
   published
     {:name of certificate/key within PKCS#15 file. It can hold more then one
      certificate/key and each certificate/key must have unique label within one file.}
@@ -155,10 +160,12 @@ begin
   FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
   FPrivateKeyLabel := 'synapse';
   FDelCert := false;
+  FTrustedCAs := nil;
 end;
 
 destructor TSSLCryptLib.Destroy;
 begin
+  SetCertCAFile('');  // destroy certificates
   DeInit;
   inherited Destroy;
 end;
@@ -211,7 +218,11 @@ begin
   if FLastError <> 0 then
   begin
     Result := False;
+{$IF CRYPTLIB_VERSION >= 3400}
+    FLastErrorDesc := GetString(FCryptSession, CRYPT_ATTRIBUTE_ERRORMESSAGE);
+{$ELSE}
     FLastErrorDesc := GetString(FCryptSession, CRYPT_ATTRIBUTE_INT_ERRORMESSAGE);
+{$IFEND}
   end;
 end;
 
@@ -313,6 +324,12 @@ begin
   if x >= 0 then
     if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x)) then
       Exit;
+
+  if (FCertComplianceLevel <> -1) then
+    if not SSLCheck(cryptSetAttribute (CRYPT_UNUSED, CRYPT_OPTION_CERT_COMPLIANCELEVEL,
+      FCertComplianceLevel)) then
+      Exit;
+
   if FUsername <> '' then
   begin
     cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_USERNAME,
@@ -409,6 +426,9 @@ begin
       Exit;
     if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then
       Exit;
+    if FverifyCert then
+      if (GetVerifyCert <> 0) or (not DoVerifyCert) then
+        Exit;
     FSSLEnabled := True;
     Result := True;
     FReadBuffer := '';
@@ -439,8 +459,8 @@ end;
 
 function TSSLCryptLib.BiShutdown: boolean;
 begin
-  if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then
+//  if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then
-    cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 0);
+//    cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 0); //no-op
   DeInit;
   FReadBuffer := '';
   Result := True;
@@ -511,7 +531,7 @@ begin
   if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
     Exit;
   cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
-  cryptSetAttribute(cert, CRYPT_CERTINFO_SUBJECTNAME, CRYPT_UNUSED);
+  cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_SUBJECTNAME);
   Result := GetString(cert, CRYPT_CERTINFO_DN);
   cryptDestroyCert(cert);
 end;
@@ -524,7 +544,7 @@ begin
   if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
     Exit;
   cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
-  cryptSetAttribute(cert, CRYPT_CERTINFO_ISSUERNAME, CRYPT_UNUSED);
+  cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_SUBJECTNAME);
   Result := GetString(cert, CRYPT_CERTINFO_COMMONNAME);
   cryptDestroyCert(cert);
 end;
@@ -537,8 +557,8 @@ begin
   if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
     Exit;
   cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
-  cryptSetAttribute(cert, CRYPT_CERTINFO_ISSUERNAME, CRYPT_UNUSED);
+  cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_ISSUERNAME);
-  Result := GetString(cert, CRYPT_CERTINFO_DN);
+  Result := GetString(cert, CRYPT_CERTINFO_COMMONNAME);
   cryptDestroyCert(cert);
 end;
 
@@ -551,19 +571,109 @@ begin
     Exit;
   cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
   Result := GetString(cert, CRYPT_CERTINFO_FINGERPRINT);
-  Result := MD5(Result);
+  cryptDestroyCert(cert);
+end;
+
+
+procedure TSSLCryptLib.SetCertCAFile(const Value: string);
+
+var F:textfile;
+  bInCert:boolean;
+  s,sCert:string;
+  cert: CRYPT_CERTIFICATE;
+  idx:integer;
+
+begin
+if assigned(FTrustedCAs) then
+  begin
+  for idx := 0 to High(FTrustedCAs) do
+    cryptDestroyCert(FTrustedCAs[idx]);
+  FTrustedCAs:=nil;
+  end;
+if Value<>'' then
+  begin
+  AssignFile(F,Value);
+  reset(F);
+  bInCert:=false;
+  idx:=0;
+  while not eof(F) do
+    begin
+    readln(F,s);
+    if pos('-----END CERTIFICATE-----',s)>0 then
+      begin
+      bInCert:=false;
+      cert:=0;
+      if (cryptImportCert(PAnsiChar(sCert),length(sCert)-2,CRYPT_UNUSED,cert)=CRYPT_OK) then
+        begin
+        cryptSetAttribute( cert, CRYPT_CERTINFO_TRUSTED_IMPLICIT, 1 );
+        SetLength(FTrustedCAs,idx+1);
+        FTrustedCAs[idx]:=cert;
+        idx:=idx+1;
+        end;
+      end;
+    if bInCert then
+      sCert:=sCert+s+#13#10;
+    if pos('-----BEGIN CERTIFICATE-----',s)>0 then
+      begin
+      bInCert:=true;
+      sCert:='';
+      end;
+    end;
+  CloseFile(F);
+  end;
+end;
+
+function TSSLCryptLib.GetVerifyCert: integer;
+var
+  cert: CRYPT_CERTIFICATE;
+  itype,ilocus:integer;
+begin
+  Result := -1;
+  if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
+    Exit;
+  cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
+  result:=cryptCheckCert(cert,CRYPT_UNUSED);
+  if result<>CRYPT_OK then
+    begin
+    //get extended error info if available
+    cryptGetAttribute(cert,CRYPT_ATTRIBUTE_ERRORtype,itype);
+    cryptGetAttribute(cert,CRYPT_ATTRIBUTE_ERRORLOCUS,ilocus);
+    cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_SUBJECTNAME);
+    FLastError := Result;
+    FLastErrorDesc := format('SSL/TLS certificate verification failed for "%s"'#13#10'Status: %d. ERRORTYPE: %d. ERRORLOCUS: %d.',
+      [GetString(cert, CRYPT_CERTINFO_COMMONNAME),result,itype,ilocus]);
+    end;
   cryptDestroyCert(cert);
 end;
 
 {==============================================================================}
 
+var imajor,iminor,iver:integer;
+//    e: ESynapseError;
+
 initialization
   if cryptInit = CRYPT_OK then
     SSLImplementation := TSSLCryptLib;
   cryptAddRandom(nil, CRYPT_RANDOM_SLOWPOLL);
-
+  cryptGetAttribute (CRYPT_UNUSED, CRYPT_OPTION_INFO_MAJORVERSION,imajor);
+  cryptGetAttribute (CRYPT_UNUSED, CRYPT_OPTION_INFO_MINORVERSION,iminor);
+// according to the documentation CRYPTLIB version has 3 digits. recent versions use 4 digits
+  if CRYPTLIB_VERSION >1000 then
+    iver:=CRYPTLIB_VERSION div 100
+  else
+    iver:=CRYPTLIB_VERSION div 10;
+  if (iver <> imajor*10+iminor) then
+  begin
+    SSLImplementation :=TSSLNone;
+//    e := ESynapseError.Create(format('Error wrong cryptlib version (is %d.%d expected %d.%d). ',
+//       [imajor,iminor,iver div 10, iver mod 10]));
+//    e.ErrorCode := 0;
+//    e.ErrorMessage := format('Error wrong cryptlib version (%d.%d expected %d.%d)',
+//       [imajor,iminor,iver div 10, iver mod 10]);
+//    raise e;
+  end;
 finalization
   cryptEnd;
-
 end.
 
+

ssl_openssl.pas

@@ -501,6 +501,8 @@ begin
       SSLCheck;
       Exit;
     end;
+    if SNIHost<>'' then
+      SSLCtrl(Fssl, SSL_CTRL_SET_TLSEXT_HOSTNAME, TLSEXT_NAMETYPE_host_name, pchar(SNIHost));
     x := sslconnect(FSsl);
     if x < 1 then
     begin
@@ -508,7 +510,7 @@ begin
       Exit;
     end;
   if FverifyCert then
-    if GetVerifyCert <> 0 then
+    if (GetVerifyCert <> 0) or (not DoVerifyCert) then
       Exit;
     FSSLEnabled := True;
     Result := True;

ssl_openssl_lib.pas

@@ -218,6 +218,9 @@ const
   SSL_FILETYPE_PEM = 1;
   EVP_PKEY_RSA = 6;
 
+  SSL_CTRL_SET_TLSEXT_HOSTNAME = 55;
+  TLSEXT_NAMETYPE_host_name = 0;
+
 var
   SSLLibHandle: TLibHandle = 0;
   SSLUtilHandle: TLibHandle = 0;
@@ -420,6 +423,11 @@ var
     EntryPoint = 'SSL_get_verify_result')]
     function SSLGetVerifyResult(ssl: PSSL):Integer;external;
 
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_ctrl')]
+    function SslCtrl(ssl: PSSL; cmd: integer; larg: integer; parg: IntPtr): integer; external;
+
   [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
     SetLastError = False, CallingConvention= CallingConvention.cdecl,
     EntryPoint = 'X509_new')]
@@ -712,6 +720,7 @@ var
   function SSLCipherGetName(c: SslPtr): AnsiString;
   function SSLCipherGetBits(c: SslPtr; var alg_bits: Integer):Integer;
   function SSLGetVerifyResult(ssl: PSSL):Integer;
+  function SSLCtrl(ssl: PSSL; cmd: integer; larg: integer; parg: SslPtr):Integer;
 
 // libeay.dll
   function X509New: PX509;
@@ -821,6 +830,9 @@ type
   TSSLCipherGetName = function(c: Sslptr):PAnsiChar; cdecl;
   TSSLCipherGetBits = function(c: SslPtr; alg_bits: PInteger):Integer; cdecl;
   TSSLGetVerifyResult = function(ssl: PSSL):Integer; cdecl;
+  TSSLCtrl = function(ssl: PSSL; cmd: integer; larg: integer; parg: SslPtr):Integer; cdecl;
+
+  TSSLSetTlsextHostName = function(ssl: PSSL; buf: PAnsiChar):Integer; cdecl;
 
 // libeay.dll
   TX509New = function: PX509; cdecl;
@@ -920,6 +932,7 @@ var
   _SSLCipherGetName: TSSLCipherGetName = nil;
   _SSLCipherGetBits: TSSLCipherGetBits = nil;
   _SSLGetVerifyResult: TSSLGetVerifyResult = nil;
+  _SSLCtrl: TSSLCtrl = nil;
 
 // libeay.dll
   _X509New: TX509New = nil;
@@ -1301,6 +1314,15 @@ begin
     Result := X509_V_ERR_APPLICATION_VERIFICATION;
 end;
 
+
+function SSLCtrl(ssl: PSSL; cmd: integer; larg: integer; parg: SslPtr):Integer;
+begin
+  if InitSSLInterface and Assigned(_SSLCtrl) then
+    Result := _SSLCtrl(ssl, cmd, larg, parg)
+  else
+    Result := X509_V_ERR_APPLICATION_VERIFICATION;
+end;
+
 // libeay.dll
 function X509New: PX509;
 begin
@@ -1785,6 +1807,7 @@ begin
         _SslCipherGetName := GetProcAddr(SSLLibHandle, 'SSL_CIPHER_get_name');
         _SslCipherGetBits := GetProcAddr(SSLLibHandle, 'SSL_CIPHER_get_bits');
         _SslGetVerifyResult := GetProcAddr(SSLLibHandle, 'SSL_get_verify_result');
+        _SslCtrl := GetProcAddr(SSLLibHandle, 'SSL_ctrl');
 
         _X509New := GetProcAddr(SSLUtilHandle, 'X509_new');
         _X509Free := GetProcAddr(SSLUtilHandle, 'X509_free');
@@ -1969,6 +1992,7 @@ begin
     _SslCipherGetName := nil;
     _SslCipherGetBits := nil;
     _SslGetVerifyResult := nil;
+    _SslCtrl := nil;
 
     _X509New := nil;
     _X509Free := nil;