paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-15 13:19:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Rework SSL handling to be pluggable, add HTTPS support to fphttpserver

Browse Source 
git-svn-id: trunk@40769 -
This commit is contained in:
michael 2019-01-05 12:37:44 +00:00
parent 1378f55f6d
commit b0c264948e
19 changed files with 1277 additions and 489 deletions

2
.gitattributes vendored
View File

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

2
packages/fcl-net/fpmake.pp
View File

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

242
packages/fcl-net/src/sslbase.pp Normal file
View File

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

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

@ -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 (len<Length(Pwd)+1) then
SetLength(Pwd,len-1);
pwd:=pwd+#0;
Result:=Length(Pwd);
Move(Pointer(Pwd)^,Buf^,Result);
end;
function TSSLSocketHandler.InitSslKeys: boolean;
begin
Result:=(FCTX<>Nil);
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.

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

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

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

@ -3,7 +3,7 @@ program httpget;
{$mode objfpc}{$H+}
uses
SysUtils, Classes, fphttpclient, sslsockets, fpopenssl;
SysUtils, Classes, fphttpclient, sslsockets, fpopenssl, opensslsockets;
Type

2
packages/fcl-web/examples/httpclient/httppost.pp
View File

@ -3,7 +3,7 @@ program httppost;
{$mode objfpc}{$H+}
uses
SysUtils, Classes, fphttpclient;
SysUtils, Classes, fphttpclient, opensslsockets;
Var
F : TFileStream;

2
packages/fcl-web/examples/httpclient/httppostfile.pp
View File

@ -3,7 +3,7 @@ program httppostfile;
{$mode objfpc}{$H+}
uses
SysUtils, Classes, fphttpclient;
SysUtils, Classes, fphttpclient, opensslsockets;
Var
F : TFileStream;

2
packages/fcl-web/examples/httpclient/keepalive.pp
View File

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

23
packages/fcl-web/examples/simpleserver/simpleserver.lpi
View File

@ -4,8 +4,12 @@
<Version Value="11"/>
<General>
<Flags>
<SaveClosedFiles Value="False"/>
<SaveOnlyProjectUnits Value="True"/>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
<SaveJumpHistory Value="False"/>
<SaveFoldState Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
@ -20,16 +24,31 @@
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<CommandLineParams Value="-p 3003 -s -H nickname.freepascal.org"/>
</local>
<FormatVersion Value="2"/>
<Modes Count="1">
<Mode0 Name="default"/>
<Mode0 Name="default">
<local>
<CommandLineParams Value="-p 3003 -s -H nickname.freepascal.org"/>
</local>
</Mode0>
</Modes>
</RunParams>
<Units Count="1">
<Units Count="3">
<Unit0>
<Filename Value="simpleserver.pas"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="sslbase.pp"/>
<IsPartOfProject Value="True"/>
</Unit1>
<Unit2>
<Filename Value="opensslsockets.pp"/>
<IsPartOfProject Value="True"/>
</Unit2>
</Units>
</ProjectOptions>
<CompilerOptions>

10
packages/fcl-web/examples/simpleserver/simpleserver.pas
View File

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

1
packages/fcl-web/fpmake.pp
View File

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

56
packages/fcl-web/src/base/custhttpapp.pp
View File

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

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

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

103
packages/fcl-web/src/base/fphttpserver.pp
View File

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

4
packages/openssl/fpmake.pp
View File

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

311
packages/openssl/src/fpopenssl.pp
View File

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

149
packages/openssl/src/openssl.pas
View File

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

321
packages/openssl/src/opensslsockets.pp Normal file
View File

@ -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 (len<Length(Pwd)+1) then
SetLength(Pwd,len-1);
pwd:=pwd+#0;
Result:=Length(Pwd);
Move(Pointer(Pwd)^,Buf^,Result);
end;
function TOpenSSLSocketHandler.InitSslKeys: boolean;
begin
Result:=(FCTX<>Nil);
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.