* Fix bug #37980: correct verifypeercert

git-svn-id: trunk@47340 -
(cherry picked from commit 5ec7ffa8d9cf72e1af5dab796dd3a55680966f09)

packages/fcl-net/src/sslbase.pp

@@ -36,6 +36,7 @@ Type
   Private
     FStrData : Array[0..StrDataCount] of string;
     FCertData : Array[0..SSLDataCount] of TSSLData;
+    FTrustedCertsDir: String;
     function GetSSLData(AIndex: Integer): TSSLData;
     procedure SetSSLData(AIndex: Integer; AValue: TSSLData);
     function GetString(AIndex: Integer): String;
@@ -54,6 +55,8 @@ Type
     property PrivateKey : TSSLData Index 2 Read GetSSLData Write SetSSLData;
     property PFX: TSSLData Index 3 Read GetSSLData Write SetSSLData;
     property CertCA: TSSLData Index 4 Read GetSSLData Write SetSSLData;
+    // OpenSSL allows both a PEM file or a Dir. We separate out the dir.
+    Property TrustedCertsDir : String Read FTrustedCertsDir Write FTrustedCertsDir;
   end;
 
     { TX509Certificate }

packages/fcl-net/src/sslsockets.pp

@@ -51,9 +51,12 @@ Type
   protected
     Procedure SetSSLActive(aValue : Boolean);
     function DoVerifyCert: boolean; virtual;  // if event define's change not accceptable, suggest to set virtual
+    Function GetLastSSLErrorString : String; virtual; abstract;
+    Function GetLastSSLErrorCode : Integer; virtual; abstract;
   public
     constructor Create; override;
     Destructor Destroy; override;
+    Function GetLastErrorDescription : String;override;
     // Class factory methods
     Class Procedure SetDefaultHandlerClass(aClass : TSSLSocketHandlerClass);
     Class Function GetDefaultHandlerClass : TSSLSocketHandlerClass;
@@ -64,6 +67,8 @@ Type
     function CreateSelfSignedCertificate: Boolean; virtual;
     Property CertGenerator : TX509Certificate Read FCertGenerator;
     Property SSLActive: Boolean read FSSLActive;
+    Property LastSSLErrorString : String Read GetLastSSLErrorString;
+    Property LastSSLErrorCode : Integer Read GetLastSSLErrorCode;
   published
     property SSLType: TSSLType read FSSLType write FSSLType;
     property VerifyPeerCert: Boolean read FVerifyPeerCert Write FVerifyPeerCert;
@@ -92,6 +97,7 @@ Resourcestring
     'Please include opensslsockets unit in program and recompile it.';
   SErrNoX509Certificate =
     'Cannot create a X509 certificate without SLL support';
+  SSSLErrorCode = 'SSL error code: %d';
 
 { TSSLSocketHandler }
 
@@ -177,6 +183,19 @@ begin
   inherited Destroy;
 end;
 
+function TSSLSocketHandler.GetLastErrorDescription: String;
+begin
+  Result:='';
+  if LastSSLErrorCode<>0 then
+    Result:=Format(SSSLErrorCode,[GetLastSSLErrorCode]);
+  if LastSSLErrorString<>'' then
+    begin
+    if (Result<>'') then
+      Result:=Result+': ';
+    Result:=Result+LastSSLErrorString;
+    end;
+end;
+
 class procedure TSSLSocketHandler.SetDefaultHandlerClass(aClass: TSSLSocketHandlerClass);
 begin
   FDefaultHandlerClass:=aClass;

packages/fcl-net/src/ssockets.pp

@@ -70,6 +70,8 @@ type
     function Recv(Const Buffer; Count: Integer): Integer; virtual;
     function Send(Const Buffer; Count: Integer): Integer; virtual;
     function BytesAvailable: Integer; virtual;
+    // Call this to get extra error info.
+    Function GetLastErrorDescription : String; virtual;
     Property Socket : TSocketStream Read FSocket;
     Property LastError : Integer Read FLastError;
   end;
@@ -289,7 +291,7 @@ resourcestring
   strSocketCreationFailed = 'Creation of socket failed: %s';
   strSocketBindFailed = 'Binding of socket failed: %s';
   strSocketListenFailed = 'Listening on port #%d failed, error: %d';
-  strSocketConnectFailed = 'Connect to %s failed.';
+  strSocketConnectFailed = 'Connect to %s failed: %s';
   strSocketAcceptFailed = 'Could not accept a client connection on socket: %d, error %d';
   strSocketAcceptWouldBlock = 'Accept would block on socket: %d';
   strSocketIOTimeOut = 'Failed to set IO Timeout to %d';
@@ -380,6 +382,11 @@ begin
   { we need ioctlsocket here }
 end;
 
+function TSocketHandler.GetLastErrorDescription: String;
+begin
+  Result:='';
+end;
+
 
 Function TSocketHandler.Close: Boolean;
 begin
@@ -401,7 +408,7 @@ begin
     seAcceptFailed     : s := strSocketAcceptFailed;
     seAcceptWouldBLock : S := strSocketAcceptWouldBlock;
     seIOTimeout        : S := strSocketIOTimeOut;
-    seConnectTimeOut    : s := strSocketConnectTimeout;
+    seConnectTimeOut   : s := strSocketConnectTimeout;
   end;
   s := Format(s, MsgArgs);
   inherited Create(s);
@@ -1117,6 +1124,7 @@ Var
   IsError : Boolean;
   TimeOutResult : TCheckTimeOutResult;
   Err: Integer;
+  aErrMsg : String;
 {$IFDEF HAVENONBLOCKING}
   FDS: TFDSet;
   TimeV: TTimeVal;
@@ -1171,7 +1179,10 @@ begin
     if TimeoutResult=ctrTimeout then
       Raise ESocketError.Create(seConnectTimeOut, [Format('%s:%d',[FHost, FPort])])
     else
-      Raise ESocketError.Create(seConnectFailed, [Format('%s:%d',[FHost, FPort])]);
+      begin
+      aErrMsg:=FHandler.GetLastErrorDescription;
+      Raise ESocketError.Create(seConnectFailed, [Format('%s:%d',[FHost, FPort]),aErrMsg]);
+      end;
 end;
 
 { ---------------------------------------------------------------------
@@ -1203,7 +1214,7 @@ Var
 begin
   Str2UnixSockAddr(FFilename,UnixAddr,AddrLen);
   If  FpConnect(ASocket,@UnixAddr,AddrLen)<>0 then
-    Raise ESocketError.Create(seConnectFailed,[FFilename]);
+    Raise ESocketError.Create(seConnectFailed,[FFilename,'']);
 end;
 {$endif}
 end.

packages/fcl-web/examples/httpclient/httpget.pas

@@ -4,7 +4,7 @@ program httpget;
 {$DEFINE USEGNUTLS}
 
 uses
-  SysUtils, Classes, fphttpclient,
+  SysUtils, Classes, fphttpclient, ssockets,
 {$IFNDEF USEGNUTLS}
   fpopenssl, opensslsockets,
 {$else}
@@ -17,6 +17,9 @@ Type
   { TTestApp }
 
   TTestApp = Class(Tobject)
+  private
+    procedure DoHaveSocketHandler(Sender: TObject; AHandler: TSocketHandler);
+    procedure DoVerifyCertificate(Sender: TObject; AHandler: TSSLSocketHandler; var aAllow: Boolean);
     procedure DoProgress(Sender: TObject; Const ContentLength, CurrentPos : Int64);
     procedure DoHeaders(Sender : TObject);
     procedure DoPassword(Sender: TObject; var RepeatRequest: Boolean);
@@ -84,6 +87,7 @@ begin
   Writeln('Following redirect from ',ASrc,'  ==> ',ADest);
 end;  
 
+
 procedure TTestApp.Run;
 
 begin
@@ -99,6 +103,9 @@ begin
       OnPassword:=@DoPassword;
       OnDataReceived:=@DoProgress;
       OnHeaders:=@DoHeaders;
+      VerifySSlCertificate:=True;
+      OnVerifySSLCertificate:=@DoVerifyCertificate;
+      AfterSocketHandlerCreate:=@DoHaveSocketHandler;
       { Set this if you want to try a proxy.
       Proxy.Host:='195.207.46.20';
       Proxy.Port:=8080;
@@ -109,6 +116,30 @@ begin
     end;
 end;
 
+procedure TTestApp.DoHaveSocketHandler(Sender: TObject; AHandler: TSocketHandler);
+
+Var
+  SSLHandler :  TSSLSocketHandler absolute aHandler;
+
+begin
+  if (aHandler is TSSLSocketHandler) then
+    begin
+    SSLHandler.CertificateData.TrustedCertsDir:='/etc/ssl/certs/';
+    end
+end;
+
+procedure TTestApp.DoVerifyCertificate(Sender: TObject; AHandler: TSSLSocketHandler; var aAllow: Boolean);
+
+Var
+  S : String;
+
+begin
+  Writeln('SSL Certificate verification requested, allowing');
+  S:=TEncoding.ASCII.GetAnsiString( aHandler.CertificateData.Certificate.Value);
+  Writeln('Cert: ',S);
+  aAllow:=True;
+end;
+
 begin
   With TTestApp.Create do
     try

packages/fcl-web/src/base/fphttpclient.pp

@@ -14,17 +14,12 @@
  **********************************************************************}
 unit fphttpclient;
 
-{ ---------------------------------------------------------------------
-  Todo:
-  * Proxy support ?
-  ---------------------------------------------------------------------}
-
 {$mode objfpc}{$H+}
 
 interface
 
 uses
-  Classes, SysUtils, ssockets, httpdefs, uriparser, base64;
+  Classes, SysUtils, ssockets, httpdefs, uriparser, base64, sslsockets;
 
 Const
   // Socket Read buffer size
@@ -42,6 +37,7 @@ Type
   // Use this to set up a socket handler. UseSSL is true if protocol was https
   TGetSocketHandlerEvent = Procedure (Sender : TObject; Const UseSSL : Boolean; Out AHandler : TSocketHandler) of object;
   TSocketHandlerCreatedEvent = Procedure (Sender : TObject; AHandler : TSocketHandler) of object;
+  THTTPVerifyCertificateEvent = Procedure (Sender : TObject; AHandler : TSSLSocketHandler; var aAllow : Boolean) of object;
 
   TFPCustomHTTPClient = Class;
 
@@ -79,6 +75,7 @@ Type
     FOnHeaders: TNotifyEvent;
     FOnPassword: TPasswordEvent;
     FOnRedirect: TRedirectEvent;
+    FOnVerifyCertificate: THTTPVerifyCertificateEvent;
     FPassword: String;
     FIOTimeout: Integer;
     FConnectTimeout: Integer;
@@ -98,6 +95,7 @@ Type
     FOnGetSocketHandler : TGetSocketHandlerEvent;
     FAfterSocketHandlerCreated : TSocketHandlerCreatedEvent;
     FProxy : TProxyData;
+    FVerifySSLCertificate: Boolean;
     function CheckContentLength: Int64;
     function CheckTransferEncoding: string;
     function GetCookies: TStrings;
@@ -113,7 +111,8 @@ Type
     Procedure ExtractHostPort(AURI: TURI; Out AHost: String; Out APort: Word);
     Procedure CheckConnectionCloseHeader;
   protected
-
+    // Called with TSSLSocketHandler as sender
+    procedure DoVerifyCertificate(Sender: TObject; var Allow: Boolean); virtual;
     Function NoContentAllowed(ACode : Integer) : Boolean;
     // Peform a request, close connection.
     Procedure DoNormalRequest(const AURI: TURI; const AMethod: string;
@@ -305,9 +304,6 @@ Type
     // Maximum chunk size: If chunk sizes bigger than this are encountered, an error will be raised.
     // Set to zero to disable the check.
     Property MaxChunkSize : SizeUInt Read FMaxChunkSize Write FMaxChunkSize;
-    // Called On redirect. Dest URL can be edited.
-    // If The DEST url is empty on return, the method is aborted (with redirect status).
-    Property OnRedirect : TRedirectEvent Read FOnRedirect Write FOnRedirect;
     // Proxy support
     Property Proxy : TProxyData Read GetProxy Write SetProxy;
     // Authentication.
@@ -319,6 +315,11 @@ Type
     Property Connected: Boolean read IsConnected;
     // Keep-Alive support. Setting to true will set HTTPVersion to 1.1
     Property KeepConnection: Boolean Read FKeepConnection Write SetKeepConnection;
+    // SSL certificate validation.
+    Property VerifySSLCertificate : Boolean Read FVerifySSLCertificate Write FVerifySSLCertificate;
+    // Called On redirect. Dest URL can be edited.
+    // If The DEST url is empty on return, the method is aborted (with redirect status).
+    Property OnRedirect : TRedirectEvent Read FOnRedirect Write FOnRedirect;
     // If a request returns a 401, then the OnPassword event is fired.
     // It can modify the username/password and set RepeatRequest to true;
     Property OnPassword : TPasswordEvent Read FOnPassword Write FOnPassword;
@@ -330,6 +331,8 @@ Type
     Property OnGetSocketHandler : TGetSocketHandlerEvent Read FOnGetSocketHandler Write FOnGetSocketHandler;
     // Called after create socket handler was created, with the created socket handler.
     Property AfterSocketHandlerCreate : TSocketHandlerCreatedEvent Read FAfterSocketHandlerCreated Write FAfterSocketHandlerCreated;
+    // Called when a SSL certificate must be verified.
+    Property OnVerifySSLCertificate : THTTPVerifyCertificateEvent Read FOnVerifyCertificate Write FOnVerifyCertificate;
   end;
 
 
@@ -357,6 +360,10 @@ Type
     Property OnHeaders;
     Property OnGetSocketHandler;
     Property Proxy;
+    Property VerifySSLCertificate;
+    Property AfterSocketHandlerCreate;
+    Property OnVerifySSLCertificate;
+
   end;
 
   EHTTPClient = Class(EHTTP);
@@ -366,8 +373,6 @@ Function DecodeURLElement(Const S : String) : String;
 
 implementation
 
-uses sslsockets;
-
 resourcestring
   SErrInvalidProtocol = 'Invalid protocol : "%s"';
   SErrReadingSocket = 'Error reading data from socket';
@@ -585,13 +590,21 @@ end;
 
 function TFPCustomHTTPClient.GetSocketHandler(const UseSSL: Boolean): TSocketHandler;
 
+Var
+  SSLHandler : TSSLSocketHandler;
+
 begin
   Result:=Nil;
   if Assigned(FonGetSocketHandler) then
     FOnGetSocketHandler(Self,UseSSL,Result);
   if (Result=Nil) then
     If UseSSL then
-      Result:=TSSLSocketHandler.GetDefaultHandler
+      begin
+      SSLHandler:=TSSLSocketHandler.GetDefaultHandler;
+      SSLHandler.VerifyPeerCert:=FVerifySSLCertificate;
+      SSLHandler.OnVerifyCertificate:=@DoVerifyCertificate;
+      Result:=SSLHandler;
+      end
     else
       Result:=TSocketHandler.Create;
   if Assigned(AfterSocketHandlerCreate) then
@@ -945,6 +958,12 @@ begin
     end;
 end;
 
+procedure TFPCustomHTTPClient.DoVerifyCertificate(Sender: TObject; var Allow: Boolean);
+begin
+  If Assigned(FOnVerifyCertificate) then
+    FOnVerifyCertificate(Self,Sender as TSSLSocketHandler,Allow);
+end;
+
 function TFPCustomHTTPClient.GetCookies: TStrings;
 begin
   If (FCookies=Nil) then

packages/gnutls/src/gnutlssockets.pp

@@ -40,6 +40,8 @@ Type
     function InitSession(AsServer: Boolean): Boolean; virtual;
     function DoneSession: Boolean; virtual;
     function InitSslKeys: boolean;virtual;
+    function GetLastSSLErrorCode: Integer; override;
+    function GetLastSSLErrorString: String; override;
   Public
     Constructor create; override;
     destructor destroy; override;
@@ -288,7 +290,7 @@ begin
     exit;
   Result:=DoHandShake;
   if Result and VerifyPeerCert then
-    Result:=(not DoVerifyCert);
+    Result:=DoVerifyCert;
   if Result then
     SetSSLActive(True);
 end;
@@ -480,8 +482,8 @@ begin
     Result:=LoadCertificate(CertificateData.Certificate,CertificateData.PrivateKey);
   if Result and Not CertificateData.TrustedCertificate.Empty then
     Result:=LoadTrustedCertificate(CertificateData.TrustedCertificate);
-  if Result and (CertificateData.CertCA.FileName<>'') then
-    Result:=Result and SetTrustedCertificateDir(CertificateData.CertCA.FileName);
+  if Result and (CertificateData.TrustedCertsDir<>'') then
+    Result:=Result and SetTrustedCertificateDir(CertificateData.TrustedCertsDir);
   // If nothing was set, set defaults.
   if not Assigned(FCred) then
     begin
@@ -598,6 +600,16 @@ begin
   Result:=FGNUTLSLastError;
 end;
 
+function TGNUTLSSocketHandler.GetLastSSLErrorString: String;
+begin
+  Result:=FGNUTLSLastErrorString;
+end;
+
+function TGNUTLSSocketHandler.GetLastSSLErrorCode: Integer;
+begin
+  Result:=FGNUTLSLastError;
+end;
+
 initialization
   TSSLSocketHandler.SetDefaultHandlerClass(TGNUTLSSocketHandler);
 end.

packages/openssl/src/opensslsockets.pp

@@ -25,6 +25,8 @@ Type
     function InitContext(NeedCertificate: Boolean): Boolean; virtual;
     function DoneContext: Boolean; virtual;
     function InitSslKeys: boolean;virtual;
+    Function GetLastSSLErrorString : String; override;
+    Function GetLastSSLErrorCode : Integer; override;
   Public
     Constructor create; override;
     destructor destroy; override;
@@ -171,12 +173,22 @@ begin
     Result:=CheckSSL(FCTX.UseCertificate(CertificateData.Certificate));
   if Result and not CertificateData.PrivateKey.Empty then
     Result:=CheckSSL(FCTX.UsePrivateKey(CertificateData.PrivateKey));
-  if Result and (CertificateData.CertCA.FileName<>'') then
-    Result:=CheckSSL(FCTX.LoadVerifyLocations(CertificateData.CertCA.FileName,''));
+  if Result and ((CertificateData.CertCA.FileName<>'') or (CertificateData.TrustedCertsDir<>'')) then
+    Result:=CheckSSL(FCTX.LoadVerifyLocations(CertificateData.CertCA.FileName,CertificateData.TrustedCertsDir));
   if Result and not CertificateData.PFX.Empty then
     Result:=CheckSSL(FCTX.LoadPFX(CertificateData.PFX,CertificateData.KeyPassword));
 end;
 
+function TOpenSSLSocketHandler.GetLastSSLErrorString: String;
+begin
+  Result:=FSSLLastErrorString;
+end;
+
+function TOpenSSLSocketHandler.GetLastSSLErrorCode: Integer;
+begin
+  Result:=FSSLLastError;
+end;
+
 constructor TOpenSSLSocketHandler.create;
 begin
   inherited create;