From b0c264948e307ef375c264bfb1e1e35c46b4ae97 Mon Sep 17 00:00:00 2001 From: michael Date: Sat, 5 Jan 2019 12:37:44 +0000 Subject: [PATCH] * Rework SSL handling to be pluggable, add HTTPS support to fphttpserver git-svn-id: trunk@40769 - --- .gitattributes | 2 + packages/fcl-net/fpmake.pp | 2 +- packages/fcl-net/src/sslbase.pp | 242 +++++++++ packages/fcl-net/src/sslsockets.pp | 487 +++++------------- packages/fcl-net/src/ssockets.pp | 36 +- .../fcl-web/examples/httpclient/httpget.pas | 2 +- .../fcl-web/examples/httpclient/httppost.pp | 2 +- .../examples/httpclient/httppostfile.pp | 2 +- .../fcl-web/examples/httpclient/keepalive.pp | 2 +- .../examples/simpleserver/simpleserver.lpi | 23 +- .../examples/simpleserver/simpleserver.pas | 10 +- packages/fcl-web/fpmake.pp | 1 + packages/fcl-web/src/base/custhttpapp.pp | 56 ++ packages/fcl-web/src/base/fphttpclient.pp | 11 +- packages/fcl-web/src/base/fphttpserver.pp | 103 +++- packages/openssl/fpmake.pp | 4 + packages/openssl/src/fpopenssl.pp | 311 +++++++---- packages/openssl/src/openssl.pas | 149 +++++- packages/openssl/src/opensslsockets.pp | 321 ++++++++++++ 19 files changed, 1277 insertions(+), 489 deletions(-) create mode 100644 packages/fcl-net/src/sslbase.pp create mode 100644 packages/openssl/src/opensslsockets.pp diff --git a/.gitattributes b/.gitattributes index d4eca08718..27c7a1dcc7 100644 --- a/.gitattributes +++ b/.gitattributes @@ -2604,6 +2604,7 @@ packages/fcl-net/src/netware/resolve.inc svneol=native#text/plain packages/fcl-net/src/netwlibc/resolve.inc svneol=native#text/plain packages/fcl-net/src/os2/resolve.inc svneol=native#text/plain packages/fcl-net/src/resolve.pp svneol=native#text/plain +packages/fcl-net/src/sslbase.pp svneol=native#text/plain packages/fcl-net/src/sslsockets.pp svneol=native#text/plain packages/fcl-net/src/ssockets.pp svneol=native#text/plain packages/fcl-net/src/unix/resolve.inc svneol=native#text/plain @@ -6711,6 +6712,7 @@ packages/openssl/examples/test1.pas svneol=native#text/plain packages/openssl/fpmake.pp svneol=native#text/plain packages/openssl/src/fpopenssl.pp svneol=native#text/plain packages/openssl/src/openssl.pas svneol=native#text/plain +packages/openssl/src/opensslsockets.pp svneol=native#text/plain packages/oracle/Makefile svneol=native#text/plain packages/oracle/Makefile.fpc svneol=native#text/plain packages/oracle/Makefile.fpc.fpcmake svneol=native#text/plain diff --git a/packages/fcl-net/fpmake.pp b/packages/fcl-net/fpmake.pp index e7316947c1..ebd7129805 100644 --- a/packages/fcl-net/fpmake.pp +++ b/packages/fcl-net/fpmake.pp @@ -19,7 +19,6 @@ begin {$endif ALLPACKAGES} P.Version:='3.3.1'; P.Dependencies.Add('fcl-base'); - P.Dependencies.Add('openssl',AllUnixOSes+AllWindowsOSes); P.Dependencies.Add('fcl-xml'); P.Dependencies.Add('fcl-passrc'); P.Dependencies.Add('fcl-async',[linux,freebsd,netbsd,openbsd,dragonfly]); @@ -44,6 +43,7 @@ begin // IP and Sockets T:=P.Targets.AddUnit('netdb.pp',AllUnixOSes); + T:=P.Targets.AddUnit('sslbase.pp'); T:=P.Targets.AddUnit('resolve.pp',AllUnixOSes+AllWindowsOSes+AllAmigaLikeOSes+[OS2,EMX]); with T.Dependencies do begin diff --git a/packages/fcl-net/src/sslbase.pp b/packages/fcl-net/src/sslbase.pp new file mode 100644 index 0000000000..dc93c670c8 --- /dev/null +++ b/packages/fcl-net/src/sslbase.pp @@ -0,0 +1,242 @@ +unit sslbase; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils; + +Type + TSSLType = (stAny,stSSLv2,stSSLv3,stTLSv1,stTLSv1_1,stTLSv1_2); + + { TSSLData } + + TSSLData = Class(TPersistent) + private + FFileName: String; + FValue: TBytes; + Public + Function Empty : Boolean; + Procedure Assign(Source : TPersistent);override; + Property FileName : String Read FFileName Write FFileName; + Property Value: TBytes Read FValue Write FValue; + end; + +Const + SSLDataCount = 4; // 0 based. + StrDataCount = 2; // 0 based. + +Type + { TSSLSocketHandler } + + { TCertificateData } + + TCertificateData = Class(TPersistent) + Private + FStrData : Array[0..StrDataCount] of string; + FCertData : Array[0..SSLDataCount] of TSSLData; + function GetSSLData(AIndex: Integer): TSSLData; + procedure SetSSLData(AIndex: Integer; AValue: TSSLData); + function GetString(AIndex: Integer): String; + procedure SetString(AIndex: Integer; AValue: String); + Public + constructor Create; + Destructor Destroy; override; + Procedure Assign(Source : TPersistent); override; + Function NeedCertificateData : Boolean; + Published + property KeyPassword: string Index 0 read GetString write SetString; + property CipherList: string Index 1 read GetString write SetString; + Property HostName : String Index 2 read GetString write SetString; + property Certificate : TSSLData Index 0 Read GetSSLData Write SetSSLData; + property TrustedCertificate : TSSLData Index 1 Read GetSSLData Write SetSSLData; + 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; + end; + + { TX509Certificate } + TCertAndKey = Record + Certificate : TBytes; + PrivateKey : TBytes; + end; + + TX509Certificate = Class (TObject) + private + FCommonName: string; + FCountry: String; + FHostName: string; + FKeySize: Integer; + FOrganization: String; + FSerial: Integer; + FValidFrom: TDateTime; + FValidTo: TDateTime; + FVersion: Integer; + function GetKeySize: Integer; + function GetValidFrom: TDateTime; + function GetValidTo: TDateTime; + function GetVersion: Integer; + Protected + Function GetRealSerial : Integer; + Public + Function CreateCertificateAndKey : TCertAndKey; virtual; abstract; + Procedure CreateCertificateAndKey(Var aCertificate,aKey : TBytes); + Property Country : String Read FCountry Write FCountry; + Property HostName : string Read FHostName Write FHostName; + Property CommonName : string Read FCommonName Write FCommonName; + Property Organization : String Read FOrganization Write FOrganization; + Property KeySize : Integer Read GetKeySize Write FKeySize; + // Valid from. Default today -1; + Property ValidFrom : TDateTime Read GetValidFrom Write FValidFrom; + // Valid To. Default today + 31; + Property ValidTo : TDateTime Read GetValidTo Write FValidTo; + // Version Default 1. + Property Version : Integer Read GetVersion Write FVersion; + // Serial. If zero, then a serial is generated. + Property Serial : Integer Read FSerial Write FSerial; + + end; + +implementation + +{ TSSLData } + +Function TSSLData.Empty: Boolean; +begin + Result:=(Length(Value)=0) and (FileName=''); +end; + +Procedure TSSLData.Assign(Source: TPersistent); + +begin + if Source is TSSLData then + With TSSLData(Source) do + begin + Self.FValue:=FValue; + Self.FFileName:=FFileName; + end + else + inherited Assign(Source); +end; + +{ TCertificateData } + +function TCertificateData.GetSSLData(AIndex: Integer): TSSLData; +begin + Result:=FCertData[AIndex]; +end; + +procedure TCertificateData.SetSSLData(AIndex: Integer; AValue: TSSLData); +begin + FCertData[AIndex].Assign(AValue); +end; + +function TCertificateData.GetString(AIndex: Integer): String; +begin + Result:=FStrData[AIndex]; + if (AIndex=2) and (result='') then + Result:='localhost'; +end; + +procedure TCertificateData.SetString(AIndex: Integer; AValue: String); +begin + FStrData[AIndex]:=aValue; +end; + +constructor TCertificateData.Create; + +Var + I : Integer; + +begin + CipherList:='DEFAULT'; + HostName:='localhost'; + For I:=0 to SSLDataCount do + FCertData[i]:=TSSLData.Create; +end; + +destructor TCertificateData.Destroy; + +Var + I : Integer; + +begin + For I:=0 to SSLDataCount do + FreeAndNil(FCertData[i]); + inherited Destroy; +end; + +procedure TCertificateData.Assign(Source: TPersistent); + +Var + CD : TCertificateData; + I : Integer; + +begin + if Source is TCertificateData then + begin + CD:=Source as TCertificateData; + For I:=0 to StrDataCount do + FStrData[i]:=CD.FStrData[i]; + For I:=0 to SSLDataCount do + FCertData[i].Assign(CD.FCertData[i]) + end + else + inherited Assign(Source); +end; + +function TCertificateData.NeedCertificateData: Boolean; +begin + Result:=Certificate.Empty and PFX.Empty; +end; + +function TX509Certificate.GetKeySize: Integer; +begin + Result:=FKeySize; + if Result=0 then + Result:=1024; +end; + +function TX509Certificate.GetValidFrom: TDateTime; +begin + Result:=FValidFrom; + If Result=0 then + Result:=Date-1; +end; + +function TX509Certificate.GetValidTo: TDateTime; +begin + Result:=FValidTo; + If Result=0 then + Result:=Date+31; +end; + + +function TX509Certificate.GetVersion: Integer; +begin + Result:=FVersion; + if FVersion=0 then + FVersion:=1; +end; + +function TX509Certificate.GetRealSerial: Integer; +begin + Result:=FSerial; + if Result=0 then + Result:=10; // MinutesBetween(Now,EncodeDate(2019,1,1)); +end; + +procedure TX509Certificate.CreateCertificateAndKey(var aCertificate, aKey: TBytes); + +Var + CK : TCertAndKey; + +begin + CK:=CreateCertificateAndKey; + aCertificate:=CK.Certificate; + aKey:=CK.PrivateKey; +end; + +end. + diff --git a/packages/fcl-net/src/sslsockets.pp b/packages/fcl-net/src/sslsockets.pp index cab9882d3b..382919c64d 100644 --- a/packages/fcl-net/src/sslsockets.pp +++ b/packages/fcl-net/src/sslsockets.pp @@ -19,109 +19,137 @@ unit sslsockets; interface uses - Classes, SysUtils, sockets, ssockets, openssl, fpopenssl; + Classes, SysUtils, sockets, ssockets, sslbase; Const - SSLDataCount = 4; // 0 based. + SUseCertData = 'use CertificateData instead'; Type + ESSLSocketError = Class(ESocketError); + TSSLSocketHandler = class; TVerifyCertificateEvent = Procedure(Sender : TObject; Allow : Boolean) of object; + TSSLSocketHandlerClass = class of TSSLSocketHandler; + { TSSLSocketHandler } TSSLSocketHandler = class(TSocketHandler) private - FRemoteHostName: String; - FSSLLastErrorString: string; - FCipherList: string; + FCertGenerator: TX509Certificate; + FCertificateData: TCertificateData; FVerifyPeerCert: Boolean; FOnVerifyCertificate: TVerifyCertificateEvent; FSSLType: TSSLType; - FKeyPassword: string; - FUsername: string; - FPassword: string; - FCertData : Array[0..4] of TSSLData; - FSSL: TSSL; - FCTX : TSSLContext; FSSLActive : Boolean; FSendHostAsSNI : Boolean; function GetSSLData(AIndex: Integer): TSSLData; + function GetString(AIndex: Integer): string; + procedure SetCertificateData(AValue: TCertificateData); procedure SetSSLData(AIndex: Integer; AValue: TSSLData); - procedure SetSSLLastErrorString(AValue: string); + procedure SetString(AIndex: Integer; AValue: string); + Private + Class Var FDefaultHandlerClass : TSSLSocketHandlerClass; protected - Function FetchErrorInfo: Boolean; - function CheckSSL(SSLResult: Integer): Boolean; - function CheckSSL(SSLResult: Pointer): Boolean; - function InitContext(NeedCertificate: Boolean): Boolean; virtual; - function DoneContext: Boolean; virtual; - function InitSslKeys: boolean;virtual; - function DoVerifyCert:boolean; + Procedure SetSSLActive(aValue : Boolean); + function DoVerifyCert: boolean; public constructor Create; override; Destructor Destroy; override; + // Class factory methods + Class Procedure SetDefaultHandlerClass(aClass : TSSLSocketHandlerClass); + Class Function GetDefaultHandlerClass : TSSLSocketHandlerClass; + Class Function GetDefaultHandler : TSSLSocketHandler; // Socket methods - function Connect : Boolean; override; - function Close : Boolean; override; - function Accept : Boolean; override; - function Shutdown(BiDirectional : Boolean): boolean; override; - function Send(Const Buffer; Count: Integer): Integer; override; - function Recv(Const Buffer; Count: Integer): Integer; override; - function BytesAvailable: Integer; override; - Function SSLActive: Boolean; - function CreateSelfSignedCertificate(Const AHostName: string): Boolean; virtual; - // Result of last CheckSSL call. - Function SSLLastError: integer; - property SSLLastErrorString: string read FSSLLastErrorString write SetSSLLastErrorString; + Function CreateCertificateData : TCertificateData; virtual; + Function CreateCertGenerator : TX509Certificate; virtual; + function CreateSelfSignedCertificate: Boolean; virtual; + Property CertGenerator : TX509Certificate Read FCertGenerator; + Property SSLActive: Boolean read FSSLActive; published property SSLType: TSSLType read FSSLType write FSSLType; - {:Password for decrypting of encoded certificate or key.} - property Username: string read FUsername write FUsername; - property Password: string read FPassword write FPassword; - property KeyPassword: string read FKeyPassword write FKeyPassword; - property CipherList: string read FCipherList write FCipherList; - property Certificate : TSSLData Index 0 Read GetSSLData Write SetSSLData; - property TrustedCertificate : TSSLData Index 1 Read GetSSLData Write SetSSLData; - 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; property VerifyPeerCert: Boolean read FVerifyPeerCert Write FVerifyPeerCert; Property SendHostAsSNI : Boolean Read FSendHostAsSNI Write FSendHostAsSNI; + Property CertificateData : TCertificateData Read FCertificateData Write SetCertificateData; + // Deprecated, use CertificateData instead. + property KeyPassword: string Index 0 read GetString write SetString; deprecated 'use CertificateData instead'; + property CipherList: string Index 1 read GetString write SetString; deprecated 'use CertificateData instead'; // In case a certificate must be generated as server, this is the hostname that will be used. - property RemoteHostName : String Read FRemoteHostName Write FRemoteHostName; + property RemoteHostName : String Index 2 read GetString write SetString; deprecated 'use CertificateData instead'; + property Certificate : TSSLData Index 0 Read GetSSLData Write SetSSLData; deprecated 'use CertificateData instead'; + property TrustedCertificate : TSSLData Index 1 Read GetSSLData Write SetSSLData;deprecated 'use CertificateData instead'; + property PrivateKey : TSSLData Index 2 Read GetSSLData Write SetSSLData;deprecated 'use CertificateData instead'; + property PFX: TSSLData Index 3 Read GetSSLData Write SetSSLData;deprecated 'use CertificateData instead'; + property CertCA: TSSLData Index 4 Read GetSSLData Write SetSSLData;deprecated 'use CertificateData instead'; property OnVerifyCertificate: TVerifyCertificateEvent read FOnVerifyCertificate write FOnVerifyCertificate; end; + implementation -{ TSocketHandler } Resourcestring - SErrNoLibraryInit = 'Could not initialize OpenSSL library'; - -Procedure MaybeInitSSLInterface; - -begin - if not IsSSLloaded then - if not InitSSLInterface then - Raise EInOutError.Create(SErrNoLibraryInit); -end; - + SErrNoSSLSupport = + 'No SSL Socket support compiled in.'+sLineBreak+ + 'Please include opensslsockets unit in program and recompile it.'; + SErrNoX509Certificate = + 'Cannot create a X509 certificate without SLL support'; { TSSLSocketHandler } + function TSSLSocketHandler.GetSSLData(AIndex: Integer): TSSLData; begin - Result:=FCertData[AIndex]; + Case aIndex of + 0 : Result:=FCertificateData.Certificate; + 1 : Result:=FCertificateData.TrustedCertificate; + 2 : Result:=FCertificateData.PrivateKey; + 3 : Result:=FCertificateData.PFX; + 4 : Result:=FCertificateData.CertCA; + end; +end; + +function TSSLSocketHandler.GetString(AIndex: Integer): string; +begin + Case AIndex of + 0 : Result:=FCertificateData.KeyPassword; + 1 : Result:=FCertificateData.CipherList; + 2 : Result:=FCertificateData.HostName; + end; +end; + +procedure TSSLSocketHandler.SetCertificateData(AValue: TCertificateData); +begin + if FCertificateData=AValue then Exit; + FCertificateData.Assign(AValue); end; procedure TSSLSocketHandler.SetSSLData(AIndex: Integer; AValue: TSSLData); begin - FCertData[AIndex].Assign(AValue); + Case aIndex of + 0 : FCertificateData.Certificate:=AValue; + 1 : FCertificateData.TrustedCertificate:=AValue; + 2 : FCertificateData.PrivateKey:=AValue; + 3 : FCertificateData.PFX:=AValue; + 4 : FCertificateData.CertCA:=AValue; + end; end; -procedure TSSLSocketHandler.SetSSLLastErrorString(AValue: string); + + +procedure TSSLSocketHandler.SetString(AIndex: Integer; AValue: string); begin - if FSSLLastErrorString=AValue then Exit; - FSSLLastErrorString:=AValue; + Case AIndex of + 0 : FCertificateData.KeyPassword:=AValue; + 1 : FCertificateData.CipherList:=AValue; + 2 : begin + FCertificateData.HostName:=AValue; + FCertGenerator.HostName:=aValue; + end; + end; +end; + +procedure TSSLSocketHandler.SetSSLActive(aValue: Boolean); +begin + FSSLActive:=aValue; end; @@ -134,329 +162,60 @@ end; constructor TSSLSocketHandler.Create; -Var - I : Integer; begin inherited Create; FSendHostAsSNI:=True; - MaybeInitSSLInterface; - FCipherList:='DEFAULT'; - For I:=0 to SSLDataCount do - FCertData[i]:=TSSLData.Create; + FCertGenerator:=CreateCertGenerator; + FCertificateData:=CreateCertificateData; end; Destructor TSSLSocketHandler.Destroy; -Var - I : Integer; - begin - FreeAndNil(FSSL); - FreeAndNil(FCTX); + FreeAndNil(FCertificateData); + FreeAndNil(FCertGenerator); inherited Destroy; - For I:=0 to SSLDataCount do - FreeAndNil(FCertData[i]); end; -function TSSLSocketHandler.CreateSelfSignedCertificate(Const AHostName: string): Boolean; +class procedure TSSLSocketHandler.SetDefaultHandlerClass(aClass: TSSLSocketHandlerClass); +begin + FDefaultHandlerClass:=aClass; +end; -Const - OneDay = 60*60*24; - SixtyDays = 60*OneDay; +class function TSSLSocketHandler.GetDefaultHandlerClass: TSSLSocketHandlerClass; +begin + Result:=FDefaultHandlerClass; +end; -var - PK : PEVP_PKEY; - X509 : PX509; - RSA : PRSA; - UTC : PASN1_UTCTIME; - SN : PX509_NAME; - B : PBIO; +class function TSSLSocketHandler.GetDefaultHandler: TSSLSocketHandler; +begin + if FDefaultHandlerClass=Nil then + Raise ESSLSocketError.Create(SErrNoSSLSupport); + Result:=FDefaultHandlerClass.Create; +end; + +function TSSLSocketHandler.CreateCertificateData: TCertificateData; +begin + Result:=TCertificateData.Create; +end; + +function TSSLSocketHandler.CreateCertGenerator: TX509Certificate; +begin + Raise ESSLSocketError.Create(SErrNoX509Certificate); +end; + +function TSSLSocketHandler.CreateSelfSignedCertificate: Boolean; + +Var + CK:TCertAndKey; begin - Result:=False; - PK:=Nil; - X509:=Nil; - try - PK:=EvpPkeynew; - X509:=X509New; - RSA:=RsaGenerateKey(1024,$10001,nil,nil); - EvpPkeyAssign(PK,EVP_PKEY_RSA,RSA); - X509SetVersion(X509,2); - Asn1IntegerSet(X509getSerialNumber(X509),0); - UTC:=Asn1UtctimeNew; - try - X509GmtimeAdj(UTC,-OneDay); - X509SetNotBefore(X509,UTC); - X509GmtimeAdj(UTC,SixtyDays); - X509SetNotAfter(X509,UTC); - finally - Asn1UtctimeFree(UTC); - end; - X509SetPubkey(X509,PK); - SN:=X509GetSubjectName(X509); - X509NameAddEntryByTxt(SN,'C',$1001,'CZ',-1,-1,0); - X509NameAddEntryByTxt(SN,'CN',$1001, AHostName,-1,-1,0); - x509SetIssuerName(X509,SN); - x509Sign(X509,PK,EvpGetDigestByName('SHA1')); - B:=BioNew(BioSMem); - try - i2dX509Bio(B,X509); - Certificate.Value:=BioToString(B); - finally - BioFreeAll(b); - end; - B:=BioNew(BioSMem); - try - i2dPrivatekeyBio(B,PK); - Privatekey.Value:=BioToString(B); - finally - BioFreeAll(b); - end; - finally - X509free(X509); - EvpPkeyFree(PK); - end; + CK:=CertGenerator.CreateCertificateAndKey; + CertificateData.Certificate.Value:=CK.Certificate; + CertificateData.PrivateKey.Value:=CK.PrivateKey; + Result:=(Length(CK.Certificate)<>0) and (Length(CK.PrivateKey)<>0); end; -function TSSLSocketHandler.Connect: Boolean; -begin - Result:=Inherited Connect; - Result := Result and InitContext(False); - if Result then - begin - Result:=CheckSSL(FSSL.SetFD(FSocket.Handle)); - if Result then - begin - if FSendHostAsSNI and (FSocket is TInetSocket) then - FSSL.Ctrl(SSL_CTRL_SET_TLSEXT_HOSTNAME,TLSEXT_NAMETYPE_host_name,PAnsiChar(AnsiString((FSocket as TInetSocket).Host))); - Result:=CheckSSL(FSSL.Connect); - if Result and VerifyPeerCert then - Result:=(FSSL.VerifyResult<>0) or (not DoVerifyCert); - if Result then - FSSLActive:=True; - end; - end; -end; - -function TSSLSocketHandler.Close: Boolean; -begin - Result:=Shutdown(False); -end; - -Function TSSLSocketHandler.FetchErrorInfo : Boolean; - -var - S : AnsiString; - -begin - FSSLLastErrorString:=''; - FLastError:=ErrGetError; - ErrClearError; - Result:=(FLastError<>0); - if not Result then - begin - S:=StringOfChar(#0,256); - ErrErrorString(FLastError,S,256); - FSSLLastErrorString:=s; - end; -end; - -function TSSLSocketHandler.CheckSSL(SSLResult : Integer) : Boolean; - -begin - Result:=SSLResult>=1; - if Not Result then - begin - FLastError:=SSLResult; - FetchErrorInfo; - end; -end; - -function TSSLSocketHandler.CheckSSL(SSLResult: Pointer): Boolean; -begin - Result:=(SSLResult<>Nil); - if not Result then - Result:=FetchErrorInfo; -end; - -function TSSLSocketHandler.DoneContext: Boolean; - -begin - FreeAndNil(FSSL); - FreeAndNil(FCTX); - ErrRemoveState(0); - FSSLActive:=False; - Result:=True; -end; - -Function HandleSSLPwd(buf : PAnsiChar; len:Integer; flags:Integer; UD : Pointer):Integer; cdecl; - -var - Pwd: AnsiString; - H : TSSLSocketHandler; - -begin - if Not Assigned(UD) then - PWD:='' - else - begin - H:=TSSLSocketHandler(UD); - Pwd:=H.KeyPassword; - end; - if (lenNil); - if not Result then - Exit; - if not Certificate.Empty then - Result:=CheckSSL(FCTX.UseCertificate(Certificate)); - if Result and not PrivateKey.Empty then - Result:=CheckSSL(FCTX.UsePrivateKey(PrivateKey)); - if Result and (CertCA.FileName<>'') then - Result:=CheckSSL(FCTX.LoadVerifyLocations(CertCA.FileName,'')); - if Result and not PFX.Empty then - Result:=CheckSSL(FCTX.LoadPFX(PFX,Self.KeyPassword)); -end; - -function TSSLSocketHandler.InitContext(NeedCertificate:Boolean): Boolean; - -Const - VO : Array[Boolean] of Integer = (SSL_VERIFY_NONE,SSL_VERIFY_PEER); - -var - s: AnsiString; - -begin - Result:=DoneContext; - if Not Result then - Exit; - try - FCTX:=TSSLContext.Create(SSLType); - Except - CheckSSL(Nil); - Result:=False; - Exit; - end; - S:=FCipherList; - FCTX.SetCipherList(S); - FCTX.SetVerify(VO[FVerifypeerCert],Nil); - FCTX.SetDefaultPasswdCb(@HandleSSLPwd); - FCTX.SetDefaultPasswdCbUserdata(self); - If NeedCertificate and Certificate.Empty and PFX.Empty then - if Not CreateSelfSignedCertificate(RemoteHostName) then - begin - DoneContext; - Exit(False); - end; - if Not InitSSLKeys then - begin - DoneContext; - Exit(False); - end; - try - FSSL:=TSSL.Create(FCTX); - Result:=True; - Except - CheckSSL(Nil); - DoneContext; - Result:=False; - end; -end; - -function TSSLSocketHandler.Accept: Boolean; - -begin - Result:=InitContext(True); - if Result then - begin - Result:=CheckSSL(FSSL.setfd(Socket.Handle)); - if Result then - Result:=CheckSSL(FSSL.Accept); - end; - FSSLActive:=Result; -end; - -function TSSLSocketHandler.Shutdown(BiDirectional : Boolean): boolean; - -var - r : integer; - -begin - Result:=assigned(FSsl); - if Result then - If Not BiDirectional then - Result:=CheckSSL(FSSL.Shutdown) - else - begin - r:=FSSL.Shutdown; - if r<>0 then - Result:=CheckSSL(r) - else - begin - Result:=fpShutdown(FSocket.Handle,1)=0; - if Result then - Result:=CheckSSL(FSsl.Shutdown); - end - end; - If Result then - Result:=DoneContext; -end; - -function TSSLSocketHandler.Send(Const Buffer; Count: Integer): Integer; -var - e: integer; -begin - FLastError := 0; - FSSLLastErrorString:=''; - repeat - Result:=FSsl.Write(@Buffer,Count); - e:=FSsl.GetError(Result); - until Not (e in [SSL_ERROR_WANT_READ,SSL_ERROR_WANT_WRITE]); - if (E=SSL_ERROR_ZERO_RETURN) then - Result:=0 - else if (e<>0) then - FLastError:=e; -end; - -function TSSLSocketHandler.Recv(Const Buffer; Count: Integer): Integer; - -var - e: integer; -begin - FLastError:=0; - FSSLLastErrorString:= ''; - repeat - Result:=FSSL.Read(@Buffer ,Count); - e:=FSSL.GetError(Result); - until Not (e in [SSL_ERROR_WANT_READ,SSL_ERROR_WANT_WRITE]); - if (E=SSL_ERROR_ZERO_RETURN) then - Result:=0 - else if (e<>0) then - FLastError:=e; -end; - -function TSSLSocketHandler.BytesAvailable: Integer; -begin - Result:= FSSL.Pending; -end; - -Function TSSLSocketHandler.SSLActive: Boolean; -begin - Result:=FSSLActive; -end; - -Function TSSLSocketHandler.SSLLastError: integer; -begin - Result:=FLastError; -end; end. diff --git a/packages/fcl-net/src/ssockets.pp b/packages/fcl-net/src/ssockets.pp index d55c253b87..1bd158d6e6 100644 --- a/packages/fcl-net/src/ssockets.pp +++ b/packages/fcl-net/src/ssockets.pp @@ -45,24 +45,26 @@ type TAcceptErrorAction = (aeaRaise,aeaIgnore,aeaStop); TSocketStream = Class; + TSocketServer = Class; // Handles all OS calls { TSocketHandler } TSocketHandler = Class(TObject) + Private + FServer: TSocketServer; FSocket: TSocketStream; - FLastError : integer; Protected + FLastError : integer; Procedure SetSocket(const AStream: TSocketStream); virtual; Procedure CheckSocket; Public constructor Create; virtual; // Called after the connect call succeded. Returns True to continue, false to close connection. function Connect: boolean; virtual; - // Called after the accept call succeded. + // Called after the accept call succeded on the NEW client socket function Accept : Boolean; virtual; - Function Close : Boolean; virtual; function Shutdown(BiDirectional : Boolean): boolean; virtual; function Recv(Const Buffer; Count: Integer): Integer; virtual; @@ -111,6 +113,7 @@ type TConnectEvent = Procedure (Sender : TObject; Data : TSocketStream) Of Object; TConnectQuery = Procedure (Sender : TObject; ASocket : Longint; Var Allow : Boolean) of Object; TOnAcceptError = Procedure (Sender : TObject; ASocket : Longint; E : Exception; Var ErrorAction : TAcceptErrorAction) of Object; + TGetClientSocketHandlerEvent = Procedure (Sender : TObject; Out AHandler : TSocketHandler) of object; { TSocketServer } @@ -118,6 +121,7 @@ type Private FIdleTimeOut: Cardinal; FOnAcceptError: TOnAcceptError; + FOnCreateClientSocketHandler: TGetClientSocketHandlerEvent; FOnIdle : TNotifyEvent; FNonBlocking : Boolean; FSocket : longint; @@ -148,6 +152,7 @@ type Function RunIdleLoop : Boolean; function GetConnection: TSocketStream; virtual; abstract; Function HandleAcceptError(E : ESocketError) : TAcceptErrorAction; + Function GetClientSocketHandler(aSocket : Longint) : TSocketHandler; virtual; Property Handler : TSocketHandler Read FHandler; Public Constructor Create(ASocket : Longint; AHandler : TSocketHandler); @@ -176,6 +181,7 @@ type // Accept Timeout in milliseconds. // If Different from 0, then there will be an idle loop before accepting new connections, Calling OnIdle if no new connection appeared in the specified timeout. Property AcceptIdleTimeOut : Cardinal Read FIdleTimeOut Write FIdleTimeout; + Property OnCreateClientSocketHandler : TGetClientSocketHandlerEvent Read FOnCreateClientSocketHandler Write FOnCreateClientSocketHandler; end; { TInetServer } @@ -256,6 +262,7 @@ type end; {$endif} + Implementation uses @@ -379,6 +386,7 @@ begin Result:=True; end; + constructor ESocketError.Create(ACode: TSocketErrorType; const MsgArgs: array of const); var s: String; @@ -658,6 +666,15 @@ begin FOnAcceptError(Self,FSocket,E,Result); end; +function TSocketServer.GetClientSocketHandler(aSocket : Longint): TSocketHandler; +begin + If Assigned(FOnCreateClientSocketHandler) then + FOnCreateClientSocketHandler(Self,Result) + else + if Assigned(FHandler) then + Result:=TSocketHandlerClass(FHandler.ClassType).Create; +end; + procedure TSocketServer.StartAccepting; Var @@ -856,10 +873,19 @@ end; Function TInetServer.SockToStream (ASocket : Longint) : TSocketStream; +Var + H : TSocketHandler; + begin - Result:=TInetSocket.Create(ASocket); + H:=GetClientSocketHandler(aSocket); + Result:=TInetSocket.Create(ASocket,H); (Result as TInetSocket).FHost:=''; (Result as TInetSocket).FPort:=FPort; + if Not H.Accept then + begin + H.Shutdown(False); + FreeAndNil(Result); + end; end; Function TInetServer.Accept : Longint; @@ -882,7 +908,7 @@ begin If R=ESysEWOULDBLOCK then Raise ESocketError.Create(seAcceptWouldBlock,[socket]); {$endif} - if (Result<0) or Not (FAccepting and FHandler.Accept) then + if (Result<0) or Not FAccepting then begin If (Result>=0) then CloseSocket(Result); diff --git a/packages/fcl-web/examples/httpclient/httpget.pas b/packages/fcl-web/examples/httpclient/httpget.pas index f8cae0aa74..0996b8566e 100644 --- a/packages/fcl-web/examples/httpclient/httpget.pas +++ b/packages/fcl-web/examples/httpclient/httpget.pas @@ -3,7 +3,7 @@ program httpget; {$mode objfpc}{$H+} uses - SysUtils, Classes, fphttpclient, sslsockets, fpopenssl; + SysUtils, Classes, fphttpclient, sslsockets, fpopenssl, opensslsockets; Type diff --git a/packages/fcl-web/examples/httpclient/httppost.pp b/packages/fcl-web/examples/httpclient/httppost.pp index 9ecc3b1c08..a227fe2479 100644 --- a/packages/fcl-web/examples/httpclient/httppost.pp +++ b/packages/fcl-web/examples/httpclient/httppost.pp @@ -3,7 +3,7 @@ program httppost; {$mode objfpc}{$H+} uses - SysUtils, Classes, fphttpclient; + SysUtils, Classes, fphttpclient, opensslsockets; Var F : TFileStream; diff --git a/packages/fcl-web/examples/httpclient/httppostfile.pp b/packages/fcl-web/examples/httpclient/httppostfile.pp index 4d3202a64f..0dafad7339 100644 --- a/packages/fcl-web/examples/httpclient/httppostfile.pp +++ b/packages/fcl-web/examples/httpclient/httppostfile.pp @@ -3,7 +3,7 @@ program httppostfile; {$mode objfpc}{$H+} uses - SysUtils, Classes, fphttpclient; + SysUtils, Classes, fphttpclient, opensslsockets; Var F : TFileStream; diff --git a/packages/fcl-web/examples/httpclient/keepalive.pp b/packages/fcl-web/examples/httpclient/keepalive.pp index 877bfecd2f..f8eb1e0b81 100644 --- a/packages/fcl-web/examples/httpclient/keepalive.pp +++ b/packages/fcl-web/examples/httpclient/keepalive.pp @@ -3,7 +3,7 @@ program keepalive; {$mode objfpc}{$H+} uses - Classes, SysUtils, CustApp, fphttpclient; + Classes, SysUtils, CustApp, fphttpclient, opensslsockets; const URL_DIRECT = 'https://www.google.com/humans.txt'; diff --git a/packages/fcl-web/examples/simpleserver/simpleserver.lpi b/packages/fcl-web/examples/simpleserver/simpleserver.lpi index 46a8628d1b..93fd0fc2b1 100644 --- a/packages/fcl-web/examples/simpleserver/simpleserver.lpi +++ b/packages/fcl-web/examples/simpleserver/simpleserver.lpi @@ -4,8 +4,12 @@ + + + + @@ -20,16 +24,31 @@ + + + - + + + + + - + + + + + + + + + diff --git a/packages/fcl-web/examples/simpleserver/simpleserver.pas b/packages/fcl-web/examples/simpleserver/simpleserver.pas index b6d9700b56..c25762880f 100644 --- a/packages/fcl-web/examples/simpleserver/simpleserver.pas +++ b/packages/fcl-web/examples/simpleserver/simpleserver.pas @@ -2,7 +2,7 @@ {$h+} program simpleserver; -uses sysutils,custhttpapp, fpwebfile; +uses sysutils, custhttpapp, fpwebfile, sslbase, opensslsockets; Type @@ -48,6 +48,8 @@ begin Writeln('-p --port=NNNN TCP/IP port to listen on (default is 3000)'); Writeln('-m --mimetypes=file path of mime.types, default under unix: /etc/mime.types'); Writeln('-q --quiet Do not write diagnostic messages'); + Writeln('-s --ssl Use SSL'); + Writeln('-H --hostname=NAME set hostname for self-signed SSL certificate'); Halt(Ord(Msg<>'')); end; @@ -57,7 +59,7 @@ Var S,IndexPage,D : String; begin - S:=Checkoptions('hqd:ni:p:',['help','quiet','noindexpage','directory:','port:','indexpage:']); + S:=Checkoptions('hqd:ni:p:sH:',['help','quiet','noindexpage','directory:','port:','indexpage:','ssl','hostname:']); if (S<>'') or HasOption('h','help') then usage(S); Quiet:=HasOption('q','quiet'); @@ -66,7 +68,9 @@ begin if D='' then D:=GetCurrentDir; Log(etInfo,'Listening on port %d, serving files from directory: %s',[Port,D]); - + UseSSL:=HasOption('s','ssl'); + if HasOption('H','hostname') then + HostName:=GetOptionValue('H','hostname'); if HasOption('m','mimetypes') then MimeTypesFile:=GetOptionValue('m','mimetypes'); {$ifdef unix} diff --git a/packages/fcl-web/fpmake.pp b/packages/fcl-web/fpmake.pp index ae4365893b..befeb8c164 100644 --- a/packages/fcl-web/fpmake.pp +++ b/packages/fcl-web/fpmake.pp @@ -26,6 +26,7 @@ begin P.Dependencies.Add('fcl-net'); P.Dependencies.Add('fcl-process'); P.Dependencies.Add('fcl-fpcunit'); + P.Dependencies.Add('openssl',AllUnixOSes+AllWindowsOSes); P.Dependencies.Add('fastcgi'); P.Dependencies.Add('httpd22', AllOses - [amiga,aros,morphos]); P.Dependencies.Add('httpd24', AllOses - [amiga,aros,morphos]); diff --git a/packages/fcl-web/src/base/custhttpapp.pp b/packages/fcl-web/src/base/custhttpapp.pp index 70fedc49be..6eeb9f0ff1 100644 --- a/packages/fcl-web/src/base/custhttpapp.pp +++ b/packages/fcl-web/src/base/custhttpapp.pp @@ -51,11 +51,14 @@ Type FServer: TEmbeddedHTTPServer; function GetAllowConnect: TConnectQuery; function GetAddress: string; + function GetHostName: String; function GetIdle: TNotifyEvent; function GetIDleTimeOut: Cardinal; function GetPort: Word; function GetQueueSize: Word; function GetThreaded: Boolean; + function GetUseSSL: Boolean; + procedure SetHostName(AValue: String); procedure SetIdle(AValue: TNotifyEvent); procedure SetIDleTimeOut(AValue: Cardinal); procedure SetOnAllowConnect(const AValue: TConnectQuery); @@ -65,6 +68,7 @@ Type procedure SetThreaded(const AValue: Boolean); function GetLookupHostNames : Boolean; Procedure SetLookupHostnames(Avalue : Boolean); + procedure SetUseSSL(AValue: Boolean); protected procedure HTTPHandleRequest(Sender: TObject; var ARequest: TFPHTTPConnectionRequest; var AResponse: TFPHTTPConnectionResponse); virtual; procedure HandleRequestError(Sender: TObject; E: Exception); virtual; @@ -96,6 +100,10 @@ Type Property OnAcceptIdle : TNotifyEvent Read GetIdle Write SetIdle; // If >0, when no new connection appeared after timeout, OnAcceptIdle is called. Property AcceptIdleTimeout : Cardinal Read GetIDleTimeOut Write SetIDleTimeOut; + // Use SSL or not ? + Property UseSSL : Boolean Read GetUseSSL Write SetUseSSL; + // HostName to use when using SSL + Property HostName : String Read GetHostName Write SetHostName; end; { TCustomHTTPApplication } @@ -103,9 +111,12 @@ Type TCustomHTTPApplication = Class(TCustomWebApplication) private procedure FakeConnect; + function GetHostName: String; function GetIdle: TNotifyEvent; function GetIDleTimeOut: Cardinal; function GetLookupHostNames : Boolean; + function GetUseSSL: Boolean; + procedure SetHostName(AValue: String); procedure SetIdle(AValue: TNotifyEvent); procedure SetIDleTimeOut(AValue: Cardinal); Procedure SetLookupHostnames(Avalue : Boolean); @@ -119,6 +130,7 @@ Type procedure SetPort(const AValue: Word); procedure SetQueueSize(const AValue: Word); procedure SetThreaded(const AValue: Boolean); + procedure SetUseSSL(AValue: Boolean); protected function InitializeWebHandler: TWebHandler; override; Function HTTPHandler : TFPHTTPServerHandler; @@ -138,6 +150,10 @@ Type Property OnAcceptIdle : TNotifyEvent Read GetIdle Write SetIdle; // If >0, when no new connection appeared after timeout, OnAcceptIdle is called. Property AcceptIdleTimeout : Cardinal Read GetIDleTimeOut Write SetIDleTimeOut; + // Use SSL ? + Property UseSSL : Boolean Read GetUseSSL Write SetUseSSL; + // Hostname to use when using SSL + Property HostName : String Read GetHostName Write SetHostName; end; @@ -179,6 +195,16 @@ begin Result:=HTTPHandler.LookupHostNames; end; +function TCustomHTTPApplication.GetUseSSL: Boolean; +begin + +end; + +procedure TCustomHTTPApplication.SetHostName(AValue: String); +begin + HTTPHandler.HostName:=aValue; +end; + procedure TCustomHTTPApplication.SetIdle(AValue: TNotifyEvent); begin HTTPHandler.OnAcceptIdle:=AValue; @@ -245,6 +271,11 @@ begin HTTPHandler.Threaded:=Avalue; end; +procedure TCustomHTTPApplication.SetUseSSL(AValue: Boolean); +begin + HTTPHandler.UseSSL:=aValue; +end; + function TCustomHTTPApplication.InitializeWebHandler: TWebHandler; begin Result:=TFPHTTPServerHandler.Create(Self); @@ -265,6 +296,11 @@ begin end end; +function TCustomHTTPApplication.GetHostName: String; +begin + Result:=HTTPHandler.HostName; +end; + procedure TCustomHTTPApplication.Terminate; begin @@ -316,6 +352,11 @@ begin FServer.LookupHostNames:=AValue; end; +procedure TFPHTTPServerHandler.SetUseSSL(AValue: Boolean); +begin + FServer.UseSSL:=aValue; +end; + function TFPHTTPServerHandler.GetAllowConnect: TConnectQuery; begin Result:=FServer.OnAllowConnect; @@ -326,6 +367,11 @@ begin Result:=FServer.Address; end; +function TFPHTTPServerHandler.GetHostName: String; +begin + Result:=FServer.HostName; +end; + function TFPHTTPServerHandler.GetIdle: TNotifyEvent; begin Result:=FServer.OnAcceptIdle; @@ -351,6 +397,16 @@ begin Result:=FServer.Threaded; end; +function TFPHTTPServerHandler.GetUseSSL: Boolean; +begin + Result:=FServer.UseSSL; +end; + +procedure TFPHTTPServerHandler.SetHostName(AValue: String); +begin + FServer.HostName:=aValue; +end; + procedure TFPHTTPServerHandler.SetIdle(AValue: TNotifyEvent); begin FServer.OnAcceptIdle:=AValue; diff --git a/packages/fcl-web/src/base/fphttpclient.pp b/packages/fcl-web/src/base/fphttpclient.pp index d3a4f88ebf..dc1c38376e 100644 --- a/packages/fcl-web/src/base/fphttpclient.pp +++ b/packages/fcl-web/src/base/fphttpclient.pp @@ -41,6 +41,7 @@ Type TDataEvent = Procedure (Sender : TObject; Const ContentLength, CurrentPos : Int64) of object; // 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; TFPCustomHTTPClient = Class; @@ -95,6 +96,7 @@ Type FTerminated: Boolean; FUserName: String; FOnGetSocketHandler : TGetSocketHandlerEvent; + FAfterSocketHandlerCreated : TSocketHandlerCreatedEvent; FProxy : TProxyData; function CheckContentLength: Int64; function CheckTransferEncoding: string; @@ -326,7 +328,8 @@ Type Property OnHeaders : TNotifyEvent Read FOnHeaders Write FOnHeaders; // Called to create socket handler. If not set, or Nil is returned, a standard socket handler is created. 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; end; @@ -587,12 +590,12 @@ begin if Assigned(FonGetSocketHandler) then FOnGetSocketHandler(Self,UseSSL,Result); if (Result=Nil) then - {$if not defined(HASAMIGA)} If UseSSL then - Result:=TSSLSocketHandler.Create + Result:=TSSLSocketHandler.GetDefaultHandler else - {$endif} Result:=TSocketHandler.Create; + if Assigned(AfterSocketHandlerCreate) then + AfterSocketHandlerCreate(Self,Result); end; procedure TFPCustomHTTPClient.ConnectToServer(const AHost: String; diff --git a/packages/fcl-web/src/base/fphttpserver.pp b/packages/fcl-web/src/base/fphttpserver.pp index 48be9cf477..485fd3f792 100644 --- a/packages/fcl-web/src/base/fphttpserver.pp +++ b/packages/fcl-web/src/base/fphttpserver.pp @@ -20,7 +20,7 @@ unit fphttpserver; interface uses - Classes, SysUtils, sockets, ssockets, resolve, httpdefs; + Classes, SysUtils, sockets, sslbase, sslsockets, ssockets, resolve, httpdefs; Const ReadBufLen = 4096; @@ -30,6 +30,8 @@ Type TFPHTTPConnectionThread = Class; TFPCustomHttpServer = Class; TRequestErrorHandler = Procedure (Sender : TObject; E : Exception) of object; + TGetSocketHandlerEvent = Procedure (Sender : TObject; Const UseSSL : Boolean; Out AHandler : TSocketHandler) of object; + TSocketHandlerCreatedEvent = Procedure (Sender : TObject; AHandler : TSocketHandler) of object; { TFPHTTPConnectionRequest } @@ -104,8 +106,12 @@ Type FAcceptIdleTimeout: Cardinal; FAdminMail: string; FAdminName: string; + FAfterSocketHandlerCreated: TSocketHandlerCreatedEvent; + FCertificateData: TCertificateData; + FHostName: string; FOnAcceptIdle: TNotifyEvent; FOnAllowConnect: TConnectQuery; + FOnGetSocketHandler: TGetSocketHandlerEvent; FOnRequest: THTTPServerRequestHandler; FOnRequestError: TRequestErrorHandler; FAddress: string; @@ -117,9 +123,14 @@ Type FLookupHostNames, FThreaded: Boolean; FConnectionCount : Integer; + FUseSSL: Boolean; + procedure DoCreateClientHandler(Sender: TObject; out AHandler: TSocketHandler); function GetActive: Boolean; + function GetHostName: string; procedure SetAcceptIdleTimeout(AValue: Cardinal); procedure SetActive(const AValue: Boolean); + procedure SetCertificateData(AValue: TCertificateData); + procedure SetHostName(AValue: string); procedure SetIdle(AValue: TNotifyEvent); procedure SetOnAllowConnect(const AValue: TConnectQuery); procedure SetAddress(const AValue: string); @@ -129,6 +140,12 @@ Type procedure SetupSocket; procedure WaitForRequests; Protected + // Override this to create descendent + function CreateSSLSocketHandler: TSocketHandler; + // Override this to create descendent + Function CreateCertificateData : TCertificateData; virtual; + // Override this to create descendent + Function GetSocketHandler(Const UseSSL : Boolean) : TSocketHandler; virtual; // Override these to create descendents of the request/response instead. Function CreateRequest : TFPHTTPConnectionRequest; virtual; Function CreateResponse(ARequest : TFPHTTPConnectionRequest) : TFPHTTPConnectionResponse; virtual; @@ -189,6 +206,17 @@ Type property AdminName: string read FAdminName write FAdminName; property ServerBanner: string read FServerBanner write FServerBanner; Property LookupHostNames : Boolean Read FLookupHostNames Write FLookupHostNames; + // You need to set this if you want to use SSL + property HostName : string Read GetHostName Write SetHostName; deprecated 'Use certificatedata instead'; + // Properties to use when doing SSL handshake + Property CertificateData : TCertificateData Read FCertificateData Write SetCertificateData; + // Set to true if you want to use SSL + Property UseSSL : Boolean Read FUseSSL Write FUseSSL; + // Called to create socket handler. If not set, or Nil is returned, a standard socket handler is created. + 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; + end; TFPHttpServer = Class(TFPCustomHttpServer) @@ -480,6 +508,7 @@ Var S : String; begin + S:=''; L:=ARequest.ContentLength; If (L>0) then begin @@ -648,6 +677,16 @@ begin Result:=Assigned(FServer); end; +procedure TFPCustomHttpServer.DoCreateClientHandler(Sender: TObject; out AHandler: TSocketHandler); +begin + AHandler:=GetSocketHandler(UseSSL); +end; + +function TFPCustomHttpServer.GetHostName: string; +begin + Result:=FCertificateData.HostName; +end; + procedure TFPCustomHttpServer.SetAcceptIdleTimeout(AValue: Cardinal); begin if FAcceptIdleTimeout=AValue then Exit; @@ -677,6 +716,17 @@ begin StopServerSocket; end; +procedure TFPCustomHttpServer.SetCertificateData(AValue: TCertificateData); +begin + if FCertificateData=AValue then Exit; + FCertificateData:=AValue; +end; + +procedure TFPCustomHttpServer.SetHostName(AValue: string); +begin + FCertificateData.HostName:=aValue; +end; + procedure TFPCustomHttpServer.SetIdle(AValue: TNotifyEvent); begin FOnAcceptIdle:=AValue; @@ -787,11 +837,13 @@ begin end; procedure TFPCustomHttpServer.CreateServerSocket; + begin if FAddress='' then FServer:=TInetServer.Create(FPort) else FServer:=TInetServer.Create(FAddress,FPort); + FServer.OnCreateClientSocketHandler:=@DoCreateClientHandler; FServer.MaxConnections:=-1; FServer.OnConnectQuery:=OnAllowConnect; FServer.OnConnect:=@DOConnect; @@ -824,7 +876,8 @@ begin inherited Create(AOwner); FPort:=80; FQueueSize:=5; - FServerBanner := 'Freepascal'; + FServerBanner := 'FreePascal'; + FCertificateData:=CreateCertificateData; end; procedure TFPCustomHttpServer.WaitForRequests; @@ -845,11 +898,57 @@ begin end; end; +function TFPCustomHttpServer.CreateCertificateData: TCertificateData; +begin + Result:=TCertificateData.Create; +end; + +function TFPCustomHttpServer.CreateSSLSocketHandler : TSocketHandler; + +Var + S : TSSLSocketHandler; + CK : TCertAndKey; + +begin + S:=TSSLSocketHandler.GetDefaultHandler; + try + // We must create the certificate once in our global copy of CertificateData ! + if CertificateData.NeedCertificateData then + begin + S.CertGenerator.HostName:=CertificateData.Hostname; + CK:=S.CertGenerator.CreateCertificateAndKey; + CertificateData.Certificate.Value:=CK.Certificate; + CertificateData.PrivateKey.Value:=CK.PrivateKey; + end; + S.CertificateData:=Self.CertificateData; + Result:=S; + except + S.free; + Raise; + end; +end; + +function TFPCustomHttpServer.GetSocketHandler(const UseSSL: Boolean): TSocketHandler; + +begin + Result:=Nil; + if Assigned(FonGetSocketHandler) then + FOnGetSocketHandler(Self,UseSSL,Result); + if (Result=Nil) then + If UseSSL then + Result:=CreateSSLSocketHandler + else + Result:=TSocketHandler.Create; + if Assigned(FAfterSocketHandlerCreated) then + FAfterSocketHandlerCreated(Self,Result); +end; + destructor TFPCustomHttpServer.Destroy; begin Active:=False; if Threaded and (FConnectionCount>0) then WaitForRequests; + FreeAndNil(FCertificateData); inherited Destroy; end; diff --git a/packages/openssl/fpmake.pp b/packages/openssl/fpmake.pp index 9279c97dfb..ea397bc6f7 100644 --- a/packages/openssl/fpmake.pp +++ b/packages/openssl/fpmake.pp @@ -13,6 +13,7 @@ begin {$endif ALLPACKAGES} P:=AddPackage('openssl'); + P.Dependencies.Add('fcl-net'); P.ShortName:='ossl'; P.Description := 'Interface units for OpenSSL libraries supporting SSL-encrypted network communication.'; {$ifdef ALLPACKAGES} @@ -29,6 +30,9 @@ begin T:=P.Targets.AddUnit('openssl.pas'); T:=P.Targets.AddUnit('fpopenssl.pp'); T.ResourceStrings:=true; + T:=P.Targets.AddUnit('opensslsockets.pp'); + T.ResourceStrings:=true; + T.Dependencies.AddUnit('openssl'); P.ExamplePath.Add('examples'); P.Targets.AddExampleProgram('test1.pas'); diff --git a/packages/openssl/src/fpopenssl.pp b/packages/openssl/src/fpopenssl.pp index 4355cdbb22..d0e34013d8 100644 --- a/packages/openssl/src/fpopenssl.pp +++ b/packages/openssl/src/fpopenssl.pp @@ -15,31 +15,23 @@ unit fpopenssl; {$mode objfpc}{$H+} +{$DEFINE DUMPCERT} interface uses - Classes, SysUtils, openssl, ctypes; + Classes, SysUtils, sslbase, openssl, ctypes; + +{$IFDEF DUMPCERT} +Const +{$IFDEF UNIX} + DumpCertFile = '/tmp/x509.txt'; +{$ELSE} + DumpCertFile = 'C:\temp\x509.txt'; +{$ENDIF} +{$ENDIF} + Type - TSSLType = (stAny,stSSLv2,stSSLv3,stTLSv1,stTLSv1_1,stTLSv1_2); - - // PASN1_INTEGER = SslPtr; - - { TSSLData } - - TSSLData = Class(TPersistent) - private - FFileName: String; - FValue: String; - Public - Function Empty : Boolean; - Procedure Assign(Source : TPersistent);override; - Property FileName : String Read FFileName Write FFileName; - Property Value: String Read FValue Write FValue; - end; - - { TSocketHandler } - { TSSLContext } TSSLContext = Class; @@ -55,24 +47,27 @@ Type FCTX: PSSL_CTX; function UsePrivateKey(pkey: SslPtr): cInt; function UsePrivateKeyASN1(pk: cInt; d: String; len: cLong): cInt; + function UsePrivateKeyASN1(pk: cInt; d: TBytes; len: cLong): cInt; function UsePrivateKeyFile(const Afile: String; Atype: cInt): cInt; Public Constructor Create(AContext : PSSL_CTX = Nil); overload; Constructor Create(AType : TSSLType); overload; Destructor Destroy; override; Function SetCipherList(Var ACipherList : String) : Integer; - procedure SetVerify(mode: Integer; arg2: PFunction); + procedure SetVerify(mode: Integer; arg2: TSSLCTXVerifyCallback); procedure SetDefaultPasswdCb(cb: PPasswdCb); procedure SetDefaultPasswdCbUserdata(u: SslPtr); Function UsePrivateKey(Data : TSSLData) : cint; // Use certificate. Function UseCertificate(Data : TSSLData) : cint; - function UseCertificateASN1(len: cLong; d: String):cInt; + function UseCertificateASN1(len: cLong; d: String):cInt; overload; deprecated 'use TBytes overload'; + function UseCertificateASN1(len: cLong; buf: TBytes):cInt; overload; function UseCertificateFile(const Afile: String; Atype: cInt):cInt; function UseCertificateChainFile(const Afile: PChar):cInt; function UseCertificate(x: SslPtr):cInt; function LoadVerifyLocations(const CAfile: String; const CApath: String):cInt; - function LoadPFX(Const S,APassword : AnsiString) : cint; + function LoadPFX(Const S,APassword : AnsiString) : cint; deprecated 'use TBytes overload'; + function LoadPFX(Const Buf : TBytes;APassword : AnsiString) : cint; function LoadPFX(Data : TSSLData; Const APAssword : Ansistring) : cint; function SetOptions(AOptions: cLong): cLong; procedure SetTlsextServernameCallback(cb: PCallbackCb); @@ -116,17 +111,30 @@ Type Property SSL: PSSL Read FSSL; end; + + TOpenSSLX509Certificate = Class (TX509Certificate) + Protected + function CreateKey: PEVP_PKEY; virtual; + procedure SetNameData(x: PX509); virtual; + procedure SetTimes(x: PX509); virtual; + Public + Function CreateCertificateAndKey : TCertAndKey; override; + end; + ESSL = Class(Exception); -Function BioToString(B : PBIO) : AnsiString; +Function BioToString(B : PBIO; FreeBIO : Boolean = False) : AnsiString; implementation +uses dateutils; + Resourcestring SErrCountNotGetContext = 'Failed to create SSL Context'; SErrFailedToCreateSSL = 'Failed to create SSL'; -Function BioToString(B : PBIO) : AnsiString; + +Function BioToString(B : PBIO; FreeBIO : Boolean = False) : AnsiString; Var L,RL : Integer; @@ -138,6 +146,25 @@ begin SetLength(Result,RL) else SetLength(Result,0); + if FreeBio then + BioFreeAll(B); +end; + +Function BioToTBytes(B : PBIO; FreeBIO : Boolean = False) : TBytes; + +Var + L,RL : Integer; +begin + l:=bioctrlpending(B); + SetLength(Result,l); + FillChar(Result[0],L,0); + RL:=BioRead(B,Result,L); + if (RL>0) then + SetLength(Result,RL) + else + SetLength(Result,0); + if FreeBio then + BioFreeAll(B); end; function SelectSNIContextCallback(ASSL: TSSL; ad: integer; arg: TTlsExtCtx): integer; cdecl; @@ -167,6 +194,114 @@ begin result := SSL_TLSEXT_ERR_OK; end; +{ TOpenSSLX509Certificate } + + +procedure TOpenSSLX509Certificate.SetNameData(x: PX509); + +Var + ND : PX509_NAME; + S : AnsiString; + + Procedure SetEntry(aCode,aValue : AnsiString); + + begin + if (AValue<>'') then + X509NameAddEntryByTxt(ND, aCode, $1001, aValue, -1, -1, 0); + end; + +begin + ND:=X509GetSubjectName(x); + S:=Country; + if S='' then + S:='BE'; + SetEntry('C',S); + S:=HostName; + if S='' then + S:='localhost'; + SetEntry('CN',S); + SetEntry('O',Organization); + x509SetIssuerName(x,ND); +end; + +Procedure TOpenSSLX509Certificate.SetTimes(x : PX509); + +var + Utc : PASN1_UTCTIME; + +begin + Utc:=Asn1UtctimeNew; + try + ASN1UtcTimeSetString(Utc,PAnsiChar(FormatDateTime('YYMMDDHHNNSS',ValidFrom))); + X509SetNotBefore(x, Utc); + ASN1UtcTimeSetString(Utc,PAnsiChar(FormatDateTime('YYMMDDHHNNSS',ValidTo))); + X509SetNotAfter(x,Utc); + finally + Asn1UtctimeFree(Utc); + end; +end; + + +function TOpenSSLX509Certificate.CreateKey : PEVP_PKEY; + +Var + rsa: PRSA; + +begin + Result:=EvpPkeynew; + rsa:=RsaGenerateKey(KeySize,$10001,nil,nil); + EvpPkeyAssign(Result,EVP_PKEY_RSA,rsa); +end; + +function TOpenSSLX509Certificate.CreateCertificateAndKey: TCertAndKey; + +var + pk: PEVP_PKEY; + x: PX509; + b: PBIO; +{$IFDEF DUMPCERT} + s : string; +{$ENDIF} + +begin + SetLength(Result.Certificate,0); + SetLength(Result.PrivateKey,0); + pk := nil; + x := X509New; + try + X509SetVersion(x, Version); + Asn1IntegerSet(X509getSerialNumber(x), GetRealSerial); + SetTimes(X); + pk:=CreateKey; + X509SetPubkey(x, pk); + SetNameData(x); + x509Sign(x,pk,EvpGetDigestByName('SHA1')); + // Certificate + b := BioNew(BioSMem); + i2dX509Bio(b, x); + Result.Certificate:=BioToTbytes(B,True); + // Private key + b := BioNew(BioSMem); + i2dPrivatekeyBio(b, pk); + Result.PrivateKey:=BioToTbytes(B,True); +{$IFDEF DUMPCERT} + b := BioNew(BioSMem); + PEM_write_bio_X509(b,x); + S:=BioToString(B,True); + With TStringList.Create do + try + Add(S); + SaveToFile(DumpCertFile); + finally + Free; + end; +{$ENDIF} + finally + X509free(x); + EvpPkeyFree(pk); + end; +end; + { TSSLContext } Constructor TSSLContext.Create(AContext: PSSL_CTX); @@ -211,7 +346,7 @@ begin Result:=SSLCTxSetCipherList(FCTX,ACipherList); end; -procedure TSSLContext.SetVerify(mode: Integer; arg2: PFunction); +procedure TSSLContext.SetVerify(mode: Integer; arg2: TSSLCTXVerifyCallback); begin SslCtxSetVerify(FCtx,Mode,arg2); end; @@ -236,6 +371,11 @@ begin Result:=SslCtxUsePrivateKeyASN1(pk,FCtx,d,len); end; +function TSSLContext.UsePrivateKeyASN1(pk: cInt; d: TBytes; len: cLong): cInt; +begin + Result:=SslCtxUsePrivateKeyASN1(pk,FCtx,d,len); +end; + function TSSLContext.UsePrivateKeyFile(const Afile: String; Atype: cInt):cInt; begin Result:=SslCtxUsePrivateKeyFile(FCTX,AFile,AType); @@ -245,44 +385,43 @@ end; Function TSSLContext.UsePrivateKey(Data: TSSLData): cint; Var - S : AnsiString; + FN : String; + l : integer; begin Result:=-1; - If (Data.Value<>'') then - begin - S:=Data.Value; - Result:=UsePrivateKeyASN1(EVP_PKEY_RSA,S,length(S)); - end + L:=Length(Data.Value); + If (l<>0) then + Result:=UsePrivateKeyASN1(EVP_PKEY_RSA,Data.Value,L) else if (Data.FileName<>'') then begin - S:=Data.FileName; - Result:=UsePrivateKeyFile(S,SSL_FILETYPE_PEM); + FN:=Data.FileName; + Result:=UsePrivateKeyFile(FN,SSL_FILETYPE_PEM); if (Result<>1) then - Result:=UsePrivateKeyFile(S,SSL_FILETYPE_ASN1); + Result:=UsePrivateKeyFile(FN,SSL_FILETYPE_ASN1); end; end; Function TSSLContext.UseCertificate(Data: TSSLData): cint; Var - S : AnsiString; + l : integer; + FN : String; + begin Result:=-1; - if (Data.Value<>'') then - begin - S:=Data.Value; - Result:=UseCertificateASN1(length(S),S); - end + L:=Length(Data.Value); + if (L<>0) then + Result:=UseCertificateASN1(length(Data.Value),Data.Value) else if (Data.FileName<>'') then begin - S:=Data.FileName; - Result:=UseCertificateChainFile(PChar(S)); + FN:=Data.FileName; + Result:=UseCertificateChainFile(PChar(FN)); if Result<>1 then begin - Result:=UseCertificateFile(S,SSL_FILETYPE_PEM); - if Result<>1 then - Result:=UseCertificateFile(S,SSL_FILETYPE_ASN1); + Result:=UseCertificateFile(FN,SSL_FILETYPE_PEM); + if (Result<>1) then + Result:=UseCertificateFile(FN,SSL_FILETYPE_ASN1); end; end end; @@ -292,6 +431,11 @@ begin Result:=sslctxUseCertificateASN1(FCTX,len,d); end; +function TSSLContext.UseCertificateASN1(len: cLong; buf: TBytes): cInt; +begin + Result:=sslctxUseCertificateASN1(FCTX,len,Buf); +end; + function TSSLContext.UseCertificateFile(const Afile: String; Atype: cInt): cInt; begin Result:=sslctxUseCertificateFile(FCTX,Afile,Atype); @@ -314,6 +458,17 @@ end; function TSSLContext.LoadPFX(Const S, APassword: AnsiString): cint; +var + Buf : TBytes; + +begin + SetLength(Buf,Length(S)); + Move(S[1],Buf[0],Length(S)); + Result:=LoadPFX(Buf,APAssword); +end; + +function TSSLContext.LoadPFX(const Buf: TBytes; APassword: AnsiString): cint; + var b: PBIO; p12,c,pk,ca: SslPtr; @@ -326,50 +481,46 @@ begin p12:=Nil; b:=BioNew(BioSMem); try - BioWrite(b,S,Length(S)); + BioWrite(b,Buf,Length(Buf)); p12:=d2iPKCS12bio(b,nil); - finally - BioFreeAll(b); - end; - if Not Assigned(p12) then - Exit; - try - try + if Assigned(p12) then if PKCS12parse(p12,APassword,pk,c,ca)>0 then begin Result:=UseCertificate(c); if (Result>0) then Result:=UsePrivateKey(pk); end; - finally - EvpPkeyFree(pk); - X509free(c); -// SkX509PopFree(ca,_X509Free); - end; finally - PKCS12free(p12); + if pk<>Nil then + EvpPkeyFree(pk); + if c<>nil then + X509free(c); +// SkX509PopFree(ca,_X509Free); + if p12<>Nil then + PKCS12free(p12); + BioFreeAll(b); end; end; function TSSLContext.LoadPFX(Data: TSSLData; Const APAssword : Ansistring): cint; Var - S : String; + B : TBytes; begin Result:=-1; try - if (Data.Value<>'') then - S:=Data.Value + if (Length(Data.Value)<>0) then + B:=Data.Value else With TFileStream.Create(Data.FileName,fmOpenRead or fmShareDenyNone) do Try - SetLength(S,Size); - ReadBuffer(S[1],Size); + SetLength(B,Size); + ReadBuffer(B[0],Size); finally Free; end; - Result:=LoadPFX(s,APassword); + Result:=LoadPFX(B,APassword); except // Silently ignore Exit; @@ -407,27 +558,6 @@ begin SslCtxCtrl(FCTX, SSL_CTRL_SET_ECDH_AUTO, larg, nil); end; -{ TSSLData } - -Function TSSLData.Empty: Boolean; -begin - Result:=(Value='') and (FileName=''); -end; - -Procedure TSSLData.Assign(Source: TPersistent); - - -begin - if Source is TSSLData then - With TSSLData(Source) do - begin - Self.FValue:=FValue; - Self.FFileName:=FFileName; - end - else - inherited Assign(Source); -end; - { TSSL } Constructor TSSL.Create(ASSL: PSSL); @@ -473,7 +603,11 @@ end; function TSSL.Shutdown: cInt; begin - Result:=sslShutDown(fSSL); + try + Result:=sslShutDown(fSSL); + except + // Sometimes, SSL gives an error when the connection is lost + end; end; function TSSL.Read(buf: SslPtr; num: cInt): cInt; @@ -555,6 +689,7 @@ var begin Result:=''; + S:=''; c:=PeerCertificate; if Assigned(c) then try diff --git a/packages/openssl/src/openssl.pas b/packages/openssl/src/openssl.pas index 94940d241c..30d9c3ef20 100644 --- a/packages/openssl/src/openssl.pas +++ b/packages/openssl/src/openssl.pas @@ -254,6 +254,10 @@ type PASN1_cInt = SslPtr; PPasswdCb = SslPtr; PCallbackCb = SslPtr; + + PX509_STORE_CTX = SslPtr; + TSSLCTXVerifyCallback = function (ok : cInt; ctx : PX509_STORE_CTX) : Cint; cdecl; + PFunction = procedure; DES_cblock = array[0..7] of Byte; PDES_cblock = ^DES_cblock; @@ -833,6 +837,35 @@ const RSA_NO_PADDING = 3; RSA_PKCS1_OAEP_PADDING = 4; + // ASN1 values + V_ASN1_EOC = 0; + V_ASN1_BOOLEAN = 1; + V_ASN1_INTEGER = 2; + V_ASN1_BIT_STRING = 3; + V_ASN1_OCTET_STRING = 4; + V_ASN1_NULL = 5; + V_ASN1_OBJECT = 6; + V_ASN1_OBJECT_DESCRIPTOR = 7; + V_ASN1_EXTERNAL = 8; + V_ASN1_REAL = 9; + V_ASN1_ENUMERATED = 10; + V_ASN1_UTF8STRING = 12; + V_ASN1_SEQUENCE = 16; + V_ASN1_SET = 17; + V_ASN1_NUMERICSTRING = 18; + V_ASN1_PRINTABLESTRING = 19; + V_ASN1_T61STRING = 20; + V_ASN1_TELETEXSTRING = 20; + V_ASN1_VIDEOTEXSTRING = 21; + V_ASN1_IA5STRING = 22; + V_ASN1_UTCTIME = 23; + V_ASN1_GENERALIZEDTIME = 24; + V_ASN1_GRAPHICSTRING = 25; + V_ASN1_ISO64STRING = 26; + V_ASN1_VISIBLESTRING = 26; + V_ASN1_GENERALSTRING = 27; + V_ASN1_UNIVERSALSTRING = 28; + V_ASN1_BMPSTRING = 30; // BN {$ifdef cpu64} @@ -1016,11 +1049,13 @@ var function SslMethodV23:PSSL_METHOD; function SslTLSMethod:PSSL_METHOD; function SslCtxUsePrivateKey(ctx: PSSL_CTX; pkey: SslPtr):cInt; - function SslCtxUsePrivateKeyASN1(pk: cInt; ctx: PSSL_CTX; d: String; len: cLong):cInt; + function SslCtxUsePrivateKeyASN1(pk: cInt; ctx: PSSL_CTX; d: String; len: cLong):cInt;overload; + function SslCtxUsePrivateKeyASN1(pk: cInt; ctx: PSSL_CTX; b: TBytes; len: cLong):cInt;overload; // function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: PChar; _type: cInt):cInt; function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: String; _type: cInt):cInt; function SslCtxUseCertificate(ctx: PSSL_CTX; x: SslPtr):cInt; - function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: cLong; d: String):cInt; + function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: cLong; d: String):cInt; overload; + function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: cLong; Buf: TBytes):cInt; overload; function SslCtxUseCertificateFile(ctx: PSSL_CTX; const _file: String; _type: cInt):cInt; // function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: PChar):cInt; function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: String):cInt; @@ -1040,7 +1075,7 @@ var function SslPending(ssl: PSSL):cInt; function SslGetVersion(ssl: PSSL):String; function SslGetPeerCertificate(ssl: PSSL):PX509; - procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: cInt; arg2: PFunction); + procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: cInt; arg2: TSSLCTXVerifyCallback); function SSLGetCurrentCipher(s: PSSL):SslPtr; function SSLCipherGetName(c: SslPtr): String; function SSLCipherGetBits(c: SslPtr; var alg_bits: cInt):cInt; @@ -1086,6 +1121,9 @@ var function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr; function PKCS12parse(p12: SslPtr; pass: string; var pkey, cert, ca: SslPtr): cInt; procedure PKCS12free(p12: SslPtr); + function Asn1StringTypeNew(aType : cint): PASN1_STRING; + Function Asn1UtctimePrint(b : PBio; a: PASN1_UTCTIME) : integer; + Function ASN1UtcTimeSetString(t : PASN1_UTCTIME; s : PAnsichar) : cint; function Asn1UtctimeNew: PASN1_UTCTIME; procedure Asn1UtctimeFree(a: PASN1_UTCTIME); function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer; @@ -1243,14 +1281,17 @@ var u: pointer): integer; function PEM_write_bio_PUBKEY(bp: pBIO; x: pEVP_PKEY): integer; function PEM_read_bio_X509(bp: PBIO; x: PPX509; cb: ppem_password_cb; u: pointer): PX509; - + function PEM_write_bio_X509(bp: pBIO; x: px509): integer; + // BIO Functions - bio.h function BioNew(b: PBIO_METHOD): PBIO; procedure BioFreeAll(b: PBIO); function BioSMem: PBIO_METHOD; function BioCtrlPending(b: PBIO): cInt; function BioRead(b: PBIO; var Buf: String; Len: cInt): cInt; - function BioWrite(b: PBIO; Buf: String; Len: cInt): cInt; + function BioRead(b: PBIO; Buf: TBytes; Len: cInt): cInt; + function BioWrite(b: PBIO; Buf: String; Len: cInt): cInt; overload; + function BioWrite(b: PBIO; Buf: TBytes; Len: cInt): cInt; overload; function BIO_ctrl(bp: PBIO; cmd: cint; larg: clong; parg: Pointer): clong; function BIO_read_filename(b: PBIO; const name: PChar): cint; @@ -1558,7 +1599,9 @@ type Td2iPKCS12bio = function(b:PBIO; Pkcs12: SslPtr): SslPtr; cdecl; TPKCS12parse = function(p12: SslPtr; pass: PChar; var pkey, cert, ca: SslPtr): cInt; cdecl; TPKCS12free = procedure(p12: SslPtr); cdecl; - TAsn1UtctimeNew = function: PASN1_UTCTIME; cdecl; + TAsn1StringTypeNew = function(aype : cint): SSlPtr; cdecl; + TAsn1UtcTimeSetString = function(t : PASN1_UTCTIME; S : PAnsiChar): cint; cdecl; + TAsn1UtctimePrint = Function(b : PBio;a: PASN1_UTCTIME) : cint; cdecl; TAsn1UtctimeFree = procedure(a: PASN1_UTCTIME); cdecl; TAsn1IntegerSet = function(a: PASN1_INTEGER; v: integer): integer; cdecl; TAsn1IntegerGet = function(a: PASN1_INTEGER): integer; cdecl; @@ -1684,6 +1727,7 @@ type u: pointer): integer; cdecl; TPEM_write_bio_PUBKEY = function(bp: pBIO; x: pEVP_PKEY): integer; cdecl; TPEM_read_bio_X509 = function(bp: pBIO; x: PPX509; cb: Ppem_password_cb; u: pointer): px509; cdecl; + TPEM_write_bio_X509 = function(bp: pBIO; x: PX509): integer; cdecl; // BIO Functions @@ -1783,7 +1827,9 @@ var _d2iPKCS12bio: Td2iPKCS12bio = nil; _PKCS12parse: TPKCS12parse = nil; _PKCS12free: TPKCS12free = nil; - _Asn1UtctimeNew: TAsn1UtctimeNew = nil; + _Asn1StringTypeNew: TAsn1StringTypeNew = nil; + _Asn1UtctimeSetString : TAsn1UtctimeSetString = Nil; + _Asn1UtctimePrint: TAsn1UtctimePrint = nil; _Asn1UtctimeFree: TAsn1UtctimeFree = nil; _Asn1IntegerSet: TAsn1IntegerSet = nil; _Asn1IntegerGet: TAsn1IntegerGet = nil; @@ -1916,6 +1962,7 @@ var _PEM_write_bio_PrivateKey: TPEM_write_bio_PrivateKey = nil; _PEM_write_bio_PUBKEY: TPEM_write_bio_PUBKEY = nil; _PEM_read_bio_X509: TPEM_read_bio_X509 = nil; + _PEM_write_bio_X509: TPEM_write_bio_X509 = nil; // BIO Functions _BIO_ctrl: TBIO_ctrl = nil; @@ -2200,7 +2247,7 @@ begin Result := 0; end; -function SslCtxUsePrivateKeyASN1(pk: cInt; ctx: PSSL_CTX; d: String; len: cLong):cInt; +function SslCtxUsePrivateKeyASN1(pk: cInt; ctx: PSSL_CTX; d: String; len: cLong):cInt; overload; begin if InitSSLInterface and Assigned(_SslCtxUsePrivateKeyASN1) then Result := _SslCtxUsePrivateKeyASN1(pk, ctx, Sslptr(d), len) @@ -2208,6 +2255,14 @@ begin Result := 0; end; +function SslCtxUsePrivateKeyASN1(pk: cInt; ctx: PSSL_CTX; b: TBytes; len: cLong): cInt;overload; +begin + if InitSSLInterface and Assigned(_SslCtxUsePrivateKeyASN1) then + Result := _SslCtxUsePrivateKeyASN1(pk, ctx, Sslptr(b), len) + else + Result := 0; +end; + function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: String; _type: cInt):cInt; begin if InitSSLInterface and Assigned(_SslCtxUsePrivateKeyFile) then @@ -2232,6 +2287,14 @@ begin Result := 0; end; +function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: cLong; Buf: TBytes): cInt; +begin + if InitSSLInterface and Assigned(_SslCtxUseCertificateASN1) then + Result := _SslCtxUseCertificateASN1(ctx, len, SslPtr(Buf)) + else + Result := 0; +end; + function SslCtxUseCertificateFile(ctx: PSSL_CTX; const _file: String; _type: cInt):cInt; begin if InitSSLInterface and Assigned(_SslCtxUseCertificateFile) then @@ -2363,7 +2426,7 @@ begin Result := nil; end; -procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: cInt; arg2: PFunction); +procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: cInt; arg2: TSSLCTXVerifyCallback); begin if InitSSLInterface and Assigned(_SslCtxSetVerify) then _SslCtxSetVerify(ctx, mode, @arg2); @@ -2587,6 +2650,14 @@ begin Result := 0; end; +function BioRead(b: PBIO; Buf: TBytes; Len: cInt): cInt; +begin + if InitSSLInterface and Assigned(_BioRead) then + Result := _BioRead(b, PChar(Buf), Len) + else + Result := -2; +end; + function BioRead(b: PBIO; var Buf: String; Len: cInt): cInt; begin if InitSSLInterface and Assigned(_BioRead) then @@ -2604,6 +2675,16 @@ begin Result := -2; end; +function BioWrite(b: PBIO; Buf: TBytes; Len: cInt): cInt; + +begin + if InitSSLInterface and Assigned(_BioWrite) then + Result := _BioWrite(b, PChar(Buf), Len) + else + Result := -2; +end; + + function X509print(b: PBIO; a: PX509): cInt; begin if InitSSLInterface and Assigned(_X509print) then @@ -2694,8 +2775,14 @@ end; function Asn1UtctimeNew: PASN1_UTCTIME; begin - if InitSSLInterface and Assigned(_Asn1UtctimeNew) then - Result := _Asn1UtctimeNew + Result:=PASN1_UTCTIME(Asn1StringTypeNew(V_ASN1_UTCTIME)); +end; + +function Asn1StringTypeNew(aType : cint): PASN1_STRING; + +begin + if InitSSLInterface and Assigned(_Asn1StringTypeNew) then + Result := _Asn1StringTypeNew(aType) else Result := nil; end; @@ -2706,6 +2793,22 @@ begin _Asn1UtctimeFree(a); end; +function Asn1UtctimePrint(b: PBio; a: PASN1_UTCTIME): integer; +begin + if InitSSLInterface and Assigned(_Asn1UtctimePrint) then + Result:=_Asn1UtctimePrint(b,a) + else + Result:=0; +end; + +function ASN1UtcTimeSetString(t: PASN1_UTCTIME; s: PAnsichar): cint; +begin + if InitSSLInterface and Assigned(_Asn1UtctimeSetString) then + Result:=_Asn1UtctimeSetString(t,s) + else + Result:=0; +end; + function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer; begin if InitSSLInterface and Assigned(_Asn1IntegerSet) then @@ -3558,7 +3661,7 @@ Begin Result := -1; end; -function PEM_read_bio_X509(bp: pBIO; x: ppx509; cb: Ppem_password_cb; u: pointer): px509; +function PEM_read_bio_X509(bp: PBIO; x: PPX509; cb: ppem_password_cb; u: pointer): PX509; begin if InitSSLInterface and Assigned(_PEM_read_bio_X509) then Result := _PEM_read_bio_X509(bp, x, cb, u) @@ -3566,6 +3669,14 @@ begin Result := nil; end; +function PEM_write_bio_X509(bp: pBIO; x: px509): integer; +begin + if InitSSLInterface and Assigned(_PEM_write_bio_X509) then + Result := _PEM_write_bio_X509(bp, x) + else + Result := 0; +end; + // BIO Functions @@ -3582,7 +3693,7 @@ begin Result := BIO_ctrl(b, BIO_C_SET_FILENAME, BIO_CLOSE or BIO_FP_READ, name); end; -function BIO_s_file: PBIO_METHOD; +function BIO_s_file: pBIO_METHOD; begin if InitSSLInterface and Assigned(_BIO_s_file) then Result := _BIO_s_file @@ -4643,7 +4754,9 @@ begin _d2iPKCS12bio := GetProcAddr(SSLUtilHandle, 'd2i_PKCS12_bio'); _PKCS12parse := GetProcAddr(SSLUtilHandle, 'PKCS12_parse'); _PKCS12free := GetProcAddr(SSLUtilHandle, 'PKCS12_free'); - _Asn1UtctimeNew := GetProcAddr(SSLUtilHandle, 'ASN1_UTCTIME_new'); + _Asn1UtctimeSetString := GetProcAddr(SSLUtilHandle, 'ASN1_UTCTIME_set_string'); + _Asn1StringTypeNew := GetProcAddr(SSLUtilHandle, 'ASN1_STRING_type_new'); + _Asn1UtctimePrint := GetProcAddr(SSLUtilHandle, 'ASN1_UTCTIME_print'); _Asn1UtctimeFree := GetProcAddr(SSLUtilHandle, 'ASN1_UTCTIME_free'); _Asn1IntegerSet := GetProcAddr(SSLUtilHandle, 'ASN1_INTEGER_set'); _Asn1IntegerGet := GetProcAddr(SSLUtilHandle, 'ASN1_INTEGER_get'); @@ -4755,7 +4868,8 @@ begin _PEM_write_bio_PrivateKey := GetProcAddr(SSLUtilHandle, 'PEM_write_bio_PrivateKey'); _PEM_write_bio_PUBKEY := GetProcAddr(SSLUtilHandle, 'PEM_write_bio_PUBKEY'); _PEM_read_bio_X509 := GetProcAddr(SSLUtilHandle, 'PEM_read_bio_X509'); - + _PEM_write_bio_X509 := GetProcAddr(SSLUtilHandle,'PEM_write_bio_X509'); + // BIO _BIO_ctrl := GetProcAddr(SSLUtilHandle, 'BIO_ctrl'); _BIO_s_file := GetProcAddr(SSLUtilHandle, 'BIO_s_file'); @@ -5105,7 +5219,9 @@ begin _d2iPKCS12bio := nil; _PKCS12parse := nil; _PKCS12free := nil; - _Asn1UtctimeNew := nil; + _Asn1UtctimeSetString := nil; + _Asn1StringTypeNew := nil; + _Asn1UtctimePrint := nil; _Asn1UtctimeFree := nil; _Asn1IntegerSet:= nil; _Asn1IntegerGet:= nil; @@ -5216,6 +5332,7 @@ begin _PEM_read_bio_PUBKEY := nil; _PEM_write_bio_PrivateKey := nil; _PEM_read_bio_X509 := nil; + _PEM_write_bio_X509 := nil; // BIO diff --git a/packages/openssl/src/opensslsockets.pp b/packages/openssl/src/opensslsockets.pp new file mode 100644 index 0000000000..88870a22c5 --- /dev/null +++ b/packages/openssl/src/opensslsockets.pp @@ -0,0 +1,321 @@ +unit opensslsockets; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, sockets, ssockets, sslsockets, sslbase, openssl, fpopenssl; + +Type + + { TOpenSSLSocketHandler } + + TOpenSSLSocketHandler = Class(TSSLSocketHandler) + Private + FSSL: TSSL; + FCTX : TSSLContext; + FSSLLastErrorString: string; + FSSLLastError : Integer; + Protected + procedure SetSSLLastErrorString(AValue: string); + Function FetchErrorInfo: Boolean; + function CheckSSL(SSLResult: Integer): Boolean; + function CheckSSL(SSLResult: Pointer): Boolean; + function InitContext(NeedCertificate: Boolean): Boolean; virtual; + function DoneContext: Boolean; virtual; + function InitSslKeys: boolean;virtual; + Public + Constructor create; override; + destructor destroy; override; + function CreateCertGenerator: TX509Certificate; override; + function Connect : Boolean; override; + function Close : Boolean; override; + function Accept : Boolean; override; + function Shutdown(BiDirectional : Boolean): boolean; override; + function Send(Const Buffer; Count: Integer): Integer; override; + function Recv(Const Buffer; Count: Integer): Integer; override; + function BytesAvailable: Integer; override; + // Result of last CheckSSL call. + Function SSLLastError: integer; + property SSLLastErrorString: string read FSSLLastErrorString write SetSSLLastErrorString; + end; + +implementation + +{ TSocketHandler } +Resourcestring + SErrNoLibraryInit = 'Could not initialize OpenSSL library'; + +Procedure MaybeInitSSLInterface; + +begin + if not IsSSLloaded then + if not InitSSLInterface then + Raise EInOutError.Create(SErrNoLibraryInit); +end; + +function TopenSSLSocketHandler.CreateCertGenerator: TX509Certificate; +begin + Result:=TOpenSSLX509Certificate.Create; +end; + +procedure TOpenSSLSocketHandler.SetSSLLastErrorString(AValue: string); +begin + if FSSLLastErrorString=AValue then Exit; + FSSLLastErrorString:=AValue; +end; + +function TOpenSSLSocketHandler.Connect: Boolean; +begin + Result:=Inherited Connect; + Result := Result and InitContext(False); + if Result then + begin + Result:=CheckSSL(FSSL.SetFD(Socket.Handle)); + if Result then + begin + if SendHostAsSNI and (Socket is TInetSocket) then + FSSL.Ctrl(SSL_CTRL_SET_TLSEXT_HOSTNAME,TLSEXT_NAMETYPE_host_name,PAnsiChar(AnsiString((Socket as TInetSocket).Host))); + Result:=CheckSSL(FSSL.Connect); + if Result and VerifyPeerCert then + Result:=(FSSL.VerifyResult<>0) or (not DoVerifyCert); + if Result then + SetSSLActive(True); + end; + end; +end; + +function TOpenSSLSocketHandler.Close: Boolean; +begin + Result:=Shutdown(False); +end; + +Function TOpenSSLSocketHandler.FetchErrorInfo : Boolean; + +var + S : AnsiString; + +begin + FSSLLastErrorString:=''; + FSSLLastError:=ErrGetError; + ErrClearError; + Result:=(FSSLLastError<>0); + if Result then + begin + S:=StringOfChar(#0,256); + ErrErrorString(FSSLLastError,S,256); + FSSLLastErrorString:=s; + end; +end; + +function TOpenSSLSocketHandler.CheckSSL(SSLResult : Integer) : Boolean; + +begin + Result:=SSLResult>=1; + if Not Result then + begin + FSSLLastError:=SSLResult; + FetchErrorInfo; + end; +end; + +function TOpenSSLSocketHandler.CheckSSL(SSLResult: Pointer): Boolean; +begin + Result:=(SSLResult<>Nil); + if not Result then + Result:=FetchErrorInfo; +end; + +function TOpenSSLSocketHandler.DoneContext: Boolean; + +begin + FreeAndNil(FSSL); + FreeAndNil(FCTX); + ErrRemoveState(0); + SetSSLActive(False); + Result:=True; +end; + +Function HandleSSLPwd(buf : PAnsiChar; len:Integer; flags:Integer; UD : Pointer):Integer; cdecl; + +var + Pwd: AnsiString; + H : TOpenSSLSocketHandler; + +begin + if Not Assigned(UD) then + PWD:='' + else + begin + H:=TOpenSSLSocketHandler(UD); + Pwd:=H.CertificateData.KeyPassword; + end; + if (lenNil); + if not Result then + Exit; + if not CertificateData.Certificate.Empty then + 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 not CertificateData.PFX.Empty then + Result:=CheckSSL(FCTX.LoadPFX(CertificateData.PFX,CertificateData.KeyPassword)); +end; + +constructor TOpenSSLSocketHandler.create; +begin + inherited create; + MaybeInitSSLInterface; +end; + +destructor TOpenSSLSocketHandler.destroy; +begin + FreeAndNil(FCTX); + FreeAndNil(FSSL); + inherited destroy; +end; + +function TOpenSSLSocketHandler.InitContext(NeedCertificate:Boolean): Boolean; + +Const + VO : Array[Boolean] of Integer = (SSL_VERIFY_NONE,SSL_VERIFY_PEER); + +var + s: AnsiString; + +begin + Result:=DoneContext; + if Not Result then + Exit; + try + FCTX:=TSSLContext.Create(SSLType); + Except + CheckSSL(Nil); + Result:=False; + Exit; + end; + S:=CertificateData.CipherList; + FCTX.SetCipherList(S); + FCTX.SetVerify(VO[VerifypeerCert],Nil); + FCTX.SetDefaultPasswdCb(@HandleSSLPwd); + FCTX.SetDefaultPasswdCbUserdata(self); + If NeedCertificate and CertificateData.NeedCertificateData then + if Not CreateSelfSignedCertificate then + begin + DoneContext; + Exit(False); + end; + if Not InitSSLKeys then + begin + DoneContext; + Exit(False); + end; + try + FSSL:=TSSL.Create(FCTX); + Result:=True; + Except + CheckSSL(Nil); + DoneContext; + Result:=False; + end; +end; + +function TOpenSSLSocketHandler.Accept: Boolean; + +begin + Result:=InitContext(True); + if Result then + begin + Result:=CheckSSL(FSSL.setfd(Socket.Handle)); + if Result then + Result:=CheckSSL(FSSL.Accept); + end; + SetSSLActive(Result); +end; + + +function TOpenSSLSocketHandler.Shutdown(BiDirectional : Boolean): boolean; + +var + r : integer; + +begin + Result:=assigned(FSsl); + if Result then + If Not BiDirectional then + Result:=CheckSSL(FSSL.Shutdown) + else + begin + r:=FSSL.Shutdown; + if r<>0 then + Result:=CheckSSL(r) + else + begin + Result:=fpShutdown(Socket.Handle,1)=0; + if Result then + Result:=CheckSSL(FSsl.Shutdown); + end + end; + If Result then + Result:=DoneContext; +end; + +function TOpenSSLSocketHandler.Send(Const Buffer; Count: Integer): Integer; +var + e: integer; +begin + FSSLLastError := 0; + FSSLLastErrorString:=''; + repeat + Result:=FSsl.Write(@Buffer,Count); + e:=FSsl.GetError(Result); + until Not (e in [SSL_ERROR_WANT_READ,SSL_ERROR_WANT_WRITE]); + if (E=SSL_ERROR_ZERO_RETURN) then + Result:=0 + else if (e<>0) then + FSSLLastError:=e; +end; + +function TOpenSSLSocketHandler.Recv(Const Buffer; Count: Integer): Integer; + +var + e: integer; +begin + FSSLLastError:=0; + FSSLLastErrorString:= ''; + repeat + Result:=FSSL.Read(@Buffer ,Count); + e:=FSSL.GetError(Result); + until Not (e in [SSL_ERROR_WANT_READ,SSL_ERROR_WANT_WRITE]); + if (E=SSL_ERROR_ZERO_RETURN) then + Result:=0 + else if (e<>0) then + FSSLLastError:=e; +end; + +function TOpenSSLSocketHandler.BytesAvailable: Integer; +begin + Result:= FSSL.Pending; +end; + +Function TOpenSSLSocketHandler.SSLLastError: integer; +begin + Result:=FSSLLastError; +end; + +initialization + TSSLSocketHandler.SetDefaultHandlerClass(TOpenSSLSocketHandler); +end. +