source: trunk/Packages/synapse/source/lib/ssl_cryptlib.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: 22.6 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-2012, 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-2012. |
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
82{$DEFINE CRYPTLIB_VERSION 3400}
83
84unit ssl_cryptlib;
85
86interface
87
88uses
89 Windows,
90 SysUtils,
91 blcksock, synsock, synautil, synacode,
92 cryptlib;
93
94type
95 {:@abstract(class implementing CryptLib SSL/SSH plugin.)
96 Instance of this class will be created for each @link(TTCPBlockSocket).
97 You not need to create instance of this class, all is done by Synapse itself!}
98 TSSLCryptLib = class(TCustomSSL)
99 protected
100 FCryptSession: CRYPT_SESSION;
101 FPrivateKeyLabel: string;
102 FDelCert: Boolean;
103 FReadBuffer: string;
104 FTrustedCAs: array of integer;
105 function SSLCheck(Value: integer): Boolean;
106 function Init(server:Boolean): Boolean;
107 function DeInit: Boolean;
108 function Prepare(server:Boolean): Boolean;
109 function GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string;
110 function CreateSelfSignedCert(Host: string): Boolean; override;
111 function PopAll: string;
112 public
113 {:See @inherited}
114 constructor Create(const Value: TTCPBlockSocket); override;
115 destructor Destroy; override;
116 {:Load trusted CA's in PEM format}
117 procedure SetCertCAFile(const Value: string); override;
118 {:See @inherited}
119 function LibVersion: String; override;
120 {:See @inherited}
121 function LibName: String; override;
122 {:See @inherited}
123 procedure Assign(const Value: TCustomSSL); override;
124 {:See @inherited and @link(ssl_cryptlib) for more details.}
125 function Connect: boolean; override;
126 {:See @inherited and @link(ssl_cryptlib) for more details.}
127 function Accept: boolean; override;
128 {:See @inherited}
129 function Shutdown: boolean; override;
130 {:See @inherited}
131 function BiShutdown: boolean; override;
132 {:See @inherited}
133 function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
134 {:See @inherited}
135 function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
136 {:See @inherited}
137 function WaitingData: Integer; override;
138 {:See @inherited}
139 function GetSSLVersion: string; override;
140 {:See @inherited}
141 function GetPeerSubject: string; override;
142 {:See @inherited}
143 function GetPeerIssuer: string; override;
144 {:See @inherited}
145 function GetPeerName: string; override;
146 {:See @inherited}
147 function GetPeerFingerprint: string; override;
148 {:See @inherited}
149 function GetVerifyCert: integer; override;
150 published
151 {:name of certificate/key within PKCS#15 file. It can hold more then one
152 certificate/key and each certificate/key must have unique label within one file.}
153 property PrivateKeyLabel: string read FPrivateKeyLabel Write FPrivateKeyLabel;
154 end;
155
156implementation
157
158{==============================================================================}
159
160constructor TSSLCryptLib.Create(const Value: TTCPBlockSocket);
161begin
162 inherited Create(Value);
163 FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
164 FPrivateKeyLabel := 'synapse';
165 FDelCert := false;
166 FTrustedCAs := nil;
167end;
168
169destructor TSSLCryptLib.Destroy;
170begin
171 SetCertCAFile(''); // destroy certificates
172 DeInit;
173 inherited Destroy;
174end;
175
176procedure TSSLCryptLib.Assign(const Value: TCustomSSL);
177begin
178 inherited Assign(Value);
179 if Value is TSSLCryptLib then
180 begin
181 FPrivateKeyLabel := TSSLCryptLib(Value).privatekeyLabel;
182 end;
183end;
184
185function TSSLCryptLib.GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string;
186var
187 l: integer;
188begin
189 l := 0;
190 cryptGetAttributeString(cryptHandle, attributeType, nil, l);
191 setlength(Result, l);
192 cryptGetAttributeString(cryptHandle, attributeType, pointer(Result), l);
193 setlength(Result, l);
194end;
195
196function TSSLCryptLib.LibVersion: String;
197var
198 x: integer;
199begin
200 Result := GetString(CRYPT_UNUSED, CRYPT_OPTION_INFO_DESCRIPTION);
201 cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MAJORVERSION, x);
202 Result := Result + ' v' + IntToStr(x);
203 cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MINORVERSION, x);
204 Result := Result + '.' + IntToStr(x);
205 cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_STEPPING, x);
206 Result := Result + '.' + IntToStr(x);
207end;
208
209function TSSLCryptLib.LibName: String;
210begin
211 Result := 'ssl_cryptlib';
212end;
213
214function TSSLCryptLib.SSLCheck(Value: integer): Boolean;
215begin
216 Result := true;
217 FLastErrorDesc := '';
218 if Value = CRYPT_ERROR_COMPLETE then
219 Value := 0;
220 FLastError := Value;
221 if FLastError <> 0 then
222 begin
223 Result := False;
224//{$IF CRYPTLIB_VERSION >= 3400}
225 FLastErrorDesc := GetString(FCryptSession, CRYPT_ATTRIBUTE_ERRORMESSAGE);
226//{$ELSE}
227// FLastErrorDesc := GetString(FCryptSession, CRYPT_ATTRIBUTE_INT_ERRORMESSAGE);
228//{$IFEND}
229 end;
230end;
231
232function TSSLCryptLib.CreateSelfSignedCert(Host: string): Boolean;
233var
234 privateKey: CRYPT_CONTEXT;
235 keyset: CRYPT_KEYSET;
236 cert: CRYPT_CERTIFICATE;
237 publicKey: CRYPT_CONTEXT;
238begin
239 if FPrivatekeyFile = '' then
240 FPrivatekeyFile := GetTempFile('', 'key');
241 cryptCreateContext(privateKey, CRYPT_UNUSED, CRYPT_ALGO_RSA);
242 cryptSetAttributeString(privateKey, CRYPT_CTXINFO_LABEL, Pointer(FPrivatekeyLabel),
243 Length(FPrivatekeyLabel));
244 cryptSetAttribute(privateKey, CRYPT_CTXINFO_KEYSIZE, 1024);
245 cryptGenerateKey(privateKey);
246 cryptKeysetOpen(keyset, CRYPT_UNUSED, CRYPT_KEYSET_FILE, PChar(FPrivatekeyFile), CRYPT_KEYOPT_CREATE);
247 FDelCert := True;
248 cryptAddPrivateKey(keyset, privateKey, PChar(FKeyPassword));
249 cryptCreateCert(cert, CRYPT_UNUSED, CRYPT_CERTTYPE_CERTIFICATE);
250 cryptSetAttribute(cert, CRYPT_CERTINFO_XYZZY, 1);
251 cryptGetPublicKey(keyset, publicKey, CRYPT_KEYID_NAME, PChar(FPrivatekeyLabel));
252 cryptSetAttribute(cert, CRYPT_CERTINFO_SUBJECTPUBLICKEYINFO, publicKey);
253 cryptSetAttributeString(cert, CRYPT_CERTINFO_COMMONNAME, Pointer(host), Length(host));
254 cryptSignCert(cert, privateKey);
255 cryptAddPublicKey(keyset, cert);
256 cryptKeysetClose(keyset);
257 cryptDestroyCert(cert);
258 cryptDestroyContext(privateKey);
259 cryptDestroyContext(publicKey);
260 Result := True;
261end;
262
263function TSSLCryptLib.PopAll: string;
264const
265 BufferMaxSize = 32768;
266var
267 Outbuffer: string;
268 WriteLen: integer;
269begin
270 Result := '';
271 repeat
272 setlength(outbuffer, BufferMaxSize);
273 Writelen := 0;
274 SSLCheck(CryptPopData(FCryptSession, @OutBuffer[1], BufferMaxSize, Writelen));
275 if FLastError <> 0 then
276 Break;
277 if WriteLen > 0 then
278 begin
279 setlength(outbuffer, WriteLen);
280 Result := Result + outbuffer;
281 end;
282 until WriteLen = 0;
283end;
284
285function TSSLCryptLib.Init(server:Boolean): Boolean;
286var
287 st: CRYPT_SESSION_TYPE;
288 keysetobj: CRYPT_KEYSET;
289 cryptContext: CRYPT_CONTEXT;
290 x: integer;
291begin
292 Result := False;
293 FLastErrorDesc := '';
294 FLastError := 0;
295 FDelCert := false;
296 FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
297 if server then
298 case FSSLType of
299 LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1:
300 st := CRYPT_SESSION_SSL_SERVER;
301 LT_SSHv2:
302 st := CRYPT_SESSION_SSH_SERVER;
303 else
304 Exit;
305 end
306 else
307 case FSSLType of
308 LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1:
309 st := CRYPT_SESSION_SSL;
310 LT_SSHv2:
311 st := CRYPT_SESSION_SSH;
312 else
313 Exit;
314 end;
315 if not SSLCheck(cryptCreateSession(FcryptSession, CRYPT_UNUSED, st)) then
316 Exit;
317 x := -1;
318 case FSSLType of
319 LT_SSLv3:
320 x := 0;
321 LT_TLSv1:
322 x := 1;
323 LT_TLSv1_1:
324 x := 2;
325 end;
326 if x >= 0 then
327 if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x)) then
328 Exit;
329
330 if (FCertComplianceLevel <> -1) then
331 if not SSLCheck(cryptSetAttribute (CRYPT_UNUSED, CRYPT_OPTION_CERT_COMPLIANCELEVEL,
332 FCertComplianceLevel)) then
333 Exit;
334
335 if FUsername <> '' then
336 begin
337 cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_USERNAME,
338 Pointer(FUsername), Length(FUsername));
339 cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_PASSWORD,
340 Pointer(FPassword), Length(FPassword));
341 end;
342 if FSSLType = LT_SSHv2 then
343 if FSSHChannelType <> '' then
344 begin
345 cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL, CRYPT_UNUSED);
346 cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_TYPE,
347 Pointer(FSSHChannelType), Length(FSSHChannelType));
348 if FSSHChannelArg1 <> '' then
349 cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG1,
350 Pointer(FSSHChannelArg1), Length(FSSHChannelArg1));
351 if FSSHChannelArg2 <> '' then
352 cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG2,
353 Pointer(FSSHChannelArg2), Length(FSSHChannelArg2));
354 end;
355
356
357 if server and (FPrivatekeyFile = '') then
358 begin
359 if FPrivatekeyLabel = '' then
360 FPrivatekeyLabel := 'synapse';
361 if FkeyPassword = '' then
362 FkeyPassword := 'synapse';
363 CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP));
364 end;
365
366 if (FPrivatekeyLabel <> '') and (FPrivatekeyFile <> '') then
367 begin
368 if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE,
369 PChar(FPrivatekeyFile), CRYPT_KEYOPT_READONLY)) then
370 Exit;
371 try
372 if not SSLCheck(cryptGetPrivateKey(KeySetObj, cryptcontext, CRYPT_KEYID_NAME,
373 PChar(FPrivatekeyLabel), PChar(FKeyPassword))) then
374 Exit;
375 if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_PRIVATEKEY,
376 cryptcontext)) then
377 Exit;
378 finally
379 cryptKeysetClose(keySetObj);
380 cryptDestroyContext(cryptcontext);
381 end;
382 end;
383 if server and FVerifyCert then
384 begin
385 if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE,
386 PChar(FCertCAFile), CRYPT_KEYOPT_READONLY)) then
387 Exit;
388 try
389 if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_KEYSET,
390 keySetObj)) then
391 Exit;
392 finally
393 cryptKeysetClose(keySetObj);
394 end;
395 end;
396 Result := true;
397end;
398
399function TSSLCryptLib.DeInit: Boolean;
400begin
401 Result := True;
402 if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then
403 CryptDestroySession(FcryptSession);
404 FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
405 FSSLEnabled := False;
406 if FDelCert then
407 SysUtils.DeleteFile(FPrivatekeyFile);
408end;
409
410function TSSLCryptLib.Prepare(server:Boolean): Boolean;
411begin
412 Result := false;
413 DeInit;
414 if Init(server) then
415 Result := true
416 else
417 DeInit;
418end;
419
420function TSSLCryptLib.Connect: boolean;
421begin
422 Result := False;
423 if FSocket.Socket = INVALID_SOCKET then
424 Exit;
425 if Prepare(false) then
426 begin
427 if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then
428 Exit;
429 if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then
430 Exit;
431 if FverifyCert then
432 if (GetVerifyCert <> 0) or (not DoVerifyCert) then
433 Exit;
434 FSSLEnabled := True;
435 Result := True;
436 FReadBuffer := '';
437 end;
438end;
439
440function TSSLCryptLib.Accept: boolean;
441begin
442 Result := False;
443 if FSocket.Socket = INVALID_SOCKET then
444 Exit;
445 if Prepare(true) then
446 begin
447 if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then
448 Exit;
449 if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then
450 Exit;
451 FSSLEnabled := True;
452 Result := True;
453 FReadBuffer := '';
454 end;
455end;
456
457function TSSLCryptLib.Shutdown: boolean;
458begin
459 Result := BiShutdown;
460end;
461
462function TSSLCryptLib.BiShutdown: boolean;
463begin
464 if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then
465 cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 0);
466 DeInit;
467 FReadBuffer := '';
468 Result := True;
469end;
470
471function TSSLCryptLib.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
472var
473 l: integer;
474begin
475 FLastError := 0;
476 FLastErrorDesc := '';
477 SSLCheck(cryptPushData(FCryptSession, Buffer, Len, L));
478 cryptFlushData(FcryptSession);
479 Result := l;
480end;
481
482function TSSLCryptLib.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
483begin
484 FLastError := 0;
485 FLastErrorDesc := '';
486 if Length(FReadBuffer) = 0 then
487 FReadBuffer := PopAll;
488 if Len > Length(FReadBuffer) then
489 Len := Length(FReadBuffer);
490 Move(Pointer(FReadBuffer)^, buffer^, Len);
491 Delete(FReadBuffer, 1, Len);
492 Result := Len;
493end;
494
495function TSSLCryptLib.WaitingData: Integer;
496begin
497 Result := Length(FReadBuffer);
498end;
499
500function TSSLCryptLib.GetSSLVersion: string;
501var
502 x: integer;
503begin
504 Result := '';
505 if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
506 Exit;
507 cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x);
508 if FSSLType in [LT_SSLv3, LT_TLSv1, LT_TLSv1_1, LT_all] then
509 case x of
510 0:
511 Result := 'SSLv3';
512 1:
513 Result := 'TLSv1';
514 2:
515 Result := 'TLSv1.1';
516 end;
517 if FSSLType in [LT_SSHv2] then
518 case x of
519 0:
520 Result := 'SSHv1';
521 1:
522 Result := 'SSHv2';
523 end;
524end;
525
526function TSSLCryptLib.GetPeerSubject: string;
527var
528 cert: CRYPT_CERTIFICATE;
529begin
530 Result := '';
531 if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
532 Exit;
533 cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
534 cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_SUBJECTNAME);
535 Result := GetString(cert, CRYPT_CERTINFO_DN);
536 cryptDestroyCert(cert);
537end;
538
539function TSSLCryptLib.GetPeerName: string;
540var
541 cert: CRYPT_CERTIFICATE;
542begin
543 Result := '';
544 if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
545 Exit;
546 cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
547 cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_SUBJECTNAME);
548 Result := GetString(cert, CRYPT_CERTINFO_COMMONNAME);
549 cryptDestroyCert(cert);
550end;
551
552function TSSLCryptLib.GetPeerIssuer: string;
553var
554 cert: CRYPT_CERTIFICATE;
555begin
556 Result := '';
557 if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
558 Exit;
559 cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
560 cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_ISSUERNAME);
561 Result := GetString(cert, CRYPT_CERTINFO_COMMONNAME);
562 cryptDestroyCert(cert);
563end;
564
565function TSSLCryptLib.GetPeerFingerprint: string;
566var
567 cert: CRYPT_CERTIFICATE;
568begin
569 Result := '';
570 if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
571 Exit;
572 cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
573 Result := GetString(cert, CRYPT_CERTINFO_FINGERPRINT);
574 cryptDestroyCert(cert);
575end;
576
577
578procedure TSSLCryptLib.SetCertCAFile(const Value: string);
579
580var F:textfile;
581 bInCert:boolean;
582 s,sCert:string;
583 cert: CRYPT_CERTIFICATE;
584 idx:integer;
585
586begin
587if assigned(FTrustedCAs) then
588 begin
589 for idx := 0 to High(FTrustedCAs) do
590 cryptDestroyCert(FTrustedCAs[idx]);
591 FTrustedCAs:=nil;
592 end;
593if Value<>'' then
594 begin
595 AssignFile(F,Value);
596 reset(F);
597 bInCert:=false;
598 idx:=0;
599 while not eof(F) do
600 begin
601 readln(F,s);
602 if pos('-----END CERTIFICATE-----',s)>0 then
603 begin
604 bInCert:=false;
605 cert:=0;
606 if (cryptImportCert(PAnsiChar(sCert),length(sCert)-2,CRYPT_UNUSED,cert)=CRYPT_OK) then
607 begin
608 cryptSetAttribute( cert, CRYPT_CERTINFO_TRUSTED_IMPLICIT, 1 );
609 SetLength(FTrustedCAs,idx+1);
610 FTrustedCAs[idx]:=cert;
611 idx:=idx+1;
612 end;
613 end;
614 if bInCert then
615 sCert:=sCert+s+#13#10;
616 if pos('-----BEGIN CERTIFICATE-----',s)>0 then
617 begin
618 bInCert:=true;
619 sCert:='';
620 end;
621 end;
622 CloseFile(F);
623 end;
624end;
625
626function TSSLCryptLib.GetVerifyCert: integer;
627var
628 cert: CRYPT_CERTIFICATE;
629 itype,ilocus:integer;
630begin
631 Result := -1;
632 if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
633 Exit;
634 cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
635 result:=cryptCheckCert(cert,CRYPT_UNUSED);
636 if result<>CRYPT_OK then
637 begin
638 //get extended error info if available
639 cryptGetAttribute(cert,CRYPT_ATTRIBUTE_ERRORtype,itype);
640 cryptGetAttribute(cert,CRYPT_ATTRIBUTE_ERRORLOCUS,ilocus);
641 cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_SUBJECTNAME);
642 FLastError := Result;
643 FLastErrorDesc := format('SSL/TLS certificate verification failed for "%s"'#13#10'Status: %d. ERRORTYPE: %d. ERRORLOCUS: %d.',
644 [GetString(cert, CRYPT_CERTINFO_COMMONNAME),result,itype,ilocus]);
645 end;
646 cryptDestroyCert(cert);
647end;
648
649{==============================================================================}
650
651var imajor,iminor,iver:integer;
652// e: ESynapseError;
653
654initialization
655 if cryptInit = CRYPT_OK then
656 SSLImplementation := TSSLCryptLib;
657 cryptAddRandom(nil, CRYPT_RANDOM_SLOWPOLL);
658 cryptGetAttribute (CRYPT_UNUSED, CRYPT_OPTION_INFO_MAJORVERSION,imajor);
659 cryptGetAttribute (CRYPT_UNUSED, CRYPT_OPTION_INFO_MINORVERSION,iminor);
660// according to the documentation CRYPTLIB version has 3 digits. recent versions use 4 digits
661 if CRYPTLIB_VERSION >1000 then
662 iver:=CRYPTLIB_VERSION div 100
663 else
664 iver:=CRYPTLIB_VERSION div 10;
665 if (iver <> imajor*10+iminor) then
666 begin
667 SSLImplementation :=TSSLNone;
668// e := ESynapseError.Create(format('Error wrong cryptlib version (is %d.%d expected %d.%d). ',
669// [imajor,iminor,iver div 10, iver mod 10]));
670// e.ErrorCode := 0;
671// e.ErrorMessage := format('Error wrong cryptlib version (%d.%d expected %d.%d)',
672// [imajor,iminor,iver div 10, iver mod 10]);
673// raise e;
674 end;
675finalization
676 cryptEnd;
677end.
678
679
Note: See TracBrowser for help on using the repository browser.