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

Last change on this file was 60, checked in by chronos, 13 years ago
File size: 19.1 KB
Line 
1{==============================================================================|
2| Project : Ararat Synapse | 001.001.000 |
3|==============================================================================|
4| Content: SSL/SSH support by Peter Gutmann's CryptLib |
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|==============================================================================|
41| History: see HISTORY.HTM from distribution package |
42| (Found at URL: http://www.ararat.cz/synapse/) |
43|==============================================================================}
44
45{:@abstract(SSL/SSH plugin for CryptLib)
46
47This plugin requires cl32.dll at least version 3.2.0! It can be used on Win32
48and Linux. This library is staticly linked - when you compile your application
49with this plugin, you MUST distribute it with Cryptib library, otherwise you
50cannot run your application!
51
52It can work with keys and certificates stored as PKCS#15 only! It must be stored
53as disk file only, you cannot load them from memory! Each file can hold multiple
54keys and certificates. You must identify it by 'label' stored in
55@link(TSSLCryptLib.PrivateKeyLabel).
56
57If you need to use secure connection and authorize self by certificate
58(each SSL/TLS server or client with client authorization), then use
59@link(TCustomSSL.PrivateKeyFile), @link(TSSLCryptLib.PrivateKeyLabel) and
60@link(TCustomSSL.KeyPassword) properties.
61
62If you need to use server what verifying client certificates, then use
63@link(TCustomSSL.CertCAFile) as PKCS#15 file with public keyas of allowed clients. Clients
64with non-matching certificates will be rejected by cryptLib.
65
66This plugin is capable to create Ad-Hoc certificates. When you start SSL/TLS
67server without explicitly assigned key and certificate, then this plugin create
68Ad-Hoc key and certificate for each incomming connection by self. It slowdown
69accepting of new connections!
70
71You can use this plugin for SSHv2 connections too! You must explicitly set
72@link(TCustomSSL.SSLType) to value LT_SSHv2 and set @link(TCustomSSL.username)
73and @link(TCustomSSL.password). You can use special SSH channels too, see
74@link(TCustomSSL).
75}
76
77{$IFDEF FPC}
78 {$MODE DELPHI}
79{$ENDIF}
80{$H+}
81
82unit ssl_cryptlib;
83
84interface
85
86uses
87 SysUtils,
88 blcksock, synsock, synautil, synacode,
89 cryptlib;
90
91type
92 {:@abstract(class implementing CryptLib SSL/SSH plugin.)
93 Instance of this class will be created for each @link(TTCPBlockSocket).
94 You not need to create instance of this class, all is done by Synapse itself!}
95 TSSLCryptLib = class(TCustomSSL)
96 protected
97 FCryptSession: CRYPT_SESSION;
98 FPrivateKeyLabel: string;
99 FDelCert: Boolean;
100 FReadBuffer: string;
101 function SSLCheck(Value: integer): Boolean;
102 function Init(server:Boolean): Boolean;
103 function DeInit: Boolean;
104 function Prepare(server:Boolean): Boolean;
105 function GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string;
106 function CreateSelfSignedCert(Host: string): Boolean; override;
107 function PopAll: string;
108 public
109 {:See @inherited}
110 constructor Create(const Value: TTCPBlockSocket); override;
111 destructor Destroy; override;
112 {:See @inherited}
113 function LibVersion: String; override;
114 {:See @inherited}
115 function LibName: String; override;
116 {:See @inherited}
117 procedure Assign(const Value: TCustomSSL); override;
118 {:See @inherited and @link(ssl_cryptlib) for more details.}
119 function Connect: boolean; override;
120 {:See @inherited and @link(ssl_cryptlib) for more details.}
121 function Accept: boolean; override;
122 {:See @inherited}
123 function Shutdown: boolean; override;
124 {:See @inherited}
125 function BiShutdown: boolean; override;
126 {:See @inherited}
127 function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
128 {:See @inherited}
129 function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
130 {:See @inherited}
131 function WaitingData: Integer; override;
132 {:See @inherited}
133 function GetSSLVersion: string; override;
134 {:See @inherited}
135 function GetPeerSubject: string; override;
136 {:See @inherited}
137 function GetPeerIssuer: string; override;
138 {:See @inherited}
139 function GetPeerName: string; override;
140 {:See @inherited}
141 function GetPeerFingerprint: string; override;
142 published
143 {:name of certificate/key within PKCS#15 file. It can hold more then one
144 certificate/key and each certificate/key must have unique label within one file.}
145 property PrivateKeyLabel: string read FPrivateKeyLabel Write FPrivateKeyLabel;
146 end;
147
148implementation
149
150{==============================================================================}
151
152constructor TSSLCryptLib.Create(const Value: TTCPBlockSocket);
153begin
154 inherited Create(Value);
155 FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
156 FPrivateKeyLabel := 'synapse';
157 FDelCert := false;
158end;
159
160destructor TSSLCryptLib.Destroy;
161begin
162 DeInit;
163 inherited Destroy;
164end;
165
166procedure TSSLCryptLib.Assign(const Value: TCustomSSL);
167begin
168 inherited Assign(Value);
169 if Value is TSSLCryptLib then
170 begin
171 FPrivateKeyLabel := TSSLCryptLib(Value).privatekeyLabel;
172 end;
173end;
174
175function TSSLCryptLib.GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string;
176var
177 l: integer;
178begin
179 l := 0;
180 cryptGetAttributeString(cryptHandle, attributeType, nil, l);
181 setlength(Result, l);
182 cryptGetAttributeString(cryptHandle, attributeType, pointer(Result), l);
183 setlength(Result, l);
184end;
185
186function TSSLCryptLib.LibVersion: String;
187var
188 x: integer;
189begin
190 Result := GetString(CRYPT_UNUSED, CRYPT_OPTION_INFO_DESCRIPTION);
191 cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MAJORVERSION, x);
192 Result := Result + ' v' + IntToStr(x);
193 cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MINORVERSION, x);
194 Result := Result + '.' + IntToStr(x);
195 cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_STEPPING, x);
196 Result := Result + '.' + IntToStr(x);
197end;
198
199function TSSLCryptLib.LibName: String;
200begin
201 Result := 'ssl_cryptlib';
202end;
203
204function TSSLCryptLib.SSLCheck(Value: integer): Boolean;
205begin
206 Result := true;
207 FLastErrorDesc := '';
208 if Value = CRYPT_ERROR_COMPLETE then
209 Value := 0;
210 FLastError := Value;
211 if FLastError <> 0 then
212 begin
213 Result := False;
214 FLastErrorDesc := GetString(FCryptSession, CRYPT_ATTRIBUTE_INT_ERRORMESSAGE);
215 end;
216end;
217
218function TSSLCryptLib.CreateSelfSignedCert(Host: string): Boolean;
219var
220 privateKey: CRYPT_CONTEXT;
221 keyset: CRYPT_KEYSET;
222 cert: CRYPT_CERTIFICATE;
223 publicKey: CRYPT_CONTEXT;
224begin
225 Result := False;
226 if FPrivatekeyFile = '' then
227 FPrivatekeyFile := GetTempFile('', 'key');
228 cryptCreateContext(privateKey, CRYPT_UNUSED, CRYPT_ALGO_RSA);
229 cryptSetAttributeString(privateKey, CRYPT_CTXINFO_LABEL, Pointer(FPrivatekeyLabel),
230 Length(FPrivatekeyLabel));
231 cryptSetAttribute(privateKey, CRYPT_CTXINFO_KEYSIZE, 1024);
232 cryptGenerateKey(privateKey);
233 cryptKeysetOpen(keyset, CRYPT_UNUSED, CRYPT_KEYSET_FILE, PChar(FPrivatekeyFile), CRYPT_KEYOPT_CREATE);
234 FDelCert := True;
235 cryptAddPrivateKey(keyset, privateKey, PChar(FKeyPassword));
236 cryptCreateCert(cert, CRYPT_UNUSED, CRYPT_CERTTYPE_CERTIFICATE);
237 cryptSetAttribute(cert, CRYPT_CERTINFO_XYZZY, 1);
238 cryptGetPublicKey(keyset, publicKey, CRYPT_KEYID_NAME, PChar(FPrivatekeyLabel));
239 cryptSetAttribute(cert, CRYPT_CERTINFO_SUBJECTPUBLICKEYINFO, publicKey);
240 cryptSetAttributeString(cert, CRYPT_CERTINFO_COMMONNAME, Pointer(host), Length(host));
241 cryptSignCert(cert, privateKey);
242 cryptAddPublicKey(keyset, cert);
243 cryptKeysetClose(keyset);
244 cryptDestroyCert(cert);
245 cryptDestroyContext(privateKey);
246 cryptDestroyContext(publicKey);
247 Result := True;
248end;
249
250function TSSLCryptLib.PopAll: string;
251const
252 BufferMaxSize = 32768;
253var
254 Outbuffer: string;
255 WriteLen: integer;
256begin
257 Result := '';
258 repeat
259 setlength(outbuffer, BufferMaxSize);
260 Writelen := 0;
261 SSLCheck(CryptPopData(FCryptSession, @OutBuffer[1], BufferMaxSize, Writelen));
262 if FLastError <> 0 then
263 Break;
264 if WriteLen > 0 then
265 begin
266 setlength(outbuffer, WriteLen);
267 Result := Result + outbuffer;
268 end;
269 until WriteLen = 0;
270end;
271
272function TSSLCryptLib.Init(server:Boolean): Boolean;
273var
274 st: CRYPT_SESSION_TYPE;
275 keysetobj: CRYPT_KEYSET;
276 cryptContext: CRYPT_CONTEXT;
277 x: integer;
278begin
279 Result := False;
280 FLastErrorDesc := '';
281 FLastError := 0;
282 FDelCert := false;
283 FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
284 if server then
285 case FSSLType of
286 LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1:
287 st := CRYPT_SESSION_SSL_SERVER;
288 LT_SSHv2:
289 st := CRYPT_SESSION_SSH_SERVER;
290 else
291 Exit;
292 end
293 else
294 case FSSLType of
295 LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1:
296 st := CRYPT_SESSION_SSL;
297 LT_SSHv2:
298 st := CRYPT_SESSION_SSH;
299 else
300 Exit;
301 end;
302 if not SSLCheck(cryptCreateSession(FcryptSession, CRYPT_UNUSED, st)) then
303 Exit;
304 x := -1;
305 case FSSLType of
306 LT_SSLv3:
307 x := 0;
308 LT_TLSv1:
309 x := 1;
310 LT_TLSv1_1:
311 x := 2;
312 end;
313 if x >= 0 then
314 if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x)) then
315 Exit;
316 if FUsername <> '' then
317 begin
318 cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_USERNAME,
319 Pointer(FUsername), Length(FUsername));
320 cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_PASSWORD,
321 Pointer(FPassword), Length(FPassword));
322 end;
323 if FSSLType = LT_SSHv2 then
324 if FSSHChannelType <> '' then
325 begin
326 cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL, CRYPT_UNUSED);
327 cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_TYPE,
328 Pointer(FSSHChannelType), Length(FSSHChannelType));
329 if FSSHChannelArg1 <> '' then
330 cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG1,
331 Pointer(FSSHChannelArg1), Length(FSSHChannelArg1));
332 if FSSHChannelArg2 <> '' then
333 cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG2,
334 Pointer(FSSHChannelArg2), Length(FSSHChannelArg2));
335 end;
336
337
338 if server and (FPrivatekeyFile = '') then
339 begin
340 if FPrivatekeyLabel = '' then
341 FPrivatekeyLabel := 'synapse';
342 if FkeyPassword = '' then
343 FkeyPassword := 'synapse';
344 CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP));
345 end;
346
347 if (FPrivatekeyLabel <> '') and (FPrivatekeyFile <> '') then
348 begin
349 if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE,
350 PChar(FPrivatekeyFile), CRYPT_KEYOPT_READONLY)) then
351 Exit;
352 try
353 if not SSLCheck(cryptGetPrivateKey(KeySetObj, cryptcontext, CRYPT_KEYID_NAME,
354 PChar(FPrivatekeyLabel), PChar(FKeyPassword))) then
355 Exit;
356 if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_PRIVATEKEY,
357 cryptcontext)) then
358 Exit;
359 finally
360 cryptKeysetClose(keySetObj);
361 cryptDestroyContext(cryptcontext);
362 end;
363 end;
364 if server and FVerifyCert then
365 begin
366 if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE,
367 PChar(FCertCAFile), CRYPT_KEYOPT_READONLY)) then
368 Exit;
369 try
370 if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_KEYSET,
371 keySetObj)) then
372 Exit;
373 finally
374 cryptKeysetClose(keySetObj);
375 end;
376 end;
377 Result := true;
378end;
379
380function TSSLCryptLib.DeInit: Boolean;
381begin
382 Result := True;
383 if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then
384 CryptDestroySession(FcryptSession);
385 FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
386 FSSLEnabled := False;
387 if FDelCert then
388 Deletefile(FPrivatekeyFile);
389end;
390
391function TSSLCryptLib.Prepare(server:Boolean): Boolean;
392begin
393 Result := false;
394 DeInit;
395 if Init(server) then
396 Result := true
397 else
398 DeInit;
399end;
400
401function TSSLCryptLib.Connect: boolean;
402begin
403 Result := False;
404 if FSocket.Socket = INVALID_SOCKET then
405 Exit;
406 if Prepare(false) then
407 begin
408 if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then
409 Exit;
410 if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then
411 Exit;
412 FSSLEnabled := True;
413 Result := True;
414 FReadBuffer := '';
415 end;
416end;
417
418function TSSLCryptLib.Accept: boolean;
419begin
420 Result := False;
421 if FSocket.Socket = INVALID_SOCKET then
422 Exit;
423 if Prepare(true) then
424 begin
425 if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then
426 Exit;
427 if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then
428 Exit;
429 FSSLEnabled := True;
430 Result := True;
431 FReadBuffer := '';
432 end;
433end;
434
435function TSSLCryptLib.Shutdown: boolean;
436begin
437 Result := BiShutdown;
438end;
439
440function TSSLCryptLib.BiShutdown: boolean;
441begin
442 if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then
443 cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 0);
444 DeInit;
445 FReadBuffer := '';
446 Result := True;
447end;
448
449function TSSLCryptLib.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
450var
451 l: integer;
452begin
453 FLastError := 0;
454 FLastErrorDesc := '';
455 SSLCheck(cryptPushData(FCryptSession, Buffer, Len, L));
456 cryptFlushData(FcryptSession);
457 Result := l;
458end;
459
460function TSSLCryptLib.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
461var
462 l: integer;
463begin
464 FLastError := 0;
465 FLastErrorDesc := '';
466 if Length(FReadBuffer) = 0 then
467 FReadBuffer := PopAll;
468 if Len > Length(FReadBuffer) then
469 Len := Length(FReadBuffer);
470 Move(Pointer(FReadBuffer)^, buffer^, Len);
471 Delete(FReadBuffer, 1, Len);
472 Result := Len;
473end;
474
475function TSSLCryptLib.WaitingData: Integer;
476begin
477 Result := Length(FReadBuffer);
478end;
479
480function TSSLCryptLib.GetSSLVersion: string;
481var
482 x: integer;
483begin
484 Result := '';
485 if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
486 Exit;
487 cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x);
488 if FSSLType in [LT_SSLv3, LT_TLSv1, LT_TLSv1_1, LT_all] then
489 case x of
490 0:
491 Result := 'SSLv3';
492 1:
493 Result := 'TLSv1';
494 2:
495 Result := 'TLSv1.1';
496 end;
497 if FSSLType in [LT_SSHv2] then
498 case x of
499 0:
500 Result := 'SSHv1';
501 1:
502 Result := 'SSHv2';
503 end;
504end;
505
506function TSSLCryptLib.GetPeerSubject: string;
507var
508 cert: CRYPT_CERTIFICATE;
509begin
510 Result := '';
511 if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
512 Exit;
513 cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
514 cryptSetAttribute(cert, CRYPT_CERTINFO_SUBJECTNAME, CRYPT_UNUSED);
515 Result := GetString(cert, CRYPT_CERTINFO_DN);
516 cryptDestroyCert(cert);
517end;
518
519function TSSLCryptLib.GetPeerName: string;
520var
521 cert: CRYPT_CERTIFICATE;
522begin
523 Result := '';
524 if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
525 Exit;
526 cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
527 cryptSetAttribute(cert, CRYPT_CERTINFO_ISSUERNAME, CRYPT_UNUSED);
528 Result := GetString(cert, CRYPT_CERTINFO_COMMONNAME);
529 cryptDestroyCert(cert);
530end;
531
532function TSSLCryptLib.GetPeerIssuer: string;
533var
534 cert: CRYPT_CERTIFICATE;
535begin
536 Result := '';
537 if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
538 Exit;
539 cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
540 cryptSetAttribute(cert, CRYPT_CERTINFO_ISSUERNAME, CRYPT_UNUSED);
541 Result := GetString(cert, CRYPT_CERTINFO_DN);
542 cryptDestroyCert(cert);
543end;
544
545function TSSLCryptLib.GetPeerFingerprint: string;
546var
547 cert: CRYPT_CERTIFICATE;
548begin
549 Result := '';
550 if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
551 Exit;
552 cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
553 Result := GetString(cert, CRYPT_CERTINFO_FINGERPRINT);
554 Result := MD5(Result);
555 cryptDestroyCert(cert);
556end;
557
558{==============================================================================}
559
560initialization
561 if cryptInit = CRYPT_OK then
562 SSLImplementation := TSSLCryptLib;
563 cryptAddRandom(nil, CRYPT_RANDOM_SLOWPOLL);
564
565finalization
566 cryptEnd;
567
568end.
569
Note: See TracBrowser for help on using the repository browser.