diff --git a/packages/fcl-net/src/sslbase.pp b/packages/fcl-net/src/sslbase.pp index dc93c670c8..13237744af 100644 --- a/packages/fcl-net/src/sslbase.pp +++ b/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 } diff --git a/packages/fcl-net/src/sslsockets.pp b/packages/fcl-net/src/sslsockets.pp index 9d75856ade..7a4ae8ce5c 100644 --- a/packages/fcl-net/src/sslsockets.pp +++ b/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; diff --git a/packages/fcl-net/src/ssockets.pp b/packages/fcl-net/src/ssockets.pp index 21a5ed83d9..973aea40e3 100644 --- a/packages/fcl-net/src/ssockets.pp +++ b/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. diff --git a/packages/fcl-web/examples/httpclient/httpget.pas b/packages/fcl-web/examples/httpclient/httpget.pas index 0fc118e695..3dbfc9001a 100644 --- a/packages/fcl-web/examples/httpclient/httpget.pas +++ b/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 diff --git a/packages/fcl-web/src/base/fphttpclient.pp b/packages/fcl-web/src/base/fphttpclient.pp index ca535d7323..fdecc9e0af 100644 --- a/packages/fcl-web/src/base/fphttpclient.pp +++ b/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 diff --git a/packages/gnutls/src/gnutlssockets.pp b/packages/gnutls/src/gnutlssockets.pp index 9f47ded8c4..337264b625 100644 --- a/packages/gnutls/src/gnutlssockets.pp +++ b/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. diff --git a/packages/openssl/src/opensslsockets.pp b/packages/openssl/src/opensslsockets.pp index 3f1e254d26..9a8c84373f 100644 --- a/packages/openssl/src/opensslsockets.pp +++ b/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;