I found four bugs in ssl_streamsec.pas that are only likely to surface
if you use it in server side code. Fixed unit in attachment.
* TSSLStreamSec.Accept calls FSlave.Open instead of FSlave.DoConnect.
The Open method is for client side connect. DoConnect is for server side
accept.
* TSSLStreamSec.Init declares pass: TSecretKey. This class is reference
counted and, if used, passed as an interface to other methods. Freeing
it at the end *will* cause an AV or Invalid Pointer Exception. The
proper declaration is pass: ISecretKey coupled with the optional
finalization code finally pass := nil end;
* If neither the global variable GlobalServer nor the TLSServer property
is assigned, TSSSLStreamSec.Init creates a TSimpleTLSInternalServer that
is never destroyed.
* TSSSLStreamSec.Init calls FSlave.MyTLSServer.TLSSetupServer, which
will happen on each accept. That method should only be called once.
The attachment fixes the third and fourth bug by adding a private field
FServerCreated that is set to true if Init creates a
TSimpleTLSInternalServer instance. However, it is strongly recommended
that you create that component in your own code.
**************************************************************************************
This email and any files transmitted with it are confidential and intended
solely for the use of the individual or entity to whom they are addressed.
If you have received this email in error please notify the sender by return
e-mail and delete it from your system. Thank you. Any opinions expressed
are that of the individual and not necessarily that of StreamSec.net.
Although StreamSec.net believe this email and any attachments are free
of any virus or defect that may affect a computer, it is the responsibility of
the recipient to ensure that this is so, and StreamSec.net accepts no
responsibility for any loss, contamination or damage arising in any way from its use.
**************************************************************************************
{==============================================================================|
| Project : Ararat Synapse | 001.000.005 |
|==============================================================================|
| Content: SSL support by StreamSecII |
|==============================================================================|
| Copyright (c)1999-2005, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2005. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
| Henrick Hellström <[EMAIL PROTECTED]> |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(SSL plugin for StreamSecII or OpenStreamSecII)
StreamSecII is native pascal library, you not need any external libraries!
You can tune lot of StreamSecII properties by using your GlobalServer. If you
not
using your GlobalServer, then this plugin create own TSimpleTLSInternalServer
instance for each TCP connection. Formore information about GlobalServer usage
refer StreamSecII documentation.
If you are not using key and certificate by GlobalServer, then you can use
properties of this plugin instead, but this have limited features and
@link(TCustomSSL.KeyPassword) not working properly yet!
For handling keys and certificates you can use this properties:
@link(TCustomSSL.CertCAFile), @link(TCustomSSL.CertCA),
@link(TCustomSSL.TrustCertificateFile), @link(TCustomSSL.TrustCertificate),
@link(TCustomSSL.PrivateKeyFile), @link(TCustomSSL.PrivateKey),
@link(TCustomSSL.CertificateFile), @link(TCustomSSL.Certificate),
@link(TCustomSSL.PFXFile). For usage of this properties and for possible formats
of keys and certificates refer to StreamSecII documentation.
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
unit ssl_streamsec;
interface
uses
SysUtils, Classes,
blcksock, synsock, synautil, synacode,
TlsInternalServer, TlsSynaSock, TlsConst, StreamSecII, Asn1, X509Base,
SecUtils;
type
{:@exclude}
TMyTLSSynSockSlave = class(TTLSSynSockSlave)
protected
procedure SetMyTLSServer(const Value: TCustomTLSInternalServer);
function GetMyTLSServer: TCustomTLSInternalServer;
published
property MyTLSServer: TCustomTLSInternalServer read GetMyTLSServer write
SetMyTLSServer;
end;
{:@abstract(class implementing StreamSecII SSL plugin.)
Instance of this class will be created for each @link(TTCPBlockSocket).
You not need to create instance of this class, all is done by Synapse
itself!}
TSSLStreamSec = class(TCustomSSL)
protected
FSlave: TMyTLSSynSockSlave;
FIsServer: Boolean;
FTLSServer: TCustomTLSInternalServer;
FServerCreated: Boolean;
function SSLCheck: Boolean;
function Init(server:Boolean): Boolean;
function DeInit: Boolean;
function Prepare(server:Boolean): Boolean;
procedure NotTrustEvent(Sender: TObject; Cert: TASN1Struct; var
ExplicitTrust: Boolean);
function X500StrToStr(const Prefix: string; const Value: TX500String):
string;
function X501NameToStr(const Value: TX501Name): string;
function GetCert: PASN1Struct;
public
constructor Create(const Value: TTCPBlockSocket); override;
destructor Destroy; override;
{:See @inherited}
function LibVersion: String; override;
{:See @inherited}
function LibName: String; override;
{:See @inherited and @link(ssl_streamsec) for more details.}
function Connect: boolean; override;
{:See @inherited and @link(ssl_streamsec) for more details.}
function Accept: boolean; override;
{:See @inherited}
function Shutdown: boolean; override;
{:See @inherited}
function BiShutdown: boolean; override;
{:See @inherited}
function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function WaitingData: Integer; override;
{:See @inherited}
function GetSSLVersion: string; override;
{:See @inherited}
function GetPeerSubject: string; override;
{:See @inherited}
function GetPeerIssuer: string; override;
{:See @inherited}
function GetPeerName: string; override;
{:See @inherited}
function GetPeerFingerprint: string; override;
{:See @inherited}
function GetCertInfo: string; override;
published
{:TLS server for tuning of StreamSecII.}
property TLSServer: TCustomTLSInternalServer read FTLSServer write
FTLSServer;
end;
implementation
{==============================================================================}
procedure TMyTLSSynSockSlave.SetMyTLSServer(const Value:
TCustomTLSInternalServer);
begin
TLSServer := Value;
end;
function TMyTLSSynSockSlave.GetMyTLSServer: TCustomTLSInternalServer;
begin
Result := TLSServer;
end;
{==============================================================================}
constructor TSSLStreamSec.Create(const Value: TTCPBlockSocket);
begin
inherited Create(Value);
FSlave := nil;
FIsServer := False;
FTLSServer := nil;
end;
destructor TSSLStreamSec.Destroy;
begin
DeInit;
inherited Destroy;
end;
function TSSLStreamSec.LibVersion: String;
begin
Result := 'StreamSecII';
end;
function TSSLStreamSec.LibName: String;
begin
Result := 'ssl_streamsec';
end;
function TSSLStreamSec.SSLCheck: Boolean;
begin
Result := true;
FLastErrorDesc := '';
if not Assigned(FSlave) then
Exit;
FLastError := FSlave.ErrorCode;
if FLastError <> 0 then
begin
FLastErrorDesc := TlsConst.AlertMsg(FLastError);
end;
end;
procedure TSSLStreamSec.NotTrustEvent(Sender: TObject; Cert: TASN1Struct; var
ExplicitTrust: Boolean);
begin
ExplicitTrust := true;
end;
function TSSLStreamSec.Init(server:Boolean): Boolean;
var
st: TMemoryStream;
pass: ISecretKey;
ws: WideString;
begin
Result := False;
ws := FKeyPassword;
pass := TSecretKey.CreateBmpStr(PWideChar(ws), length(ws));
try
FIsServer := Server;
FSlave := TMyTLSSynSockSlave.CreateSocket(FSocket.Socket);
if Assigned(FTLSServer) then
FSlave.MyTLSServer := FTLSServer
else
if Assigned(TLSInternalServer.GlobalServer) then
FSlave.MyTLSServer := TLSInternalServer.GlobalServer
else begin
FSlave.MyTLSServer := TSimpleTLSInternalServer.Create(nil);
FServerCreated := True;
end;
if server then
FSlave.MyTLSServer.ClientOrServer := cosServerSide
else
FSlave.MyTLSServer.ClientOrServer := cosClientSide;
if not FVerifyCert then
begin
FSlave.MyTLSServer.OnCertNotTrusted := NotTrustEvent;
end;
FSlave.MyTLSServer.Options.VerifyServerName := [];
FSlave.MyTLSServer.Options.Export40Bit := prAllowed;
FSlave.MyTLSServer.Options.Export56Bit := prAllowed;
FSlave.MyTLSServer.Options.RequestClientCertificate := False;
FSlave.MyTLSServer.Options.RequireClientCertificate := False;
if server and FVerifyCert then
begin
FSlave.MyTLSServer.Options.RequestClientCertificate := True;
FSlave.MyTLSServer.Options.RequireClientCertificate := True;
end;
if FCertCAFile <> '' then
FSlave.MyTLSServer.LoadRootCertsFromFile(CertCAFile);
if FCertCA <> '' then
begin
st := TMemoryStream.Create;
try
WriteStrToStream(st, FCertCA);
st.Seek(0, soFromBeginning);
FSlave.MyTLSServer.LoadRootCertsFromStream(st);
finally
st.free;
end;
end;
if FTrustCertificateFile <> '' then
FSlave.MyTLSServer.LoadTrustedCertsFromFile(FTrustCertificateFile);
if FTrustCertificate <> '' then
begin
st := TMemoryStream.Create;
try
WriteStrToStream(st, FTrustCertificate);
st.Seek(0, soFromBeginning);
FSlave.MyTLSServer.LoadTrustedCertsFromStream(st);
finally
st.free;
end;
end;
if FPrivateKeyFile <> '' then
FSlave.MyTLSServer.LoadPrivateKeyRingFromFile(FPrivateKeyFile, pass);
//
FSlave.MyTLSServer.PrivateKeyRing.LoadPrivateKeyFromFile(FPrivateKeyFile, pass);
if FPrivateKey <> '' then
begin
st := TMemoryStream.Create;
try
WriteStrToStream(st, FPrivateKey);
st.Seek(0, soFromBeginning);
FSlave.MyTLSServer.LoadPrivateKeyRingFromStream(st, pass);
finally
st.free;
end;
end;
if FCertificateFile <> '' then
FSlave.MyTLSServer.LoadMyCertsFromFile(FCertificateFile);
if FCertificate <> '' then
begin
st := TMemoryStream.Create;
try
WriteStrToStream(st, FCertificate);
st.Seek(0, soFromBeginning);
FSlave.MyTLSServer.LoadMyCertsFromStream(st);
finally
st.free;
end;
end;
if FPFXfile <> '' then
FSlave.MyTLSServer.ImportFromPFX(FPFXfile, pass);
if server and FServerCreated then
begin
FSlave.MyTLSServer.Options.BulkCipherAES128 := prPrefer;
FSlave.MyTLSServer.Options.BulkCipherAES256 := prAllowed;
FSlave.MyTLSServer.Options.EphemeralECDHKeySize := ecs256;
FSlave.MyTLSServer.Options.SignatureRSA := prPrefer;
FSlave.MyTLSServer.Options.KeyAgreementRSA := prAllowed;
FSlave.MyTLSServer.Options.KeyAgreementECDHE := prAllowed;
FSlave.MyTLSServer.Options.KeyAgreementDHE := prPrefer;
FSlave.MyTLSServer.TLSSetupServer;
end;
Result := true;
finally
pass := nil;
end;
end;
function TSSLStreamSec.DeInit: Boolean;
var
obj: TObject;
begin
Result := True;
if assigned(FSlave) then
begin
FSlave.Close;
if FServerCreated then
obj := FSlave.TLSServer
else
obj := nil;
FSlave.Free;
obj.Free;
FSlave := nil;
end;
FSSLEnabled := false;
end;
function TSSLStreamSec.Prepare(server:Boolean): Boolean;
begin
Result := false;
DeInit;
if Init(server) then
Result := true
else
DeInit;
end;
function TSSLStreamSec.Connect: boolean;
begin
Result := False;
if FSocket.Socket = INVALID_SOCKET then
Exit;
if Prepare(false) then
begin
FSlave.Open;
SSLCheck;
if FLastError <> 0 then
Exit;
FSSLEnabled := True;
Result := True;
end;
end;
function TSSLStreamSec.Accept: boolean;
begin
Result := False;
if FSocket.Socket = INVALID_SOCKET then
Exit;
if Prepare(true) then
begin
FSlave.DoConnect;
SSLCheck;
if FLastError <> 0 then
Exit;
FSSLEnabled := True;
Result := True;
end;
end;
function TSSLStreamSec.Shutdown: boolean;
begin
Result := BiShutdown;
end;
function TSSLStreamSec.BiShutdown: boolean;
begin
DeInit;
Result := True;
end;
function TSSLStreamSec.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
var
l: integer;
begin
l := len;
FSlave.SendBuf(Buffer^, l, true);
Result := l;
SSLCheck;
end;
function TSSLStreamSec.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
var
l: integer;
begin
l := Len;
Result := FSlave.ReceiveBuf(Buffer^, l);
SSLCheck;
end;
function TSSLStreamSec.WaitingData: Integer;
begin
Result := 0;
while FSlave.Connected do begin
Result := FSlave.ReceiveLength;
if Result > 0 then
Break;
Sleep(1);
end;
end;
function TSSLStreamSec.GetSSLVersion: string;
begin
Result := 'SSLv3 or TLSv1';
end;
function TSSLStreamSec.GetCert: PASN1Struct;
begin
if FIsServer then
Result := FSlave.GetClientCert
else
Result := FSlave.GetServerCert;
end;
function TSSLStreamSec.GetPeerSubject: string;
var
XName: TX501Name;
Cert: PASN1Struct;
begin
Result := '';
Cert := GetCert;
if Assigned(cert) then
begin
ExtractSubject(Cert^,XName, false);
Result := X501NameToStr(XName);
end;
end;
function TSSLStreamSec.GetPeerName: string;
var
XName: TX501Name;
Cert: PASN1Struct;
begin
Result := '';
Cert := GetCert;
if Assigned(cert) then
begin
ExtractSubject(Cert^,XName, false);
Result := XName.commonName.Str;
end;
end;
function TSSLStreamSec.GetPeerIssuer: string;
var
XName: TX501Name;
Cert: PASN1Struct;
begin
Result := '';
Cert := GetCert;
if Assigned(cert) then
begin
ExtractIssuer(Cert^, XName, false);
Result := X501NameToStr(XName);
end;
end;
function TSSLStreamSec.GetPeerFingerprint: string;
var
Cert: PASN1Struct;
begin
Result := '';
Cert := GetCert;
if Assigned(cert) then
Result := MD5(Cert.ContentAsOctetString);
end;
function TSSLStreamSec.GetCertInfo: string;
var
Cert: PASN1Struct;
l: Tstringlist;
begin
Result := '';
Cert := GetCert;
if Assigned(cert) then
begin
l := TStringList.Create;
try
Asn1.RenderAsText(cert^, l, true, true, true, 2);
Result := l.Text;
finally
l.free;
end;
end;
end;
function TSSLStreamSec.X500StrToStr(const Prefix: string;
const Value: TX500String): string;
begin
if Value.Str = '' then
Result := ''
else
Result := '/' + Prefix + '=' + Value.Str;
end;
function TSSLStreamSec.X501NameToStr(const Value: TX501Name): string;
begin
Result := X500StrToStr('CN',Value.commonName) +
X500StrToStr('C',Value.countryName) +
X500StrToStr('L',Value.localityName) +
X500StrToStr('ST',Value.stateOrProvinceName) +
X500StrToStr('O',Value.organizationName) +
X500StrToStr('OU',Value.organizationalUnitName) +
X500StrToStr('T',Value.title) +
X500StrToStr('N',Value.name) +
X500StrToStr('G',Value.givenName) +
X500StrToStr('I',Value.initials) +
X500StrToStr('SN',Value.surname) +
X500StrToStr('GQ',Value.generationQualifier) +
X500StrToStr('DNQ',Value.dnQualifier) +
X500StrToStr('E',Value.emailAddress);
end;
{==============================================================================}
initialization
SSLImplementation := TSSLStreamSec;
finalization
end.
-------------------------------------------------------------------------
Take Surveys. Earn Cash. Influence the Future of IT
Join SourceForge.net's Techsay panel and you'll get the chance to share your
opinions on IT & business topics through brief surveys-and earn cash
http://www.techsay.com/default.php?page=join.php&p=sourceforge&CID=DEVDEV
_______________________________________________
synalist-public mailing list
[email protected]
https://lists.sourceforge.net/lists/listinfo/synalist-public
