Commit 5ec7ffa8 authored by Michael Van Canneyt's avatar Michael Van Canneyt
Browse files

* Fix bug #37980: correct verifypeercert

git-svn-id: trunk@47340 -
parent 4fa33623
......@@ -36,6 +36,7 @@ interface
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 @@ interface
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 }
......
......@@ -51,9 +51,12 @@ TSSLSocketHandler = class(TSocketHandler)
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 @@ TSSLSocketHandler = class(TSocketHandler)
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 @@ implementation
'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 @@ constructor TSSLSocketHandler.Create;
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;
......
......@@ -70,6 +70,8 @@ ESocketError = class(Exception)
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 @@ TSocketStream = class(THandleStream)
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 @@ function TSocketHandler.BytesAvailable: Integer;
{ we need ioctlsocket here }
end;
function TSocketHandler.GetLastErrorDescription: String;
begin
Result:='';
end;
Function TSocketHandler.Close: Boolean;
begin
......@@ -401,7 +408,7 @@ constructor ESocketError.Create(ACode: TSocketErrorType; const MsgArgs: array of
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 @@ procedure TInetSocket.Connect;
IsError : Boolean;
TimeOutResult : TCheckTimeOutResult;
Err: Integer;
aErrMsg : String;
{$IFDEF HAVENONBLOCKING}
FDS: TFDSet;
TimeV: TTimeVal;
......@@ -1171,7 +1179,10 @@ procedure TInetSocket.Connect;
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 @@ procedure TInetSocket.Connect;
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.
......@@ -4,7 +4,7 @@
{$DEFINE USEGNUTLS}
uses
SysUtils, Classes, fphttpclient,
SysUtils, Classes, fphttpclient, ssockets,
{$IFNDEF USEGNUTLS}
fpopenssl, opensslsockets,
{$else}
......@@ -17,6 +17,9 @@
{ 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 @@ procedure TTestApp.ShowRedirect(ASender: TObject; const ASrc: String;
Writeln('Following redirect from ',ASrc,' ==> ',ADest);
end;
procedure TTestApp.Run;
begin
......@@ -99,6 +103,9 @@ procedure TTestApp.Run;
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 @@ procedure TTestApp.Run;
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
......
......@@ -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 @@ interface
// 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 @@ interface
FOnHeaders: TNotifyEvent;
FOnPassword: TPasswordEvent;
FOnRedirect: TRedirectEvent;
FOnVerifyCertificate: THTTPVerifyCertificateEvent;
FPassword: String;
FIOTimeout: Integer;
FConnectTimeout: Integer;
......@@ -98,6 +95,7 @@ interface
FOnGetSocketHandler : TGetSocketHandlerEvent;
FAfterSocketHandlerCreated : TSocketHandlerCreatedEvent;
FProxy : TProxyData;
FVerifySSLCertificate: Boolean;
function CheckContentLength: Int64;
function CheckTransferEncoding: string;
function GetCookies: TStrings;
......@@ -113,7 +111,8 @@ interface
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 @@ interface
// 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 @@ interface
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 @@ interface
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 @@ interface
Property OnHeaders;
Property OnGetSocketHandler;
Property Proxy;
Property VerifySSLCertificate;
Property AfterSocketHandlerCreate;
Property OnVerifySSLCertificate;
end;
EHTTPClient = Class(EHTTP);
......@@ -366,8 +373,6 @@ interface
implementation
uses sslsockets;
resourcestring
SErrInvalidProtocol = 'Invalid protocol : "%s"';
SErrReadingSocket = 'Error reading data from socket';
......@@ -585,13 +590,21 @@ function TFPCustomHTTPClient.GetServerURL(URI: TURI): String;
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 @@ function TFPCustomHTTPClient.CheckTransferEncoding: string;
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
......
......@@ -40,6 +40,8 @@ interface
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 @@ function TGNUTLSSocketHandler.Connect: Boolean;
exit;
Result:=DoHandShake;
if Result and VerifyPeerCert then
Result:=(not DoVerifyCert);
Result:=DoVerifyCert;
if Result then
SetSSLActive(True);
end;
......@@ -480,8 +482,8 @@ function TGNUTLSSocketHandler.InitSslKeys: boolean;
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 @@ function TGNUTLSSocketHandler.BytesAvailable: Integer;
Result:=FGNUTLSLastError;
end;
function TGNUTLSSocketHandler.GetLastSSLErrorString: String;
begin
Result:=FGNUTLSLastErrorString;
end;
function TGNUTLSSocketHandler.GetLastSSLErrorCode: Integer;
begin
Result:=FGNUTLSLastError;
end;
initialization
TSSLSocketHandler.SetDefaultHandlerClass(TGNUTLSSocketHandler);
end.
......
......@@ -25,6 +25,8 @@ interface
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 @@ function TOpenSSLSocketHandler.InitSslKeys: boolean;
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;
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment