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

Last change on this file was 60, checked in by chronos, 13 years ago
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
48StreamSecII is native pascal library, you not need any external libraries!
49
50You can tune lot of StreamSecII properties by using your GlobalServer. If you not
51using your GlobalServer, then this plugin create own TSimpleTLSInternalServer
52instance for each TCP connection. Formore information about GlobalServer usage
53refer StreamSecII documentation.
54
55If you are not using key and certificate by GlobalServer, then you can use
56properties of this plugin instead, but this have limited features and
57@link(TCustomSSL.KeyPassword) not working properly yet!
58
59For 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
65of keys and certificates refer to StreamSecII documentation.
66}
67
68{$IFDEF FPC}
69 {$MODE DELPHI}
70{$ENDIF}
71{$H+}
72
73unit ssl_streamsec;
74
75interface
76
77uses
78 SysUtils, Classes,
79 blcksock, synsock, synautil, synacode,
80 TlsInternalServer, TlsSynaSock, TlsConst, StreamSecII, Asn1, X509Base,
81 SecUtils;
82
83type
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
148implementation
149
150{==============================================================================}
151procedure TMyTLSSynSockSlave.SetMyTLSServer(const Value: TCustomTLSInternalServer);
152begin
153 TLSServer := Value;
154end;
155
156function TMyTLSSynSockSlave.GetMyTLSServer: TCustomTLSInternalServer;
157begin
158 Result := TLSServer;
159end;
160
161{==============================================================================}
162
163constructor TSSLStreamSec.Create(const Value: TTCPBlockSocket);
164begin
165 inherited Create(Value);
166 FSlave := nil;
167 FIsServer := False;
168 FTLSServer := nil;
169end;
170
171destructor TSSLStreamSec.Destroy;
172begin
173 DeInit;
174 inherited Destroy;
175end;
176
177function TSSLStreamSec.LibVersion: String;
178begin
179 Result := 'StreamSecII';
180end;
181
182function TSSLStreamSec.LibName: String;
183begin
184 Result := 'ssl_streamsec';
185end;
186
187function TSSLStreamSec.SSLCheck: Boolean;
188begin
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;
198end;
199
200procedure TSSLStreamSec.NotTrustEvent(Sender: TObject; Cert: TASN1Struct; var ExplicitTrust: Boolean);
201begin
202 ExplicitTrust := true;
203end;
204
205function TSSLStreamSec.Init(server:Boolean): Boolean;
206var
207 st: TMemoryStream;
208 pass: ISecretKey;
209 ws: WideString;
210begin
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;
314end;
315
316function TSSLStreamSec.DeInit: Boolean;
317var
318 obj: TObject;
319begin
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;
333end;
334
335function TSSLStreamSec.Prepare(server:Boolean): Boolean;
336begin
337 Result := false;
338 DeInit;
339 if Init(server) then
340 Result := true
341 else
342 DeInit;
343end;
344
345function TSSLStreamSec.Connect: boolean;
346begin
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;
359end;
360
361function TSSLStreamSec.Accept: boolean;
362begin
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;
375end;
376
377function TSSLStreamSec.Shutdown: boolean;
378begin
379 Result := BiShutdown;
380end;
381
382function TSSLStreamSec.BiShutdown: boolean;
383begin
384 DeInit;
385 Result := True;
386end;
387
388function TSSLStreamSec.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
389var
390 l: integer;
391begin
392 l := len;
393 FSlave.SendBuf(Buffer^, l, true);
394 Result := l;
395 SSLCheck;
396end;
397
398function TSSLStreamSec.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
399var
400 l: integer;
401begin
402 l := Len;
403 Result := FSlave.ReceiveBuf(Buffer^, l);
404 SSLCheck;
405end;
406
407function TSSLStreamSec.WaitingData: Integer;
408begin
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;
416end;
417
418function TSSLStreamSec.GetSSLVersion: string;
419begin
420 Result := 'SSLv3 or TLSv1';
421end;
422
423function TSSLStreamSec.GetCert: PASN1Struct;
424begin
425 if FIsServer then
426 Result := FSlave.GetClientCert
427 else
428 Result := FSlave.GetServerCert;
429end;
430
431function TSSLStreamSec.GetPeerSubject: string;
432var
433 XName: TX501Name;
434 Cert: PASN1Struct;
435begin
436 Result := '';
437 Cert := GetCert;
438 if Assigned(cert) then
439 begin
440 ExtractSubject(Cert^,XName, false);
441 Result := X501NameToStr(XName);
442 end;
443end;
444
445function TSSLStreamSec.GetPeerName: string;
446var
447 XName: TX501Name;
448 Cert: PASN1Struct;
449begin
450 Result := '';
451 Cert := GetCert;
452 if Assigned(cert) then
453 begin
454 ExtractSubject(Cert^,XName, false);
455 Result := XName.commonName.Str;
456 end;
457end;
458
459function TSSLStreamSec.GetPeerIssuer: string;
460var
461 XName: TX501Name;
462 Cert: PASN1Struct;
463begin
464 Result := '';
465 Cert := GetCert;
466 if Assigned(cert) then
467 begin
468 ExtractIssuer(Cert^, XName, false);
469 Result := X501NameToStr(XName);
470 end;
471end;
472
473function TSSLStreamSec.GetPeerFingerprint: string;
474var
475 Cert: PASN1Struct;
476begin
477 Result := '';
478 Cert := GetCert;
479 if Assigned(cert) then
480 Result := MD5(Cert.ContentAsOctetString);
481end;
482
483function TSSLStreamSec.GetCertInfo: string;
484var
485 Cert: PASN1Struct;
486 l: Tstringlist;
487begin
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;
500end;
501
502function TSSLStreamSec.X500StrToStr(const Prefix: string;
503 const Value: TX500String): string;
504begin
505 if Value.Str = '' then
506 Result := ''
507 else
508 Result := '/' + Prefix + '=' + Value.Str;
509end;
510
511function TSSLStreamSec.X501NameToStr(const Value: TX501Name): string;
512begin
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);
527end;
528
529
530{==============================================================================}
531
532initialization
533 SSLImplementation := TSSLStreamSec;
534
535finalization
536
537end.
538
539
Note: See TracBrowser for help on using the repository browser.