Context Navigation

ssl_streamsec.pas

Last change on this file was 2, checked in by chronos, 13 years ago
Přidáno: Základní kostra projektu. Přidáno: Knihovna synapse.
File size: 16.8 KB

Line
1	{==============================================================================\|
2	\| Project : Ararat Synapse \| 001.000.006 \|
3	\|==============================================================================\|
4	\| Content: SSL support by StreamSecII \|
5	\|==============================================================================\|
6	\| Copyright (c)1999-2005, Lukas Gebauer \|
7	\| All rights reserved. \|
8	\| \|
9	\| Redistribution and use in source and binary forms, with or without \|
10	\| modification, are permitted provided that the following conditions are met: \|
11	\| \|
12	\| Redistributions of source code must retain the above copyright notice, this \|
13	\| list of conditions and the following disclaimer. \|
14	\| \|
15	\| Redistributions in binary form must reproduce the above copyright notice, \|
16	\| this list of conditions and the following disclaimer in the documentation \|
17	\| and/or other materials provided with the distribution. \|
18	\| \|
19	\| Neither the name of Lukas Gebauer nor the names of its contributors may \|
20	\| be used to endorse or promote products derived from this software without \|
21	\| specific prior written permission. \|
22	\| \|
23	\| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" \|
24	\| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE \|
25	\| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE \|
26	\| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR \|
27	\| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL \|
28	\| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR \|
29	\| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER \|
30	\| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT \|
31	\| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY \|
32	\| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH \|
33	\| DAMAGE. \|
34	\|==============================================================================\|
35	\| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).\|
36	\| Portions created by Lukas Gebauer are Copyright (c)2005. \|
37	\| All Rights Reserved. \|
38	\|==============================================================================\|
39	\| Contributor(s): \|
40	\| Henrick Hellström <henrick@streamsec.se> \|
41	\|==============================================================================\|
42	\| History: see HISTORY.HTM from distribution package \|
43	\| (Found at URL: http://www.ararat.cz/synapse/) \|
44	\|==============================================================================}
45
46	{:@abstract(SSL plugin for StreamSecII or OpenStreamSecII)
47
48	StreamSecII is native pascal library, you not need any external libraries!
49
50	You can tune lot of StreamSecII properties by using your GlobalServer. If you not
51	using your GlobalServer, then this plugin create own TSimpleTLSInternalServer
52	instance for each TCP connection. Formore information about GlobalServer usage
53	refer StreamSecII documentation.
54
55	If you are not using key and certificate by GlobalServer, then you can use
56	properties of this plugin instead, but this have limited features and
57	@link(TCustomSSL.KeyPassword) not working properly yet!
58
59	For handling keys and certificates you can use this properties:
60	@link(TCustomSSL.CertCAFile), @link(TCustomSSL.CertCA),
61	@link(TCustomSSL.TrustCertificateFile), @link(TCustomSSL.TrustCertificate),
62	@link(TCustomSSL.PrivateKeyFile), @link(TCustomSSL.PrivateKey),
63	@link(TCustomSSL.CertificateFile), @link(TCustomSSL.Certificate),
64	@link(TCustomSSL.PFXFile). For usage of this properties and for possible formats
65	of keys and certificates refer to StreamSecII documentation.
66	}
67
68	{$IFDEF FPC}
69	{$MODE DELPHI}
70	{$ENDIF}
71	{$H+}
72
73	unit ssl_streamsec;
74
75	interface
76
77	uses
78	SysUtils, Classes,
79	blcksock, synsock, synautil, synacode,
80	TlsInternalServer, TlsSynaSock, TlsConst, StreamSecII, Asn1, X509Base,
81	SecUtils;
82
83	type
84	{:@exclude}
85	TMyTLSSynSockSlave = class(TTLSSynSockSlave)
86	protected
87	procedure SetMyTLSServer(const Value: TCustomTLSInternalServer);
88	function GetMyTLSServer: TCustomTLSInternalServer;
89	published
90	property MyTLSServer: TCustomTLSInternalServer read GetMyTLSServer write SetMyTLSServer;
91	end;
92
93	{:@abstract(class implementing StreamSecII SSL plugin.)
94	Instance of this class will be created for each @link(TTCPBlockSocket).
95	You not need to create instance of this class, all is done by Synapse itself!}
96	TSSLStreamSec = class(TCustomSSL)
97	protected
98	FSlave: TMyTLSSynSockSlave;
99	FIsServer: Boolean;
100	FTLSServer: TCustomTLSInternalServer;
101	FServerCreated: Boolean;
102	function SSLCheck: Boolean;
103	function Init(server:Boolean): Boolean;
104	function DeInit: Boolean;
105	function Prepare(server:Boolean): Boolean;
106	procedure NotTrustEvent(Sender: TObject; Cert: TASN1Struct; var ExplicitTrust: Boolean);
107	function X500StrToStr(const Prefix: string; const Value: TX500String): string;
108	function X501NameToStr(const Value: TX501Name): string;
109	function GetCert: PASN1Struct;
110	public
111	constructor Create(const Value: TTCPBlockSocket); override;
112	destructor Destroy; override;
113	{:See @inherited}
114	function LibVersion: String; override;
115	{:See @inherited}
116	function LibName: String; override;
117	{:See @inherited and @link(ssl_streamsec) for more details.}
118	function Connect: boolean; override;
119	{:See @inherited and @link(ssl_streamsec) for more details.}
120	function Accept: boolean; override;
121	{:See @inherited}
122	function Shutdown: boolean; override;
123	{:See @inherited}
124	function BiShutdown: boolean; override;
125	{:See @inherited}
126	function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
127	{:See @inherited}
128	function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
129	{:See @inherited}
130	function WaitingData: Integer; override;
131	{:See @inherited}
132	function GetSSLVersion: string; override;
133	{:See @inherited}
134	function GetPeerSubject: string; override;
135	{:See @inherited}
136	function GetPeerIssuer: string; override;
137	{:See @inherited}
138	function GetPeerName: string; override;
139	{:See @inherited}
140	function GetPeerFingerprint: string; override;
141	{:See @inherited}
142	function GetCertInfo: string; override;
143	published
144	{:TLS server for tuning of StreamSecII.}
145	property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer;
146	end;
147
148	implementation
149
150	{==============================================================================}
151	procedure TMyTLSSynSockSlave.SetMyTLSServer(const Value: TCustomTLSInternalServer);
152	begin
153	TLSServer := Value;
154	end;
155
156	function TMyTLSSynSockSlave.GetMyTLSServer: TCustomTLSInternalServer;
157	begin
158	Result := TLSServer;
159	end;
160
161	{==============================================================================}
162
163	constructor TSSLStreamSec.Create(const Value: TTCPBlockSocket);
164	begin
165	inherited Create(Value);
166	FSlave := nil;
167	FIsServer := False;
168	FTLSServer := nil;
169	end;
170
171	destructor TSSLStreamSec.Destroy;
172	begin
173	DeInit;
174	inherited Destroy;
175	end;
176
177	function TSSLStreamSec.LibVersion: String;
178	begin
179	Result := 'StreamSecII';
180	end;
181
182	function TSSLStreamSec.LibName: String;
183	begin
184	Result := 'ssl_streamsec';
185	end;
186
187	function TSSLStreamSec.SSLCheck: Boolean;
188	begin
189	Result := true;
190	FLastErrorDesc := '';
191	if not Assigned(FSlave) then
192	Exit;
193	FLastError := FSlave.ErrorCode;
194	if FLastError <> 0 then
195	begin
196	FLastErrorDesc := TlsConst.AlertMsg(FLastError);
197	end;
198	end;
199
200	procedure TSSLStreamSec.NotTrustEvent(Sender: TObject; Cert: TASN1Struct; var ExplicitTrust: Boolean);
201	begin
202	ExplicitTrust := true;
203	end;
204
205	function TSSLStreamSec.Init(server:Boolean): Boolean;
206	var
207	st: TMemoryStream;
208	pass: ISecretKey;
209	ws: WideString;
210	begin
211	Result := False;
212	ws := FKeyPassword;
213	pass := TSecretKey.CreateBmpStr(PWideChar(ws), length(ws));
214	try
215	FIsServer := Server;
216	FSlave := TMyTLSSynSockSlave.CreateSocket(FSocket.Socket);
217	if Assigned(FTLSServer) then
218	FSlave.MyTLSServer := FTLSServer
219	else
220	if Assigned(TLSInternalServer.GlobalServer) then
221	FSlave.MyTLSServer := TLSInternalServer.GlobalServer
222	else begin
223	FSlave.MyTLSServer := TSimpleTLSInternalServer.Create(nil);
224	FServerCreated := True;
225	end;
226	if server then
227	FSlave.MyTLSServer.ClientOrServer := cosServerSide
228	else
229	FSlave.MyTLSServer.ClientOrServer := cosClientSide;
230	if not FVerifyCert then
231	begin
232	FSlave.MyTLSServer.OnCertNotTrusted := NotTrustEvent;
233	end;
234	FSlave.MyTLSServer.Options.VerifyServerName := [];
235	FSlave.MyTLSServer.Options.Export40Bit := prAllowed;
236	FSlave.MyTLSServer.Options.Export56Bit := prAllowed;
237	FSlave.MyTLSServer.Options.RequestClientCertificate := False;
238	FSlave.MyTLSServer.Options.RequireClientCertificate := False;
239	if server and FVerifyCert then
240	begin
241	FSlave.MyTLSServer.Options.RequestClientCertificate := True;
242	FSlave.MyTLSServer.Options.RequireClientCertificate := True;
243	end;
244	if FCertCAFile <> '' then
245	FSlave.MyTLSServer.LoadRootCertsFromFile(CertCAFile);
246	if FCertCA <> '' then
247	begin
248	st := TMemoryStream.Create;
249	try
250	WriteStrToStream(st, FCertCA);
251	st.Seek(0, soFromBeginning);
252	FSlave.MyTLSServer.LoadRootCertsFromStream(st);
253	finally
254	st.free;
255	end;
256	end;
257	if FTrustCertificateFile <> '' then
258	FSlave.MyTLSServer.LoadTrustedCertsFromFile(FTrustCertificateFile);
259	if FTrustCertificate <> '' then
260	begin
261	st := TMemoryStream.Create;
262	try
263	WriteStrToStream(st, FTrustCertificate);
264	st.Seek(0, soFromBeginning);
265	FSlave.MyTLSServer.LoadTrustedCertsFromStream(st);
266	finally
267	st.free;
268	end;
269	end;
270	if FPrivateKeyFile <> '' then
271	FSlave.MyTLSServer.LoadPrivateKeyRingFromFile(FPrivateKeyFile, pass);
272	// FSlave.MyTLSServer.PrivateKeyRing.LoadPrivateKeyFromFile(FPrivateKeyFile, pass);
273	if FPrivateKey <> '' then
274	begin
275	st := TMemoryStream.Create;
276	try
277	WriteStrToStream(st, FPrivateKey);
278	st.Seek(0, soFromBeginning);
279	FSlave.MyTLSServer.LoadPrivateKeyRingFromStream(st, pass);
280	finally
281	st.free;
282	end;
283	end;
284	if FCertificateFile <> '' then
285	FSlave.MyTLSServer.LoadMyCertsFromFile(FCertificateFile);
286	if FCertificate <> '' then
287	begin
288	st := TMemoryStream.Create;
289	try
290	WriteStrToStream(st, FCertificate);
291	st.Seek(0, soFromBeginning);
292	FSlave.MyTLSServer.LoadMyCertsFromStream(st);
293	finally
294	st.free;
295	end;
296	end;
297	if FPFXfile <> '' then
298	FSlave.MyTLSServer.ImportFromPFX(FPFXfile, pass);
299	if server and FServerCreated then
300	begin
301	FSlave.MyTLSServer.Options.BulkCipherAES128 := prPrefer;
302	FSlave.MyTLSServer.Options.BulkCipherAES256 := prAllowed;
303	FSlave.MyTLSServer.Options.EphemeralECDHKeySize := ecs256;
304	FSlave.MyTLSServer.Options.SignatureRSA := prPrefer;
305	FSlave.MyTLSServer.Options.KeyAgreementRSA := prAllowed;
306	FSlave.MyTLSServer.Options.KeyAgreementECDHE := prAllowed;
307	FSlave.MyTLSServer.Options.KeyAgreementDHE := prPrefer;
308	FSlave.MyTLSServer.TLSSetupServer;
309	end;
310	Result := true;
311	finally
312	pass := nil;
313	end;
314	end;
315
316	function TSSLStreamSec.DeInit: Boolean;
317	var
318	obj: TObject;
319	begin
320	Result := True;
321	if assigned(FSlave) then
322	begin
323	FSlave.Close;
324	if FServerCreated then
325	obj := FSlave.TLSServer
326	else
327	obj := nil;
328	FSlave.Free;
329	obj.Free;
330	FSlave := nil;
331	end;
332	FSSLEnabled := false;
333	end;
334
335	function TSSLStreamSec.Prepare(server:Boolean): Boolean;
336	begin
337	Result := false;
338	DeInit;
339	if Init(server) then
340	Result := true
341	else
342	DeInit;
343	end;
344
345	function TSSLStreamSec.Connect: boolean;
346	begin
347	Result := False;
348	if FSocket.Socket = INVALID_SOCKET then
349	Exit;
350	if Prepare(false) then
351	begin
352	FSlave.Open;
353	SSLCheck;
354	if FLastError <> 0 then
355	Exit;
356	FSSLEnabled := True;
357	Result := True;
358	end;
359	end;
360
361	function TSSLStreamSec.Accept: boolean;
362	begin
363	Result := False;
364	if FSocket.Socket = INVALID_SOCKET then
365	Exit;
366	if Prepare(true) then
367	begin
368	FSlave.DoConnect;
369	SSLCheck;
370	if FLastError <> 0 then
371	Exit;
372	FSSLEnabled := True;
373	Result := True;
374	end;
375	end;
376
377	function TSSLStreamSec.Shutdown: boolean;
378	begin
379	Result := BiShutdown;
380	end;
381
382	function TSSLStreamSec.BiShutdown: boolean;
383	begin
384	DeInit;
385	Result := True;
386	end;
387
388	function TSSLStreamSec.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
389	var
390	l: integer;
391	begin
392	l := len;
393	FSlave.SendBuf(Buffer^, l, true);
394	Result := l;
395	SSLCheck;
396	end;
397
398	function TSSLStreamSec.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
399	var
400	l: integer;
401	begin
402	l := Len;
403	Result := FSlave.ReceiveBuf(Buffer^, l);
404	SSLCheck;
405	end;
406
407	function TSSLStreamSec.WaitingData: Integer;
408	begin
409	Result := 0;
410	while FSlave.Connected do begin
411	Result := FSlave.ReceiveLength;
412	if Result > 0 then
413	Break;
414	Sleep(1);
415	end;
416	end;
417
418	function TSSLStreamSec.GetSSLVersion: string;
419	begin
420	Result := 'SSLv3 or TLSv1';
421	end;
422
423	function TSSLStreamSec.GetCert: PASN1Struct;
424	begin
425	if FIsServer then
426	Result := FSlave.GetClientCert
427	else
428	Result := FSlave.GetServerCert;
429	end;
430
431	function TSSLStreamSec.GetPeerSubject: string;
432	var
433	XName: TX501Name;
434	Cert: PASN1Struct;
435	begin
436	Result := '';
437	Cert := GetCert;
438	if Assigned(cert) then
439	begin
440	ExtractSubject(Cert^,XName, false);
441	Result := X501NameToStr(XName);
442	end;
443	end;
444
445	function TSSLStreamSec.GetPeerName: string;
446	var
447	XName: TX501Name;
448	Cert: PASN1Struct;
449	begin
450	Result := '';
451	Cert := GetCert;
452	if Assigned(cert) then
453	begin
454	ExtractSubject(Cert^,XName, false);
455	Result := XName.commonName.Str;
456	end;
457	end;
458
459	function TSSLStreamSec.GetPeerIssuer: string;
460	var
461	XName: TX501Name;
462	Cert: PASN1Struct;
463	begin
464	Result := '';
465	Cert := GetCert;
466	if Assigned(cert) then
467	begin
468	ExtractIssuer(Cert^, XName, false);
469	Result := X501NameToStr(XName);
470	end;
471	end;
472
473	function TSSLStreamSec.GetPeerFingerprint: string;
474	var
475	Cert: PASN1Struct;
476	begin
477	Result := '';
478	Cert := GetCert;
479	if Assigned(cert) then
480	Result := MD5(Cert.ContentAsOctetString);
481	end;
482
483	function TSSLStreamSec.GetCertInfo: string;
484	var
485	Cert: PASN1Struct;
486	l: Tstringlist;
487	begin
488	Result := '';
489	Cert := GetCert;
490	if Assigned(cert) then
491	begin
492	l := TStringList.Create;
493	try
494	Asn1.RenderAsText(cert^, l, true, true, true, 2);
495	Result := l.Text;
496	finally
497	l.free;
498	end;
499	end;
500	end;
501
502	function TSSLStreamSec.X500StrToStr(const Prefix: string;
503	const Value: TX500String): string;
504	begin
505	if Value.Str = '' then
506	Result := ''
507	else
508	Result := '/' + Prefix + '=' + Value.Str;
509	end;
510
511	function TSSLStreamSec.X501NameToStr(const Value: TX501Name): string;
512	begin
513	Result := X500StrToStr('CN',Value.commonName) +
514	X500StrToStr('C',Value.countryName) +
515	X500StrToStr('L',Value.localityName) +
516	X500StrToStr('ST',Value.stateOrProvinceName) +
517	X500StrToStr('O',Value.organizationName) +
518	X500StrToStr('OU',Value.organizationalUnitName) +
519	X500StrToStr('T',Value.title) +
520	X500StrToStr('N',Value.name) +
521	X500StrToStr('G',Value.givenName) +
522	X500StrToStr('I',Value.initials) +
523	X500StrToStr('SN',Value.surname) +
524	X500StrToStr('GQ',Value.generationQualifier) +
525	X500StrToStr('DNQ',Value.dnQualifier) +
526	X500StrToStr('E',Value.emailAddress);
527	end;
528
529
530	{==============================================================================}
531
532	initialization
533	SSLImplementation := TSSLStreamSec;
534
535	finalization
536
537	end.
538
539

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: trunk/Packages/synapse/source/lib/ssl_streamsec.pas

Download in other formats: