Module

XuDsigS

Path

C:\CPRS\CPRS30\XuDigSig\XuDsigS.pas

Last Modified

7/15/2014 3:26:44 PM

Comments

This is the Unit that connects to the MicroSoft CryptoAPI
 that is used to create a digital Signature for a block of
 Data.  This version requires the use of a SmartCard reader.

Units Used in Interface

Name Comments
fPINPrompt -
wcrypt2 -
WinSCard -
XlfHex -
XlfMime -
XuDsigConst -
XuDsigU -

Classes

Name Comments
tCryptography -

Procedures

Name Owner Declaration Scope Comments
Certsigndata tCryptography procedure Certsigndata; Private -
HashBuf tCryptography procedure HashBuf(pB: pByte; cnt: integer); Public Called to hash a buffer of data
Hashbuffer tCryptography procedure Hashbuffer; Public Gets the SHA-2 hash of the fDataBuffer
HashEnd tCryptography procedure HashEnd; Public
This is called at the end of a long hash to destroy the hash object
If going to sign the hash it must be done before calling this.
HashStart tCryptography procedure HashStart; Public Called at start of a long hash to create the hash object.
Memo - procedure Memo(s: string); Local
-----------------------------------------------------
nested function
RaiseErr tCryptography procedure RaiseErr(msg: string); Private Raise an exception with a formatted message
Release tCryptography procedure Release; Public -
Reset tCryptography procedure Reset; Public Normal procedures and functions
sCardReattach tCryptography procedure sCardReattach; Public -
sCardReset tCryptography procedure sCardReset; Public
SCardReset and sCardReattach are not needed if CheckPINValue, below,
 is used.
SetStatus - procedure SetStatus(sta: boolean; s: string); Local -
Status - procedure Status(msg: string; st: boolean); Local Nested procedure

Functions

Name Owner Declaration Scope Comments
CertChainCheck tCryptography function CertChainCheck(pCertContext: PCCERT_CONTEXT): boolean; Private
Check the Cert Chain for the Cert just used.

 Private declarations 
-----------------------------------------------------
nested function
checkPINValue - function checkPINValue(InputForm: TComponent): TPINResult; Interfaced -
CheckSig tCryptography function CheckSig(pBlob: pointer; Blobsize: DWORD): boolean; Private -
CRLDistPoint tCryptography function CRLDistPoint(pbData: pointer; cbData: integer): string; Private -
DataReady tCryptography function DataReady: boolean; Private
This function is to check that all the input data is ready.
DEA final rule does not have DEA number or DEA schedule in the Cert.
rwf This will need changes.

nested procedure
FindCert tCryptography function FindCert: boolean; Private
Open a system certificate store and
check each certificates looking for a Certificate
that is Valid and has a given ObjID.
Leaves HCertStore and pCertContext open.


Used to tell if we found the right parts
a pointer the the rgExtension blob
GetHashValue tCryptography function GetHashValue: String; Public
This call gets the current Hash value and puts the B64
value in the public variable hashstr
procedure tCryptography.GetHashValue;
getSANFromCard - function getSANFromCard(InputForm: TComponent; crypto: tCryptography): String; Interfaced -
ptochars - function ptochars(pbdata: pbytearray; len: DWORD): string; Interfaced -
Revco - function Revco(): boolean; Local -
sCardReady - function sCardReady: boolean; Interfaced -
setPINValue - function setPINValue(PinValue: String; handle: Dword): Boolean; Interfaced -
SignData tCryptography function SignData: boolean; Public
All the data that we need will be placed thru object calls
This part will manage the other parts to get the work done.
With luck we don't have to have all the code inline.
SigningCert tCryptography function SigningCert(pCertCtx: PCCERT_CONTEXT): Integer; Private See if the Cert is valid for Signing.

Global Variables

Name Type Declaration Comments
isXuDSigSLogging Boolean isXuDSigSLogging: Boolean; 120912 - needs to be set, if it is going to record problems in Create, before the Crypto object is created.
LastPINValue UnicodeString LastPINValue: String; -
SANfromCard UnicodeString SANfromCard: String; -

Constants

Name Declaration Scope Comments
prCancel TPINResult Interfaced -
prError TPINResult Interfaced -
prLocked TPINResult Interfaced -
prOK TPINResult Interfaced -


Module Source

1     unit XuDsigS;
2     {
3      This is the Unit that connects to the MicroSoft CryptoAPI
4      that is used to create a digital Signature for a block of
5      Data.  This version requires the use of a SmartCard reader.
6     }
7     interface
8     uses SysUtils, Windows, Registry, Dialogs, Classes, Forms, Controls,
9       StdCtrls,
10      wcrypt2, XuDsigU, XlfMime,
11      XlfHex, XuDsigConst, WinSCard, fPINPrompt,
12      MFunStr;
13    
14    type
15      ECryptErr = Exception;
16    
17    type
18      TPINResult = (prOK, prCancel, prLocked, prError);
19    
20    type
21      tCryptography = class(TObject)
22      private
23        //Basic Crypto data
24        hProv: HCRYPTPROV; // provider handle
25        hPassKey: HCRYPTKEY; // Handle to password (key)
26        hHash: HCRYPTHASH; //Hash handle
27        HCERTSTORE{, hCRLStore}: HCERTSTORE;  //Certificate store handle
28        hUserKey: HCRYPTKEY;  //Handle to the users Sig key
29        //Cert. Store Data
30        hMsg: HCRYPTMSG;
31        pCertContext: PCCERT_CONTEXT;  //Cert Context
32        //Flag to mark if valid date
33        MasterDateValid: boolean;
34        //Flag to mark if Cert has valid Chain
35        MasterCertChain: boolean;
36        fCSProviderName, fContainerName, fCryptVer: string; // Misc. info
37        fHashStr: string;  //hash value in Hex
38        fHexHash: string;  //hash value in Hex
39        fHashAlogrithm: string;  //Alogrithm used
40        fSignatureStr: string;  //This is returned signature
41        fDataBuffer: string;  //This is the data to sign as one big string
42        fDeaNumber: string;  //This is the users DEA number of file with VA.
43        fUsrName: string;    //The User Name on the Cert.
44        fUsrAltName: string; // The User's Alt Name (i.e., e-mail address)
45        fDateSigned:  string;  //FM datetime
46        SignMsgParam: CRYPT_SIGN_MESSAGE_PARA;
47        fHashValue: Array of byte;
48        fIssuanceDate: String;
49        fPatientName: String;
50        fPatientAddress: String;
51        fDrugName: String;
52        fQuantity: String;
53        fDirections: String;
54        fDetoxNumber: String;
55        fProviderName: String;
56        fProviderAddress: String;
57        fhSC: SCARDCONTEXT;
58        fhCard: LongInt;
59        fisCardReset: Boolean;
60        fOrderNumber: String;
61        fVistaUserName: String;
62    
63        fIgnoreDates: Boolean;  // DEBUG ONLY
64        fIgnoreRevoked: Boolean;  // DEBUG ONLY
65        fIgnoreMasterChain: Boolean;  // DEBUG ONLY
66    
67        procedure RaiseErr(msg: string);
68        function FindCert: boolean;
69        function DataReady: boolean;
70        procedure Certsigndata;
71        function CertChainCheck(pCertContext: PCCERT_CONTEXT): boolean;
72        function CRLDistPoint(pbData: pointer; cbData: integer): string;
73        function CheckSig(pBlob: pointer; Blobsize: DWORD): boolean;
74        function SigningCert(pCertCtx: PCCERT_CONTEXT): Integer;
75    //    procedure SaveLog; hint fix
76      public
77        //These fields hold the data from the Crypto functions
78        //that we want to pass back to the caller
79        isDEAsig: boolean;  //Are we doing a DEA signature
80        //These fields hold the raw data from the Crypto functions
81        CHashValue: Array of byte;
82        CKeyBlob, CSignature: Array[0..2024] of byte;
83        CHashLen, CBlobLen, CSigLen: integer;  //The length
84        KeyBloB64, SignatureB64: string;
85        CertName, CertSerialNum: string; //pass back data
86        SigningStatus: boolean;  //This will hold the overall status.
87        Reason, SubReason: string;  //This will hold text for the caller about status.
88        //The drug's schedule
89        DrugSch: string;
90        //A URL for the CRL from the cert.
91        CrlUrl: string;
92        HashB64: string;
93        Certstr: string; //pass back data
94        ErrCode, ReturnStr: string;  //
95        Comment: String;
96        LastErr: LongInt;
97        TrackingMsg: Tstringlist;
98        constructor Create;
99        destructor Destroy; override;
100       //Info about the Crypto provider
101       property ContainerName: string read fContainerName write fContainerName;
102       property CSProviderName: string read fCSProviderName write fCSProviderName;
103       property CryptVer: string read fCryptVer;
104       //Return Data
105       property SignatureStr: string read fSignatureStr write fSignatureStr;
106       property HashAlgorithm: string read fHashAlogrithm;
107       property DTSigned: string read fDateSigned write fDateSigned;
108       property HexHash: string read fHexHash;
109       property HashStr: string read fHashStr;
110       //Normal procedures and functions
111       procedure Reset;
112       //This is where the data to sign is loaded.
113       property DataBuffer: string read fDataBuffer write fDataBuffer;
114       property DeaNumber: string read fDeaNumber write fDeaNumber;
115       property UsrName: string read fUsrName write fUsrName;
116       property UsrAltName: string read fUsrAltName write fUsrAltName;
117       property IssuanceDate: string read fIssuanceDate write fIssuanceDate;
118       property PatientName: string read fPatientName write fPatientName;
119       property PatientAddress: string read fPatientAddress write fPatientAddress;
120       property DrugName: string read fDrugName write fDrugName;
121       property Quantity: string read fQuantity write fQuantity;
122       property Directions: string read fDirections write fDirections;
123       property DetoxNumber: string read fDetoxNumber write fDetoxNumber;
124       property OrderNumber: string read fOrderNumber write fOrderNumber;
125       property ProviderName: string read fProviderName write fProviderName;
126       property ProviderAddress: string read fProviderAddress write fProviderAddress;
127       property isCardReset: Boolean read fisCardReset;
128       property ignoreDates: Boolean read fIgnoreDates write fIgnoredates;  // DEBUG ONLY
129       property ignoreRevoked: Boolean read fIgnoreRevoked write fIgnoreRevoked; // DEBUG ONLY
130       property ignoreMasterChain: Boolean read fIgnoreMasterChain write fIgnoreMasterChain; // DEBUG ONLY
131       property VistaUserName: String read fVistaUserName write fVistaUserName; // 121213 user's name from VistA
132       procedure Hashbuffer;
133       procedure HashStart;
134       procedure HashBuf(pB: pByte; cnt: integer);
135       function GetHashValue: String;
136       procedure HashEnd;
137       function  SignData: boolean;
138       procedure sCardReset;
139       procedure sCardReattach;
140       procedure Release;
141   end;
142   
143   function sCardReady: boolean;
144   function checkPINValue(InputForm: TComponent): TPINResult;
145   function ptochars(pbdata: pbytearray; len: DWORD): string;
146   function getSANFromCard(InputForm: TComponent; crypto: tCryptography): String;
147   function setPINValue(PinValue: String; handle: Dword): Boolean;
148   
149   var
150     SANfromCard: String;
151     isXuDSigSLogging: Boolean; // 120912 - needs to be set, if it is going to record problems in Create, before the Crypto object is created.
152     LastPINValue: String;
153   
154   implementation
155   
156   // Raise an exception with a formatted message
157   procedure tCryptography.RaiseErr(msg: string);
158   var
159     err: dword;
160     s: string;
161   begin
162     s := '';
163   //  SaveLog(); // 121214 remove saving of log to PKISignError
164     err := getLastError; // Check last system error
165     if SUCCEEDED(err) then
166     begin
167       raise ECryptErr.createFmt('Cryptography error: %s.', [msg]);
168     end;
169     s := SysErrorMessage(err);
170     if s = '' then
171       s := format('System Error %0X', [err]);
172     raise ECryptErr.createFmt('Cryptography error: %s (%s).', [msg, s]);
173   end;
174   
175   //This function is to check that all the input data is ready.
176   //DEA final rule does not have DEA number or DEA schedule in the Cert.
177   //rwf This will need changes.
178   function tCryptography.DataReady: boolean;
179   var
180    DataRdy: boolean;
181   
182    //nested procedure
183    procedure Status(msg: string; st: boolean);
184    begin
185      Reason := msg;
186      DataRdy := st;
187    end; //Nested
188   
189   begin
190     Status('Data Check OK', True); //Sets DataReady
191     fSignatureStr := '';
192     SubReason := '';
193     if DataBuffer = '' then
194         Status('89802000^Order Text is blank.', False);
195     if (isDEAsig = True) and (DeaNumber = '') then
196         Status('89802001^DEA # missing.', False);
197     Result := DataRdy;
198   end;
199   
200   //This will create and init the cryptography object
201   constructor tCryptography.Create;
202   var
203     buff: array [0..1023] of char;
204     provider, Container: string;
205     size: dWord;
206     LastErr: DWORD;
207     value: Boolean;
208     Str: String;
209   begin
210     inherited Create;
211     Comment := '';
212     hProv := 0;      //See that global variables are inited
213     hHash := 0;
214     hPassKey := 0;
215     hUserKey := 0;
216     hCertStore := 0;
217     CSProviderName := c_SignPROV_NAME; //The Signing Provider  // 120206
218     ContainerName := '';         //Will use the default        // 120206
219     Reason := '';
220     subReason := '';
221     fCryptVer := '0.0';
222     CHashLen := 0;
223     CSigLen := 0;
224     Reset;
225     CBlobLen := 0;
226     fDataBuffer := '';
227     fSignatureStr := '';
228     fDatesigned := '';
229     //
230     Trackingmsg := TstringList.Create;
231     if not sCardReady then
232     begin
233       ShowMessage('Put a smart card in the Reader, then Press OK');
234       sleep(5000);
235       if not sCardReady then
236       begin
237         lastErr := GetLastError;
238         Str := IntToStr(lastErr)+' - '+SysErrorMessage(lastErr);
239         TrackingMsg.Add('89802006^Smart Card Reader not found - '+Str);
240         RaiseErr('89802006^Smart Card Reader not found');
241         exit;
242       end;
243     end;
244     //Find out what CSP to use.
245     //For Verification use the MS enhanced AES version.
246      provider := CSProviderName;
247      Container := '';  //Use the default container 'MY'
248   
249      //We only want to create a default container if
250      //we are NOT using a SmartCard
251      // Create a cryptography object with default
252      // container and slected provider.
253      Comment := Comment + 'Going to CryptAcquireContext'+#10#13;
254      value := CryptAcquireContext( @hProv,
255                              pchar(Container),
256                              pchar(''),
257                              PROV_RSA_AES,  // was PROV_RSA_FULL,   //rwf
258                              0);
259      if value then
260      begin
261        Comment := '01 CryptAcquireContext true hProv = '+IntToStr(hProv);
262        TrackingMsg.Add(Comment);
263        Comment := Comment + 'Back from CryptAcquireContext value true'+#10#13
264      end
265      else
266      begin
267        lastErr := GetLastError;
268        Str := IntToStr(lastErr)+' - '+SysErrorMessage(lastErr);
269        Comment := '01 CryptAcquireContext false lastErr: '+Str;
270        TrackingMsg.Add(Comment);
271        Comment := Comment + 'Back from CryptAcquireContext value false Error: '+Str+#10#13;
272      end;
273   
274      if value = false then
275      begin
276        lastErr := GetLastError;
277        Str := IntToStr(lastErr)+' - '+SysErrorMessage(lastErr);
278        TrackingMsg.Add('CryptAcquireContext failed - '+Str);
279        // Unable to aquire context, check if failure was due to
280        // absence of key container.
281        value := CryptAcquireContext( @hProv,
282                     pchar(Container),
283                     pchar(''),
284                     PROV_RSA_AES,  // was PROV_RSA_FULL,  rwf
285                     CRYPT_NEWKEYSET);
286        if value = false then
287        begin
288          lastErr := GetLastError;
289          Str := IntToStr(lastErr)+' - '+SysErrorMessage(lastErr);
290          TrackingMsg.Add('CryptAcquireContext with new keyset false - '+Str);
291          RaiseErr( 'Unable to aquire context');
292          exit;
293        end
294        else
295        begin
296          TrackingMsg.Add('CryptAcquireContext with new keyset');
297        end;
298     end;
299     if value then
300     begin
301       Comment := '01 CryptAcquireContext true'+#10#13;
302     end;
303     if value = false then
304     begin
305       lastErr := GetLastError;
306       Str := IntToStr(lastErr)+' - '+SysErrorMessage(lastErr);
307       TrackingMsg.Add('01 CryptAcquireContext false - '+Str);
308       RaiseErr(Str);
309       exit;
310     end;
311     // Get some info about the cryptography module.
312     // Name of the CSP.
313     Comment := Comment + '02 hProv = '+IntToStr(hProv)+#10#13;
314     size := sizeof(buff);
315     if CryptGetProvParam(hProv, PP_NAME, @Buff, @size, 0) = false then
316       fCSProviderName := 'Unknown'
317     else
318       fCSProviderName := StrPas(Buff);
319     Comment := Comment + '03 fCSProviderName = '+fCSProviderName+#10#13;
320   
321     // Name of the key container.
322     size := sizeof(buff);
323     if CryptGetProvParam(hProv, PP_CONTAINER, @Buff, @size, 0) = false then
324       fContainerName := 'Unknown'
325     else
326       fContainerName := StrPas(Buff);
327     Comment := Comment + '04 ContainerName = '+fContainerName+#10#13;
328   
329     // Version number
330     size := sizeof(buff);
331     if CryptGetProvParam(hProv, PP_VERSION, @Buff, @size, 0) = false then
332       fCryptVer := '*.00'
333     else
334       fCryptVer := format('%d.%d', [integer(buff[1]), integer(buff[0])]);
335     Comment := Comment + '05 fCryptVer = '+fCryptVer+#10#13;
336   end;
337   
338   destructor tCryptography.Destroy;
339   begin
340     try
341       // Release the key handle
342       if hPassKey <> 0 then
343        if CryptDestroyKey(hPassKey) = false then
344           RaiseErr('Unable to destroy password key');
345       // Release the Hash handle
346       if hHash <> 0 then
347           CryptDestroyHash(hHash);
348       //Release a certificate Context
349       if pCertContext <> nil then
350           CertFreeCertificateContext(pCertContext);
351       //Release the Cert Store.
352       if hCertStore <> 0 then
353           CertCloseStore(hCertStore, CERT_CLOSE_STORE_FORCE_FLAG);
354       // Clean up.
355       // Release the CSP handle
356       if hProv <> 0 then
357         if CryptReleaseContext(hProv, 0) = false then
358           RaiseErr('Unable to release context');
359     finally
360         //Must remember to do this
361         inherited;
362     end;
363   end;
364   
365   //Gets the SHA-2 hash of the fDataBuffer
366   procedure tCryptography.Hashbuffer;
367   begin
368     Comment := 'Going to HashStart';
369     TrackingMsg.Add(Comment);
370     HashStart;
371     HashBuf(@DataBuffer[1], length(DataBuffer));
372     TrackingMsg.Add('Going to GetHashValue');
373     GetHashValue;
374     TrackingMsg.Add('Going to HashEnd');
375     HashEnd;
376   end;
377   
378   //Called at start of a long hash to create the hash object.
379   procedure tCryptography.HashStart;
380   var
381     Str: String;
382   begin
383     CHashLen := 0;
384     if hHash = 0 then
385       if CryptCreateHash(hprov, c_HASH_ALGID, 0, 0, @hHash) = False then
386       begin
387         lastErr := GetLastError;
388         Str := IntToStr(lastErr)+' - '+SysErrorMessage(lastErr);
389         TrackingMsg.Add('Unable to create hash object in cryptCreateHash - '+Str);
390         RaiseErr('Unable to create hash object');
391         exit;
392       end;
393   end;
394   
395   //Called to hash a buffer of data
396   procedure tCryptography.HashBuf(pB: pByte; cnt: integer);
397   var
398     Str: String;
399   begin
400     if CryptHashData(hHash, pB, Cnt, 0) = False then
401     begin
402       lastErr := GetLastError;
403       Str := IntToStr(lastErr)+' - '+SysErrorMessage(lastErr);
404       TrackingMsg.Add('CryptHashData in crypto.HashBuf failed - '+Str);
405       RaiseErr('Unable to hash buff');
406       exit;
407     end;
408   end;
409   
410   //This is called at the end of a long hash to destroy the hash object
411   //If going to sign the hash it must be done before calling this.
412   procedure tCryptography.HashEnd;
413   begin
414       //Destroy the Hash
415       CryptDestroyHash(hHash);
416       hHash := 0;
417   end;
418   
419   //This call gets the current Hash value and puts the B64
420   //value in the public variable hashstr
421   //procedure tCryptography.GetHashValue;
422   function tCryptography.GetHashValue: String;
423   var
424     pbData: pbyte;
425     dwLen, LastErr: DWORD;
426     i: integer;
427     Str: String;
428   begin
429     fHashStr := '';
430     CHashLen := 0;
431     if hHash = 0 then
432       exit;
433     //Get the length of the hash
434     CryptGetHashParam(hHash, HP_HASHVAL, nil, @dwLen, 0);
435     GetMem(pbData, dwLen);
436     if CryptGetHashParam(hHash, HP_HASHVAL, pbData, @dwLen, 0) <> True then
437     begin
438       lastErr := GetLastError;
439       Str := IntToStr(lastErr)+' - '+SysErrorMessage(lastErr);
440       Comment := Comment + 'Error in CryptGetHashParam - '+Str;
441       RaiseErr(Str);
442     end;
443     CHashLen := dwLen;
444     SetLength(fhashValue, dwLen);
445     //Move the hash into the global variable
446     for i := 0 to dwLen - 1 do fHashValue[i] := pbytearray(pbData)[i];
447     i := MimeEncodedSize(dwlen);
448     SetLength(fHashStr, i);
449     MimeEncode(PChar(fHashValue)^, dwlen, PChar(fHashStr)^);
450     //Free temp memory
451     FreeMem(pbData);
452     result := HashStr;
453   end;
454   
455   
456   ///////////////////////////////////////////////////////////
457   //Open a system certificate store and
458   //check each certificates looking for a Certificate
459   //that is Valid and has a given ObjID.
460   //Leaves HCertStore and pCertContext open.
461   ///////////////////////////////////////////////////////////
462   function Tcryptography.FindCert: Boolean;
463   const
464     buffsize = 1024;
465   var
466     //Used to tell if we found the right parts
467     DateValid, Status, Signing: boolean;
468     dwData{, ValLen}: DWORD;
469     pbarray: pbytearray;
470     str2, NameString: string;
471     kpiData: CRYPT_KEY_PROV_INFO;
472     ContainerName, CSProviderName: widestring;
473     sContainerName, sCSProviderName: String;
474     //a pointer the the rgExtension blob
475     rgExtension: PCERT_EXTENSION;
476     cExtension: DWORD;
477     pce: PCERT_EXTENSION;
478     prgp: PPVOID;
479     str: String;
480     isDisplayNameCorrect: Boolean;  // JLI 120619
481     isAltNameMatched: Boolean;  // JLI 120619
482     SigningVal: Integer;
483     pTime: TFileTime;
484     NotAfterDate: String;     // JLI 120919
485     CertDisplayName: String;  // JLI 120919
486     DateValidValue: Integer;
487     InvalidDateLine: String;
488     RevocationReason: String;
489     RevocationStatusOK: Boolean;
490   
491     function Revco(): boolean;
492     var
493       //var's for Revocation checking
494       RevStatus: CERT_REVOCATION_STATUS;
495       pRevStatus: PCERT_REVOCATION_STATUS;
496       RevPara: CERT_REVOCATION_PARA;
497       rgpvContext: array[0..3] of pointer;
498       i: integer;
499       cContext: DWORD;
500     begin
501        //This takes a long time
502        RevPara.cbSize := sizeof(RevPara);
503        RevStatus.cbSize := sizeof(RevStatus);
504        RevStatus.dwIndex := 0;
505        RevStatus.dwError := 0;
506        pRevStatus := @RevStatus;
507        for i := 0 to 3 do
508          rgpvContext[i] := nil;
509        rgpvContext[0] := pCertContext;
510        cContext := 1;
511        prgp := @(rgpvContext[0]);
512        Result := CertVerifyRevocation( c_ENCODING_TYPE,
513                                CERT_CONTEXT_REVOCATION_TYPE,
514                                cContext,
515                                prgp,
516                                CERT_VERIFY_REV_SERVER_OCSP_FLAG,  // was CERT_VERIFY_REV_CHAIN_FLAG,
517                                nil,
518                                pRevStatus);
519        //Now to check the status
520        if Result = false then
521        begin
522          LastErr := GetLastError;
523          str2 := SysErrorMessage(LastErr);
524          RevocationReason := 'Revocation failed - error: '+IntToStr(LastErr)+' - '+Str2;
525          TrackingMsg.Add('  '+RevocationReason);
526        end;  //if
527     end;  //nested function
528     //End Nested functions
529   begin
530     Status := False;
531     Result := False;
532     //The system maps the current users Cert's to the MY store.
533     //So, Open the MY Store
534     if hCertStore = 0 then
535     begin
536       hCertStore := CertOpenSystemStore(0, PChar('MY'));
537     end;
538     if pCertContext <> nil then
539     begin
540         //If we can recheck we could skip the search.
541     end;
542     pCertContext := nil;
543     Reason := 'Could not open the Cert Store';
544     //if hCertStore is 0 the open didn't work
545     if hCertStore = 0 then
546     begin
547       TrackingMsg.Add('Unable to open a Certificate Store.');
548   //  SaveLog(); // 121214 remove saving of log to PKISignError
549       exit;
550     end;
551     //Set the size of some strings
552     Setlength(ContainerName, 255);
553     Setlength(CSProviderName, 255);
554     Setlength(NameString, 255);
555     //put some data in kpiData
556     kpiData.pwszContainerName := @ContainerName;
557     kpiData.pwszProvName := @CSProviderName;
558     kpiData.dwKeySpec := 0;
559     //Set a fail reason
560     Reason := 'Did not find a Cert.';
561     //Now Get the first certificates.
562     pCertContext := CertEnumCertificatesInStore(hCertStore, nil);
563     sCSProviderName := CSProviderName;
564     sContainerName := ContainerName;
565     Str := sCSProviderName + sContainerName;
566     //The loop
567     while (pCertContext <> nil) and (STATUS = False) do
568     begin
569       //INIT flags
570       TrackingMsg.Add(' ');
571   
572       //Get user display name
573       CertDisplayName := '';
574       if (CertGetNameString(pCertContext,
575           CERT_NAME_SIMPLE_DISPLAY_TYPE,
576           0,
577           0,
578           PChar(NameString),  //SetLength done at start
579           128)) then
580                CertDisplayName := StrPas(PChar(NameString));
581   
582       // expected CertDisplayName is ALPHA NUMERIC
583       // check first for alpha and last for digit
584       isDisplayNameCorrect := false;
585       str := UpperCase(Copy(CertDisplayName,1,1));
586       if (Pos(str,'ABCDEFGHIJKLMNOPQRSTUVWXYZ') > 0) then
587       begin
588         str := IntToStr(length(certDisplayName));
589         str := copy(certDisplayName,length(certDisplayName),1);
590         if (Pos(str,'0123456789)') > 0) then
591         begin
592           isDisplayNameCorrect := true;
593           if (UsrAltName = '') then     //121213 JLI insert for checking for valid UsrAltName
594           begin
595             if not (Pos(UpperCase(Piece(VistaUserName,',')),UpperCase(certDisplayName)) > 0) then
596               isDisplayNameCorrect := false;
597           end;
598         end;
599       end;
600   
601       //Get the Cert serialNumber
602       dwdata := pCertContext.pCertInfo.SerialNumber.cbData;
603       pbarray := pbytearray(pCertContext.pCertInfo.SerialNumber.pbData);
604       //Now convert the Serial number to HEX
605       CertSerialNum := XuDsigU.SerialNum(pbarray, dwdata);
606   
607       ptime := pCertContext.pCertinfo.NotAfter;
608       NotAfterDate := CertDateTimeStr(pTime);
609   
610       //Check that it has a Signature key
611       SigningVal := SigningCert(pCertContext);
612       Signing := false;
613   // JLI 121120    if (SigningVal div $80) > 0 then
614       if (SigningVal div $C0) > 0 then // JLI 121120
615         Signing := true;
616       //****************************
617   
618       SANFromCard := '';
619       CertName := '';
620       isAltNameMatched := false;
621       if (CertGetNameString(pCertContext,8,0,0,
622           PChar(NameString),   //SetLength done at start
623           128)) then
624       begin
625         CertName := StrPas(PChar(NameString));  // 120507 JLI Make change in regular
626       end;
627       if CertName = '' then
628       begin
629         if CertGetNameString(pCertContext,1,0,0,
630            PChar(NameString),   //SetLength done at start
631            128) then
632         begin
633           CertName := StrPas(PChar(NameString));
634         end;
635       end;
636       if not (UsrAltName = '') then    // UsrAltName = '' if to get value from card
637       begin
638         if UpperCase(UsrAltName) = UpperCase(CertName) then  // 120619 JLI make non case sensitive
639         begin
640           isAltNameMatched := true;
641         end
642         else
643         begin
644           CertName := '';
645           if CertGetNameString(pCertContext,1,0,0,
646              PChar(NameString),   //SetLength done at start
647              128) then
648           begin
649             CertName := StrPas(PChar(NameString));
650           end;
651           if (UpperCase(UsrAltName) = UpperCase(CertName)) then
652           begin
653             isAltNameMatched := true;
654           end;
655         end;
656       end;
657   
658       DateValid := True;
659       //Check that the time is valid - use current time
660       DateValidValue := CertVerifyTimeValidity(nil, pCertContext.pCertinfo);   // Pointer to CERT_INFO.
661       case DateValidValue of
662         -1: DateValid := False;   //Before the not before time
663          1: DateValid := False;   //After the not after time
664          0: DateValid := True;
665       end;
666       //******************i*********
667   
668   //    TrackingMsg.Add('Checking Cert:');
669   //    TrackingMsg.Add('  CertDisplayName: '+CertDisplayName);
670   //    if isDisplayNameCorrect then
671   //      TrackingMsg.Add('  CertDisplayName is Valid')
672   //    else
673   //      TrackingMsg.Add('  CertDisplayName is NOT Valid');
674   //    TrackingMsg.Add('  Cert Serial Number: '+CertSerialNum);
675   //    TrackingMsg.Add('  Not After Date: '+NotAfterDate);
676   //    if Signing then
677   //      TrackingMsg.Add('  Is Signing Cert: true')
678   //    else
679   //      TrackingMsg.Add('  Is Signing Cert: false');
680   //    TrackingMsg.Add('  CertName: '+CertName);
681       if not (UsrAltName = '') then
682       begin
683         if isAltNameMatched then
684           TrackingMsg.Add('  User SAN is Matched')
685         else
686           TrackingMsg.Add('  User SAN is NOT Matched');
687       end
688       else if isDisplayNameCorrect and signing and dateValid and not (CertName = '') then
689       begin
690         SANFromCard := CertName;
691         Result := true;
692         exit
693       end;
694   
695       if DateValidValue = -1 then
696         TrackingMsg.Add('  Certificate is not valid yet')
697       else if DateValidValue = 1 then
698         TrackingMsg.Add('  Certificate has expired');
699   
700       InvalidDateLine := '';
701       if not IgnoreDates then
702       begin
703         if isDisplayNameCorrect and signing and isAltNameMatched then  // JLI 120619 only display if matches criteria
704         begin
705           if DateValidValue = -1 then
706             InvalidDateLine := 'Certificate is not valid yet'
707           else if DateValidValue = 1 then
708             InvalidDateLine := 'Certificate has expired';
709         end;
710       end; // not ignoreDates
711   
712       RevocationStatusOK := true;
713       if isAltNameMatched then
714           if isDisplayNameCorrect then
715             if Signing then
716               if DateValid then
717               begin
718                 rgExtension := pCertContext.pCertInfo.rgExtension;
719                 cExtension := pCertContext.pCertInfo.cExtension;
720                 // see if we get the CRL dist point
721                 pce := CertFindExtension(PChar('2.5.29.31'), cExtension, rgExtension);
722                 if pce <> nil then
723                   CRLURL := CRLDistPoint(pce.Value.pbData, pce.Value.cbData);
724                 RevocationStatusOK := true;
725                 if not IgnoreRevoked then
726                 begin
727                   RevocationStatusOK := Revco;  //Check Revocation Status
728                 end;  // not IgnoreRevoked
729                 if DateValid then
730                   MasterDateValid := True;
731       end; //if FoundObjID and Signing and DateValid then
732   
733       //Set Status, Did we find a good one.
734       Status := DateValid and isAltNameMatched
735                 and Signing and RevocationStatusOK
736                 and isDisplayNameCorrect;
737   
738       if (not Status) and isAltNameMatched and Signing and isDisplayNameCorrect then
739       begin
740         Reason := '';
741         if not DateValid then
742           Reason := InvalidDateLine
743         else if not RevocationStatusOK then
744           Reason := RevocationReason;
745       end;    
746   
747       if CertName = '' then Status := False;
748   
749       //Only get the next Cert if Status is false.
750       if Status = False then  //--- Get the next certificate
751           pCertContext := CertEnumCertificatesInStore(hCertStore, pCertContext);
752     end; // while (pCertContext <> nil) and (STATUS = False) do
753     //*******************************************************************
754     if Status = True then
755     begin  //We found a Cert, get more data on it.
756       MasterCertChain := true;
757       if not fIgnoreMasterChain then
758       begin
759         //Need to look at which properties we need.
760         MasterCertChain := CertChainCheck(pCertContext);
761         if not MasterCertChain then
762         begin
763           Reason := 'Problems with verifying certificate chain of authority';
764           TrackingMsg.Add('MasterCertChain returned False');
765         end;
766       end; // if not fIgnoreMasterChain
767     end; //end if status
768   
769     if (not Status) and (not (InvalidDateLine = '')) then
770       ShowMessage(InvalidDateLine);
771     Result := Status and MasterCertChain;
772   end;
773   
774   function tCryptography.SignData: boolean;
775     //All the data that we need will be placed thru object calls
776     //This part will manage the other parts to get the work done.
777     //With luck we don't have to have all the code inline.
778   begin
779     TrackingMsg.Clear;
780     Comment := 'Entered crypto.SignData'+#10#13;
781     TrackingMsg.Add('');
782     TrackingMsg.Add('Entered crypto.SignData');
783     if isDEAsig then
784     begin
785       // order by alphabetic of property name, since this is the order
786       // they will be returned in for verification
787       DataBuffer := '';
788       DataBuffer := DataBuffer + DeaNumber;  // 10
789       DataBuffer := DataBuffer + DetoxNumber;  // 7
790       DataBuffer := DataBuffer + Directions;  // 6
791       DataBuffer := DataBuffer + DrugName;  // 4
792       DataBuffer := DataBuffer + IssuanceDate;  // 1
793       DataBuffer := DataBuffer + OrderNumber;
794       DataBuffer := DataBuffer + PatientAddress;  // 3
795       DataBuffer := DataBuffer + PatientName;  // 2
796       DataBuffer := DataBuffer + ProviderAddress;  // 9
797       DataBuffer := DataBuffer + ProviderName;  // 8
798       DataBuffer := DataBuffer + Quantity;  // 5
799     end;  // if isDEAsig
800     SigningStatus := True;
801     MasterDateValid := False;
802     MasterCertChain := False;
803     SigningStatus := DataReady;  //function, dataready will set reason
804     Result := SigningStatus;
805     if SigningStatus = False then
806     begin
807       Comment := 'Signing Status was False';
808       exit;
809     end;
810     //Build a Hash of the fDataBuffer
811     //Put the results in fHashValue
812     Reason := '';
813     Hashbuffer;
814     if FindCert <> True then
815     begin
816       TrackingMsg.Add('FindCert failed');
817       SigningStatus := False;
818       fHashStr := '';
819       if Reason = '' then
820         Reason := '89802004^Valid Certificate not found.';
821       ShowMessage(Reason); //121214 Show Reason
822     end; //if
823     //Have what we need, Lets sign the data
824     if SigningStatus then
825     begin
826       if not (LastPINValue = '') then
827         setPINValue(LastPINValue,0);
828       TrackingMsg.Add('Going to CertSignData');
829       Certsigndata;
830       if not SigningStatus then
831       begin
832         ShowMessage('Returned from CertSignData with failure'); // 121214 display message
833         TrackingMsg.Add('Returned from CertSignData with failure');
834       end;
835     end;
836     Result := SigningStatus;
837   //  if not Result then // 121214
838   //  SaveLog(); // 121214 remove saving of log to PKISignError
839     //Clean-up
840     Release;
841   end;
842   
843   procedure tCryptography.Release;
844   begin
845     //Clean-up
846     if isCardReset then
847       sCardReattach;
848     //Release the message
849     if hmsg <> nil then
850             CryptMsgClose(hMsg);
851     hmsg := nil;
852     //Release the Cert Context
853     if pCertContext <> nil then
854             CertFreeCertificateContext(pCertContext);
855     pCertContext := nil;
856     //Release the Cert Store.
857     if hCertStore <> 0 then
858             CertCloseStore(hCertStore, CERT_CLOSE_STORE_FORCE_FLAG);
859     hCertStore := 0;
860     // the following close the card on completion
861     if not (fhCard = 0) then
862     begin
863       SCardDisconnect(fhCard,SCARD_LEAVE_CARD);
864       fhCard := 0;
865     end;
866     if not (fhSC = 0) then
867     begin
868       SCardReleaseContext(fhSC);
869       fhSC := 0;
870     end;
871   end;
872   
873   procedure tCryptography.Certsigndata;
874   var
875     LastErr: DWORD;
876     pbEncodedBlob: array of byte;
877     cbEncodedBlob: DWORD;
878     cbContent: DWORD;
879     rgpbToBeSigned: array [0..0] of PByte;
880     rgcbToBeSigned: array [0..0] of PDWORD;
881     Encodedsize: integer;
882     str: string;
883   begin
884     SignMsgParam.cbSize := sizeof(SignMsgParam);
885     //zero out the stuff we don't use in the CRYPT_SIGN_MESSAGE_PARA
886     SignMsgParam.pvHashAuxInfo := nil;
887     SignMsgParam.cMsgCert := 0;
888     SignMsgParam.rgpMsgCert := nil;
889     SignMsgParam.cMsgCrl := 0;
890     SignMsgParam.rgpMsgCrl := nil;
891     SignMsgParam.cAuthAttr := 0;
892     SignMsgParam.rgAuthAttr := nil;
893     SignMsgParam.cUnauthAttr := 0;
894     SignMsgParam.rgUnauthAttr := nil;
895     SignMsgParam.dwFlags := 0;
896     //Now for the parameters we want to use
897     SignMsgParam.dwInnerContentType := 0;
898     SignMsgParam.pSigningCert := pCertContext;
899     SignMsgParam.dwMsgEncodingType := c_ENCODING_TYPE;
900     SignMsgParam.HashAlgorithm.pszObjId := szOID_RSA_SHA1RSA; //szOID_RSA_SHA256RSA; //szOID_RSA_SHA1RSA; //szOID_RSA_MD2;
901     //Include the Signing Cert
902     SignMsgParam.cMsgCert := 1;
903     SignMsgParam.rgpMsgCert := @pCertContext;
904     //And now the data to be signed (the hash in this case)
905     cbContent := length(fHashValue);
906     rgpbToBeSigned[0] := @fHashValue;
907     rgcbToBeSigned[0] := @cbContent;
908     cbEncodedBlob := 0;
909     cbEncodedBlob := 4096;  //Fixed size normal Sig is < 2K
910     setlength(pbEncodedBlob, cbEncodedBlob + 1);
911     // We set detachedsignature to false because we did
912     // the hash ourselfs
913     if not CryptSignMessage(@SignMsgParam,
914                     False,  //DetachedSignature
915                     1,
916                     rgpbToBeSigned[0],  //rgpbToBeSigned,
917                     rgcbToBeSigned[0],  //rgcbToBeSigned,
918                     pointer(pbEncodedBlob),     //Pointer to return Blob
919                     @cbEncodedBlob) then
920     begin
921       SigningStatus := false;
922       TrackingMsg.Add('Returned from CryptSignMessage with failure');
923       LastErr := GetLastError;
924       Reason := '89802010^Signature Error - ' + SysErrorMessage(LastErr);
925       TrackingMsg.Add(Reason);
926     end;
927     if SigningStatus then
928     begin   //1
929       //Try and use Base64 encoding
930       //Get the size of the Encoded string
931       EncodedSize := MimeEncodedSize(cbEncodedBlob);
932       str := '';
933       //Set the size of the string
934       SetLength(str, EncodedSize);
935       //Now to do the encodeing
936       MimeEncode(PChar(pbEncodedBlob)^, cbEncodedBlob, PChar(str)^);
937       fSignatureStr := str;
938       //Lets check the Cert Chain
939       TrackingMsg.Add('Going to CertChainCheck');
940       CertChainCheck(pCertContext);
941       TrackingMsg.Add('Returned from CertChainCheck');
942     end; //if 1
943     //Release the CertContext and CertStore
944     Release;
945   
946     //Test if we can load the signature back in
947     if SigningStatus then
948       if not CheckSig(pointer(pbEncodedBlob),cbEncodedBlob) then
949       begin
950         TrackingMsg.Add('CheckSig (checking can load signature back) failed');
951         SigningStatus := false;
952         Reason := '89802009^Signature Check failed';
953       end;
954   end;
955   
956   
957   function tCryptography.CheckSig(pBlob: pointer; Blobsize: DWORD): boolean;
958   var
959     LastErr: DWORD;
960     pbDecoded: array of byte;
961     cbDecoded, cbSignerCertInfo: DWORD;
962     hMsg: HCRYPTMSG;
963     CertInfoBlob: array of DWORD;
964     str, NameString: string;
965     pTime: PFileTime;
966     i: integer;
967   begin
968     Result := false;
969     //---------------
970     subReason := 'SC msgOpen fail';
971     //Lets see if we can reload the msg.
972     hMsg := CryptMsgOpenToDecode(c_ENCODING_TYPE,        // Encoding type.
973                      0,            // Flags.
974                      0,            // Use the default message type.
975                                    // The message type is
976                                    // listed in the message header.
977                      0,            // Cryptographic provider. Use NULL
978                                    // for the default provider.
979                      nil,          // Recipient information.
980                      nil);         // Stream information.
981     if hMsg = nil then
982       Exit;
983     //--------------------------------------------------------------------
984     //  Update the message with an encoded blob.
985     //  Both pbEncodedBlob, the encoded data,
986     //  and cbEnclodeBlob, the length of the encoded data,
987     //  must be available.
988     if CryptMsgUpdate(hMsg,        // Handle to the message
989                         pBlob,     // Pointer to the encoded blob
990                         BlobSize,              // Size of the encoded blob
991                         True)                      // Last call
992     then
993       str := 'The encoded blob has been added to the message.'
994     else
995     begin
996       lastErr := GetLastError;
997       Str := IntToStr(lastErr)+' - '+SysErrorMessage(lastErr);
998       RaiseErr('Decode MsgUpdate failed - '+Str);
999     end;
1000  //We will try and verify the signature here.
1001  //new part
1002     //---------------
1003     // Get the number of bytes needed for a buffer
1004     // to hold the Decoded message.
1005    if CryptMsgGetParam(hMsg,                 //Handle to msg
1006                         CMSG_CONTENT_PARAM,   //Param type
1007                         0,                    //Index
1008                         nil,
1009                         @cbDecoded)
1010    then
1011      Str := 'The message param has been acquired'
1012    else
1013    begin
1014      lastErr := GetLastError;
1015      Str := IntToStr(lastErr)+' - '+SysErrorMessage(lastErr);
1016      TrackingMsg.Add('Decode CMSG_CONTENT_PARAM failed - '+Str);
1017      RaiseErr('Decode CMSG_CONTENT_PARAM failed');
1018      exit;
1019    end;
1020     // Allocate memory
1021    SetLength(pbDecoded, cbDecoded);
1022     //Copy the content to the buffer
1023     if CryptMsgGetParam(hMsg,                 //Handle to msg
1024                         CMSG_CONTENT_PARAM,   //Param type
1025                         0,                    //Index
1026                         pbDecoded,            //Address for return data
1027                         @cbDecoded)           //Size of return data
1028                    Then
1029       Str := 'The message param has been acquired'
1030     else
1031     begin
1032       lastErr := GetLastError;
1033       Str := IntToStr(lastErr)+' - '+SysErrorMessage(lastErr);
1034       TrackingMsg.Add('Decode CMSG_CONTENT_PARAM failed - '+Str);
1035       RaiseErr('Decode CMSG_CONTENT_PARAM failed');
1036       exit;
1037     end;
1038     //Verify the signature
1039     //First, Get the signer CERT_INFO from the message
1040     //------
1041     //Get the size needed
1042     if CryptMsgGetParam( hMsg,      //Msg Handle
1043                          CMSG_SIGNER_CERT_INFO_PARAM,   //Param Type
1044                          0,         //Index
1045                          nil,
1046                          @cbSignerCertInfo)  //Size of return data
1047     then
1048       Str:=IntToStr(cbSignerCertInfo) + ' bytes needed'
1049     else
1050     begin
1051       lastErr := GetLastError;
1052       Str := IntToStr(lastErr)+' - '+SysErrorMessage(lastErr);
1053       TrackingMsg.Add('Verify SIGNER_CERT #1 failed - '+Str);
1054       RaiseErr('Verify SIGNER_CERT #1 failed');
1055       exit;
1056     end;
1057     //Allocate Memory
1058     SetLength(CertInfoBlob,cbSignerCertInfo);
1059     //Get the signer CERT_INFO
1060     if CryptMsgGetParam( hMsg,      //Msg Handle
1061                          CMSG_SIGNER_CERT_INFO_PARAM,   //Param Type
1062                          0,         //Index
1063                          Pointer(CertInfoBlob),
1064                          @cbSignerCertInfo)  //Size of return data
1065     then
1066       Str:='CertInfoBlob acquired'
1067     else
1068     begin
1069       lastErr := GetLastError;
1070       Str := IntToStr(lastErr)+' - '+SysErrorMessage(lastErr);
1071       TrackingMsg.Add('Verify SIGNER_CERT #2 failed - '+Str);
1072       RaiseErr('Verify SIGNER_CERT #2 failed');
1073       exit;
1074     end;
1075     //------------
1076     //Open a certificate store in memory using CERT_STORE_PROV_MSG
1077     //which initializes it with the certificates from the MSG
1078     hCertStore := CertOpenStore( CERT_STORE_PROV_MSG,     //Store prov type
1079                                  c_ENCODING_TYPE,
1080                                  0,                       //Cryptographic provider
1081                                                           // use nil for default
1082                                  0,                       //Flags
1083                                  hMsg);
1084     if hCertStore = 0 then
1085     begin
1086       lastErr := GetLastError;
1087       Str := IntToStr(lastErr)+' - '+SysErrorMessage(lastErr);
1088       TrackingMsg.Add('Open Store failed - '+Str);
1089       RaiseErr('Open Store failed');
1090       exit;
1091     end;
1092     //--------------
1093     //Find the signer's cert in the store
1094     pCertContext :=
1095       CertGetSubjectCertificateFromStore(hCertStore,
1096                                          c_ENCODING_TYPE,
1097                                          pointer(CertInfoBlob)); // pSignerCertInfo);
1098     if pCertContext = nil then
1099     begin
1100       lastErr := GetLastError;
1101       Str := IntToStr(lastErr)+' - '+SysErrorMessage(lastErr);
1102       TrackingMsg.Add('GetSubjectCert failed - '+Str);
1103       RaiseErr('GetSubjectCert failed');
1104       exit;
1105     end;
1106     //Allocate memory for name
1107     SetLength(NameString, 256);
1108     //Get the Cert Name String
1109     CertGetNameString(pCertContext,
1110                       CERT_NAME_SIMPLE_DISPLAY_TYPE,
1111                       0,
1112                       0,
1113                       pointer(NameString),
1114                       256);
1115     //---------
1116     //Use the CERT_INFO from the signer Cert to Verify
1117     //the signature
1118     if CryptMsgControl( hMsg,             //Handle to msg
1119                         0,                //Flags
1120                         CMSG_CTRL_VERIFY_SIGNATURE,
1121                         pCertContext.pCertInfo)   //Pointer to the CERT_INFO
1122     then
1123       Result := true
1124     else
1125     begin
1126       lasterr := getLastError; // Check last system error
1127       subReason := 'Digital signature verification failed: ' +
1128                  SysErrorMessage(lasterr);
1129     end;
1130    if not IgnoreDates then
1131    begin
1132      //Check that the time is valid
1133      pTime := nil;
1134      i := CertVerifyTimeValidity(
1135            pTime,                // Use time of signing or current time.
1136            pCertContext.pCertinfo);   // Pointer to CERT_INFO.
1137      case i of
1138        -1 : Str := '89802019^Before Cert effective date.';   //Before the not before time
1139        1 : Str :='89802020^Certificate expired.'  ;   //After the not after time
1140        0 : Str := 'DateValid';
1141      end;
1142      if not (CompareStr(Str, 'DateValid') = 0) then
1143        ShowMessage('Certificate not valid: '+Str);
1144    end; // if not IgnoreDates
1145    Release;
1146  end;
1147  
1148  //Check the Cert Chain for the Cert just used.
1149  function tCryptography.CertChainCheck(pCertContext: PCCERT_CONTEXT): boolean;
1150  var
1151      { Private declarations }
1152      hChainEngine: HCERTCHAINENGINE;
1153      ChainConfig: CERT_CHAIN_ENGINE_CONFIG;
1154      pChainContext: PCCERT_CHAIN_CONTEXT;
1155      EnhkeyUsage: CERT_ENHKEY_USAGE;
1156      CertUsage: CERT_USAGE_MATCH;
1157      ChainPara: CERT_CHAIN_PARA;
1158      dwFlags: DWORD;
1159      i: integer;
1160      fStatus: boolean;  //Local status
1161      Str: String;
1162      //-----------------------------------------------------
1163      //nested function
1164      procedure Memo(s: string);
1165      begin
1166          TrackingMsg.Add(s);
1167      end;
1168      
1169      procedure SetStatus(sta: boolean; s: string);
1170      begin
1171          fStatus := False;
1172          if sta then
1173            fStatus := True;
1174          SubReason := s;
1175          Memo(s);
1176      end;
1177      //end nested function
1178      //-------------------------------------------------------
1179  begin
1180      EnhkeyUsage.cUsageIdentifier := 0;
1181      EnhkeyUsage.rgpszUsageIdentifier := nil;
1182      CertUsage.dwType := USAGE_MATCH_TYPE_AND;
1183      CertUsage.Usage := EnhkeyUsage;
1184      ChainPara.cbSize := sizeof(chainPara);
1185      ChainPara.RequestedUsage := CertUsage;
1186      ChainConfig.cbSize := sizeof(CERT_CHAIN_ENGINE_CONFIG);
1187      ChainConfig.hRestrictedRoot := 0;
1188      ChainConfig.hRestrictedTrust := 0;
1189      ChainConfig.hRestrictedOther := 0;
1190      ChainConfig.cAdditionalStore := 0;
1191      ChainConfig.rghAdditionalStore := 0;
1192      ChainConfig.dwFlags := CERT_CHAIN_REVOCATION_CHECK_CHAIN;
1193      ChainConfig.dwUrlRetrievalTimeout := 30000;
1194      ChainConfig.MaximumCachedCertificates := 0;
1195      ChainConfig.CycleDetectionModulus := 0;
1196      //---------------------------------------------------------
1197      //   Create the nondefault certificate chain engine.
1198      if CertCreateCertificateChainEngine(@ChainConfig, hChainEngine) then
1199          Memo('  A chain Engine has been created')
1200      else
1201      begin
1202          lastErr := GetLastError;
1203          Str := IntToStr(lastErr)+' - '+SysErrorMessage(lastErr);
1204          TrackingMsg.Add('The Engine Create Failed - '+Str);
1205          RaiseErr('The engine Create Failed');
1206      end;
1207      //---------------------------------------------------------
1208      //----------------------------------------------------------------
1209      //        Build a chain using CertGetCertificateChain
1210      //        and the certificate retrieved.
1211      dwFlags := CERT_CHAIN_REVOCATION_CHECK_CHAIN;
1212      if (CertGetCertificateChain(hChainEngine,
1213          // Use 0 the default chain engine.
1214          pCertContext,          // Pointer to the end certificate.
1215          nil,                  // Use the default time.
1216          0,              // Search no additional stores.
1217          @ChainPara,            // Use AND logic, and enhanced key usage
1218          // as indicated in the ChainPara
1219          // data structure.
1220          dwFlags,
1221          nil,                 // Currently reserved.
1222          pChainContext))       // Return a pointer to the chain created.
1223      then
1224          Memo('  The chain has been created. ')
1225      else
1226      begin
1227          lastErr := GetLastError;
1228          Str := IntToStr(lastErr)+' - '+SysErrorMessage(lastErr);
1229          TrackingMsg.Add('The chain could not be created - '+Str);
1230          RaiseErr('The chain could not be created.');
1231      end;
1232      //---------------------------------------------------------------
1233      // Display some of the contents of the chain.
1234      Memo('  The size of the chain context is ' + IntToStr(pChainContext.cbSize));
1235      Memo('  '+IntToStr(pChainContext.cChain) + ' simple chains found.');
1236      i := pChainContext.TrustStatus.dwErrorStatus;
1237      Memo('  Error status for the chain: '+IntToStr(i));
1238      case i of
1239          CERT_TRUST_NO_ERROR:
1240              SetStatus(True, '    No error found for this certificate or chain.');
1241          CERT_TRUST_IS_NOT_TIME_VALID:
1242              SetStatus(False,
1243                  '    This certificate or one of the certificates in the certificate chain is not time-valid.');
1244          CERT_TRUST_IS_NOT_TIME_NESTED:
1245              SetStatus(False, '    Certificates in the chain are not properly time-nested.');
1246          CERT_TRUST_IS_REVOKED:
1247              SetStatus(False,
1248                  '    Trust for this certificate or one of the certificates in the certificate chain has been revoked.');
1249          CERT_TRUST_IS_NOT_SIGNATURE_VALID:
1250              SetStatus(False,
1251                  '    The certificate or one of the certificates in the certificate chain does not have a valid signature.');
1252          CERT_TRUST_IS_NOT_VALID_FOR_USAGE:
1253              SetStatus(False,
1254                  '    The certificate or certificate chain is not valid in its proposed usage.');
1255          CERT_TRUST_IS_UNTRUSTED_ROOT:
1256              SetStatus(False, '    The certificate or certificate chain is based on an untrusted root.');
1257          CERT_TRUST_REVOCATION_STATUS_UNKNOWN:
1258              SetStatus(False,
1259                  '    The revocation status of the certificate or one of the certificates in the certificate chain is unknown.');
1260          CERT_TRUST_IS_CYCLIC:
1261              SetStatus(False,
1262                  '    One of the certificates in the chain was issued by a certification authority that the original certificate had certified.');
1263          CERT_TRUST_IS_PARTIAL_CHAIN:
1264              SetStatus(False, '    The certificate chain is not complete.');
1265          CERT_TRUST_CTL_IS_NOT_TIME_VALID:
1266              SetStatus(False, '    A CTL used to create this chain was not time-valid.');
1267          CERT_TRUST_CTL_IS_NOT_SIGNATURE_VALID:
1268              SetStatus(False, '    A CTL used to create this chain did not have a valid signature.');
1269          CERT_TRUST_CTL_IS_NOT_VALID_FOR_USAGE:
1270              SetStatus(False, '    A CTL used to create this chain is not valid for this usage.');
1271          else
1272              SetStatus(True, '    No Error information returned');
1273      end;  //case
1274      i := pChainContext.TrustStatus.dwInfoStatus;
1275      Memo('  Info status for the chain: '+IntToStr(i));
1276      case (i) of
1277          CERT_TRUST_HAS_EXACT_MATCH_ISSUER:
1278              Memo('    An exact match issuer certificate has been found for this certificate.');
1279          CERT_TRUST_HAS_KEY_MATCH_ISSUER:
1280              Memo('    A key match issuer certificate has been found for this certificate.');
1281          CERT_TRUST_HAS_NAME_MATCH_ISSUER:
1282              Memo('    A name match issuer certificate has been found for this certificate.');
1283          CERT_TRUST_IS_SELF_SIGNED:
1284              Memo('    This certificate is self-signed.');
1285          CERT_TRUST_HAS_PREFERRED_ISSUER:
1286              Memo('    This certificate has a preferred issuer');
1287          CERT_TRUST_HAS_ISSUANCE_CHAIN_POLICY:
1288              Memo('    An Issuance Chain Policy exists');
1289          CERT_TRUST_HAS_VALID_NAME_CONSTRAINTS:
1290              Memo('    A valid name contraints for all namespaces, including UPN');
1291          CERT_TRUST_IS_COMPLEX_CHAIN:
1292              Memo('    The certificate chain created is a complex chain.');
1293          else
1294              Memo('    No information status reported.');
1295      end; // End case
1296      //--------------------------------------------------------------------
1297      Result := fStatus;
1298      if Result then
1299        Memo('  Certificate Chain returned true')
1300      else
1301        Memo('  Certificate Chain returned false and failed');
1302  end;
1303  
1304  function tCryptography.CRLDistPoint(pbData: pointer; cbData: integer): string;
1305  var
1306      buff: array[0..1023] of byte;
1307      cbBuff: DWORD;
1308      pvcrl_dist_info: PCRL_DIST_POINTS_INFO;
1309      pvcrl_dist_point: PCRL_DIST_POINT;
1310      distPointName: CRL_DIST_POINT_NAME;
1311      CertAltNameInfo: CERT_ALT_NAME_INFO;
1312      CertAltNameEntry: PCERT_ALT_NAME_ENTRY;
1313      ix, j: integer;
1314      str, lcstr: string;
1315  begin
1316      pvcrl_dist_info := @buff;
1317      cbBuff := 1024;
1318      Result := '';
1319      str := '';
1320      if CryptDecodeObject(c_ENCODING_TYPE,
1321          X509_CRL_DIST_POINTS,
1322          pbData,
1323          cbData,
1324          0,
1325          pvcrl_dist_info, @cbBuff) = False then
1326          Str := SysErrorMessage(GetLastError);
1327      if Str = '' then
1328      begin
1329        j := pvCrl_dist_Info.cDistPoint;
1330        Result := 'CRL dist cnt: ' + IntToStr(j) + #9;
1331        pvcrl_dist_point := pvCrl_dist_Info.rgDistPoint;
1332        for ix := 0 to j - 1 do
1333          begin
1334            DistPointName := pvCrl_Dist_Point.DistPointName;
1335            if DistPointName.dwDistPointNameChoice = CRL_DIST_POINT_FULL_NAME then
1336              begin
1337                str := '';
1338                CertAltNameInfo := DistPointName.FullName;
1339                CertAltNameEntry := CertAltNameInfo.rgAltEntry;
1340                if CertAltNameEntry.dwAltNameChoice = CERT_ALT_NAME_URL then
1341                  begin
1342                    str := CertAltNameEntry.pwszURL;
1343                    lcstr := LowerCase(str);
1344                    //Only send http or URL's that end in .COM or .GOV for now
1345                    if (pos('http' , lcstr) = 1) or
1346                       (pos('.com/', lcstr) > 0) or
1347                       (pos('.gov/', lcstr) > 0) then
1348                                Result := Result + str + #9;
1349                  end;
1350             end;
1351             inc(pvcrl_dist_point, 1);
1352         end;
1353      end;
1354  end;
1355  
1356  //See if the Cert is valid for Signing.
1357  function tCryptography.SigningCert(pCertCtx: PCCERT_CONTEXT): Integer;
1358  var
1359      by: byte;
1360      pb: pbyte;
1361  begin
1362      Result := 0;
1363      by := 0;
1364      pb := @by;
1365      if CertGetIntendedKeyUsage(c_ENCODING_TYPE,
1366                     pCertCtx.pCertInfo,
1367                     pb,
1368                     1) then
1369         Result := by;
1370  end;
1371  
1372  function sCardReady: boolean;
1373  const
1374      MAX_SCARD_READERS = 10;
1375  var
1376      szReaders: string;
1377      dwI: DWORD;
1378      cch: integer;
1379      Str: String;
1380      ActiveProtocol: DWORD;
1381      fhSC: SCARDCONTEXT;
1382      fhCard: longint;
1383      offset, index: Integer;
1384      done: Boolean;
1385      charval: Char;
1386  begin
1387      Result := False;
1388      dwi := SCardEstablishContext(SCARD_SCOPE_USER,
1389          nil,
1390          nil, @fhSC);
1391      //See if we got a handle
1392      if dwi <> SCARD_S_SUCCESS then
1393      begin
1394        exit;
1395      end;
1396  //    dwi := SCardListReadersA(fhSC,   hint fix
1397      SCardListReadersA(fhSC,
1398          nil,
1399          nil,
1400          cch);
1401      setlength(szReaders, cch);
1402      dwi := SCardListReadersA(fhSC,
1403          nil,
1404          PChar(szReaders),
1405          cch);
1406      if dwi = SCARD_S_SUCCESS then
1407        Result := True;
1408      // check for card in reader
1409      offset := 1;
1410      done := false;
1411      Str := StrPas(PChar(szReaders));
1412      while not done do
1413      begin
1414        dwi := SCardConnectA(fhSC, PChar(Str), SCARD_SHARE_SHARED, 3, fhCard, @ActiveProtocol);
1415        if dwi = SCARD_S_SUCCESS then
1416          done := true
1417        else
1418        begin
1419          for index := offset to cch do
1420          begin
1421            offset := index;
1422            charval := szReaders[index];
1423            if charval = #0 then
1424              break;
1425          end;
1426          offset := offset + 1;
1427          if szReaders[offset] = #0 then
1428            done := true
1429          else
1430          begin
1431            for index := 1 to cch-offset+1 do
1432            begin
1433              szReaders[index] := szReaders[index+offset-1];
1434            end;
1435            Str := StrPas(PChar(szReaders));
1436            offset := 1;
1437          end;
1438        end;
1439      end;
1440      if not (dwi = SCARD_S_SUCCESS) then
1441      begin
1442        Result := false;
1443        Str := SysErrorMessage(dwi);
1444        ShowMessage(Str);
1445      end;
1446  end;
1447  
1448  
1449  procedure tCryptography.Reset;
1450  begin
1451      isDEAsig := True;  //Are we doing a DEA signature
1452      SigningStatus := False;
1453      fHashStr := '';
1454      fSignatureStr := '';
1455      DataBuffer := '';
1456      Reason := '';
1457      CrlUrl := '';
1458  end;
1459  
1460  
1461  // sCardReset and sCardReattach are not needed if CheckPINValue, below,
1462  // is used.
1463  procedure TCryptography.sCardReset;
1464  begin
1465      SCardDisconnect(fhCard,SCARD_UNPOWER_CARD);
1466      fisCardReset := true;
1467  end;
1468  
1469  procedure TCryptography.sCardReattach;
1470  var
1471    PActiveProtocol: LongInt;
1472  begin
1473      SCardReconnect(fhCard, SCARD_SHARE_SHARED, 3, SCARD_LEAVE_CARD, PActiveProtocol);
1474      fisCardReset := false;
1475  end;
1476  
1477  function checkPINValue(InputForm: TComponent): TPINResult;
1478  var
1479    ready: Boolean;
1480    handle2: DWORD;
1481    Container: String;
1482    ErrVal: Integer;
1483    Done: Boolean;
1484    fPinEntry: TfrmPINPrompt;
1485    LoopCount: Integer;
1486  begin
1487    if not sCardReady then
1488    begin
1489      ShowMessage('Put a smart card in the Reader, then Press OK');
1490      sleep(5000);
1491      if not sCardReady then
1492      begin
1493        Result := prError;
1494        exit;
1495      end;
1496    end;
1497    handle2 := 0;
1498    Container := '';
1499    ready := CryptAcquireContext(@handle2,PChar(Container),pchar('ActivClient Cryptographic Service Provider'),1,0);
1500    if ready = false then
1501    begin
1502     // Unable to aquire context, check if failure was due to
1503     // absence of key container.
1504  
1505     CryptAcquireContext(@handle2,
1506                  pchar(Container),
1507                  pchar('ActivClient Cryptographic Service Provider'),
1508                  1,
1509                  CRYPT_NEWKEYSET);
1510    end;
1511    if handle2 = 0 then
1512    begin
1513      ErrVal := GetLastError;
1514      ShowMessage('Could not aquire context Last Error val was '+IntToStr(ErrVal)+'  '+SysErrorMessage(ErrVal));
1515      Result := prError;
1516      exit;
1517    end;
1518    try
1519      Result := prOK;
1520      Done := false;
1521      LoopCount := 1;
1522      fPinEntry := TfrmPINPrompt.Create(InputForm);
1523      try
1524        while not Done do
1525        begin
1526          fPinEntry.edtPINValue.Text := '';
1527          if fPinEntry.ShowModal() = mrOK then
1528          begin
1529            PinValue := fPinEntry.edtPinValue.Text;
1530            if PinValue = '' then
1531            begin
1532              ShowMessage('Enter a valid PIN value or Press Cancel');
1533              Dec(LoopCount);
1534            end
1535            else
1536            begin
1537              ready := setPINValue(PinValue,handle2);
1538              if ready then
1539              begin
1540                LastPINValue := PinValue;
1541                Result := prOK;
1542                Done := true;
1543              end
1544              else
1545              begin
1546                if LoopCount < 3 then
1547                begin
1548                  ShowMessage('Invalid PIN entry - You only have '+IntToStr(3-LoopCount)+' attempts left before it is locked.');
1549                end
1550                else
1551                begin
1552                  ShowMessage('That was three (3) unsuccessful tries, the Card Reader is Locked');
1553                  Result := prLocked;
1554                  Done := true;
1555                end;
1556              end;
1557            end;
1558            Inc(LoopCount);
1559          end
1560          else
1561          begin
1562            ShowMessage('Pin Entry was cancelled');
1563            Result := prCancel;
1564            Done := true;
1565          end;
1566        end;
1567      finally
1568        fPinEntry.Free;
1569      end;
1570    finally
1571      if not (handle2 = 0) then
1572      begin
1573        CryptReleaseContext(handle2, 0);
1574      end;
1575    end;
1576  end;
1577  
1578  function setPINValue(PinValue: String; handle: Dword): Boolean;
1579  var
1580    handleValue: DWord;
1581    Container: String;
1582    isNewHandle: Boolean;
1583    text: array [0..5000] of char;
1584    Flags: Cardinal;
1585    text1: PByte;
1586    i: integer;
1587  begin
1588    isNewHandle := false;
1589    handleValue := handle;
1590    try
1591      if (handleValue = 0) then
1592      begin
1593        result := CryptAcquireContext(@handleValue,PChar(Container),pchar('ActivClient Cryptographic Service Provider'),1,0);
1594        if not result then
1595        begin
1596         // Unable to aquire context, check if failure was due to
1597         // absence of key container.
1598         result := CryptAcquireContext(@handleValue,
1599                    pchar(Container),
1600                    pchar('ActivClient Cryptographic Service Provider'),
1601                    1,
1602                    CRYPT_NEWKEYSET);
1603        end;
1604        if not result then
1605          exit;
1606        isNewHandle := true;
1607      end;
1608      Flags := 0;
1609      for i := 1 to Length(PinValue) do
1610      begin
1611        text[i-1] := PinValue[i];
1612      end;
1613      text[Length(PinValue)] := #0;
1614      text1 := @text;
1615      result := false;
1616      result := CryptSetProvParam(handleValue,33,text1,Flags);
1617    finally
1618      if isNewHandle and not (handleValue = 0) then
1619        CryptReleaseContext(handleValue, 0);
1620    end;
1621  end;
1622  
1623  
1624  function ptochars(pbdata: pbytearray; len: DWORD): string;
1625  var
1626      i: integer;
1627  begin
1628      Result := '';    //Init return string
1629      for i := 0 to len do
1630      begin
1631          Result := Result + char(pbdata[i]);
1632      end;
1633  end;  // ptochars
1634  
1635  function getSANFromCard(InputForm: TComponent; crypto: tCryptography): String;
1636  var
1637   errMsg: String;
1638   cpvRes: TPINResult;
1639  begin
1640    crypto.TrackingMsg.Clear;
1641    crypto.TrackingMsg.Add('Entered getSANFromCard');
1642    SANFromCard := '';
1643    cpvRes := checkPINValue(InputForm);
1644    if (cpvRes = prOK) then
1645    begin
1646      crypto.FindCert;
1647    end;
1648    result := SANFromCard;
1649    if result = '' then
1650    begin
1651      errMsg :=    'Please verify that you are logged on to the CPRS system and that your PIV card is inserted.';
1652      errMsg := errMsg + ' There is a possible mismatch between your VistA last name and the last name of the certificate on your card.';
1653      errMsg := errMsg + ' If it matches and you are still experiencing issues, please contact your card issuer for assistance.';
1654  //    crypto.TrackingMsg.Add('SAN value returned as null string');
1655      if (not(cpvRes=prCancel)) then ShowMessage(errMsg);
1656  //  crypto.SaveLog(); // 121214 remove saving of log to PKISignError
1657    end;
1658  end;
1659  
1660  {
1661   * SaveLog -
1662   */
1663  }
1664  (*procedure TCryptography.SaveLog();
1665  var
1666    MemoList: TStringList;
1667    DirName: String;
1668    FileName: String;
1669    i: Integer;
1670  begin
1671        DirName := 'C:\PKISignError';
1672        FileName := DirName +FormatDateTime('"\PKISignError_"yyyymmdd"@"hhmmss".txt"',Now);
1673        MemoList := TStringList.Create;
1674        MemoList.Add('Tracking Data:');
1675        for i := 0 to TrackingMsg.Count-1 do
1676        begin
1677          MemoList.Add('  '+TrackingMsg.Strings[i]);
1678        end;
1679        if not DirectoryExists(DirName) then
1680          if not CreateDir(DirName) then
1681            raise Exception.Create('Cannot create '+DirName);
1682        MemoList.SaveToFile(FileName);
1683        MemoList.Free;
1684  end;
1685    *)
1686  end.

Module Calls (2 levels)


XuDsigS
 ├wcrypt2
 ├XuDsigU
 ├XlfMime
 ├XuDsigConst
 │ └wcrypt2
 ├WinSCard
 └fPINPrompt

Module Called-By (2 levels)


                     XuDsigS
                   uOrders┤ 
                   uCore┤ │ 
                 fODBase┤ │ 
                 rODBase┤ │ 
                  fFrame┤ │ 
                 fOrders┤ │ 
             fOrdersSign┤ │ 
                   fMeds┤ │ 
               fARTAllgy┤ │ 
                  fNotes┤ │ 
               fConsults┤ │ 
         fReminderDialog┤ │ 
                 fReview┤ │ 
            fOrdersRenew┤ │ 
               fOrdersCV┤ │ 
                 fODMeds┤ │ 
                 fOMNavA┤ │ 
         fOrderSaveQuick┤ │ 
                  fOMSet┤ │ 
          fOrdersRelease┤ │ 
                 fOMHTML┤ │ 
               fODMedNVA┤ │ 
fODChangeUnreleasedRenew┤ │ 
          fOrdersOnChart┤ │ 
         fODReleaseEvent┤ │ 
               fODActive┘ │ 
                 fFrame...┤ 
            fOrdersSign...┤ 
                fReview...┘