paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-06 10:07:54 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Fix bug #37980: correct verifypeercert

Browse Source 
git-svn-id: trunk@47340 -
This commit is contained in:
michael 2020-11-08 12:56:55 +00:00
parent 4fa3362355
commit 5ec7ffa8d9
7 changed files with 130 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
packages/fcl-net/src/sslbase.pp
View File

@ -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 }

19
packages/fcl-net/src/sslsockets.pp
View File

@ -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;

19
packages/fcl-net/src/ssockets.pp
View File

@ -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.

33
packages/fcl-web/examples/httpclient/httpget.pas
View File

@ -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

45
packages/fcl-web/src/base/fphttpclient.pp
View File

@ -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

18
packages/gnutls/src/gnutlssockets.pp
View File

@ -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.

16
packages/openssl/src/opensslsockets.pp
View File

@ -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;