Attribute VB_Name = "GermanHealthSetup"
Option Explicit

' $Id: GermanHealthSetup.bas $
' You should only need to do these procedures once.
'   Last Updated:
'   $Date: 2014-09-04 19:02:00 $
'   $Revision: 1.2.0 $

' ******************************************************************************
' Copyright (c) 2007-14 DI Management Services Pty Limited. All rights reserved.
' Provided to illustrate the use of functions in the CryptoSys PKI Toolkit.
' Not necessarily a good example of secure programming techniques.
' Provided "as is" with no warranties. Use at your own risk.
' ******************************************************************************

' Path to working directory - CHANGE THIS TO SUIT YOUR SYSTEM
' (with trailing \) or leave empty to use current working dir
Private Const TESTPATH As String = "C:\Test\GermanHealth\"
Private Const YOUR_PKID As String = "999009991"

' Note we've added an "a" to the end of each filename to indicate a change since our earlier 2008 version.

' Step 1.
' Make your own public/private key pair
' CAUTION: if you run this again it will destroy your original keys

Private Function ghs_Make_Your_Keys() As Boolean
' INPUT:  Key length in bits; password
' OUTPUT: Public key in file; private key in encrypted file
    Dim nRet As Long
    Dim strPublicKeyFile As String
    Dim strPrivateKeyFile As String
    Dim strPassword As String
    
    ' Set filenames to be created
    strPublicKeyFile = TESTPATH & YOUR_PKID & "a_pub.p1"
    strPrivateKeyFile = TESTPATH & YOUR_PKID & "a_pri.p8"
    ' Set your password - use something decent!
    strPassword = "password"
    
    ' Create a new pair of 2048-bit RSA keys saved as binary BER-encoded files
    Debug.Print "About to create a new RSA key pair..."
    nRet = RSA_MakeKeys(strPublicKeyFile, strPrivateKeyFile, 2048, _
        PKI_RSAEXP_EQ_65537, 50, 1000, strPassword, "", 0, PKI_KEYGEN_INDICATE)
    Debug.Print "RSA_MakeKeys returns " & nRet & " (expected 0)"
    If nRet <> 0 Then
        Debug.Print "ERROR: "; nRet & " " & pkiErrorLookup(nRet)
        ghs_Make_Your_Keys = False
    Else
        Debug.Print "Created key files '" & strPublicKeyFile & "' and '" & strPrivateKeyFile & "'"
        ghs_Make_Your_Keys = True
    End If
End Function

' Step 2.
' Create a certificate request file (CRS) to be sent to the CA

Public Sub ghs_Make_Certificate_Request()
' INPUT:  RSA private key file of user, required Distinguished Name (DN), password for private key.
' OUTPUT: Certificate request file (CRS) in binary form to be sent to CA.

    Dim strCrsFile As String
    Dim strPrivateKeyFile As String
    Dim strDN As String
    Dim strPassword As String
    Dim nRet As Long
    
    strDN = "C=DE;O=ISTG Beispiel Vertrauen Mitte;OU=Unsere Firma;OU=IK999009991;CN=Erika Mustermann"
    strPrivateKeyFile = TESTPATH & YOUR_PKID & "a_pri.p8"
    strPassword = "password"
    strCrsFile = TESTPATH & YOUR_PKID & "a.p10"
    
    nRet = X509_CertRequest(strCrsFile, strPrivateKeyFile, strDN, "", strPassword, PKI_X509_FORMAT_BIN _
        + PKI_SIG_SHA256RSA)    ' CHANGED 2014-08-03 TO SHA256 FROM SHA1
    If nRet <> 0 Then
        Debug.Print "ERROR: " & nRet & " " & pkiGetLastError()
    Else
        Debug.Print "Created '" & strCrsFile & "'"
    End If

End Sub

' Step 3.
' Generate the SHA-1 checksum of your public key.
' You will need to put this in a text file,
' and possibly add spaces after each second character.
' (formerly used MD5 before 2014)

Public Sub ghs_Make_Key_CheckSum()
' INPUT:  Binary public key (.p1) file
' OUTPUT: SHA-1 hash digest of the public key in hex format (40 characters long)
    Dim strDigest As String
    Dim nRet As Long
    Dim strPublicKeyFile As String
    
    strPublicKeyFile = TESTPATH & YOUR_PKID & "a_pub.p1"
    ' CHANGED 2014-08-03 TO SHA1 FROM MD5
    strDigest = String(PKI_SHA1_CHARS, " ")
    nRet = HASH_HexFromFile(strDigest, Len(strDigest), strPublicKeyFile, PKI_HASH_SHA1)
    Debug.Print "SHA1(PublicKey)=" & strDigest
    
End Sub

' Step 4.
' a. Send the .p10 file to your CA together with the checksum hash for your public key (plus the fee)
'    NOTE: You keep your private key (.p8) and password somewhere safe. You now no longer need the .p1 file.

' ...(wait for reply)...

' b. Your CA sends you a .p7c file. This contains your new X.509 with the same public key you made before.
'    It also contains the CA's root certificate and an intermediate CA's certificate used to sign your certificate.
'    This is a p7c certificate chain file. You should be able to open it in Windows by double-clicking it.
'    For our purposes, we need to extract our own X.509 certificate and verify that it is valid.

' Step 5.
' Extract your X.509 certificate from the .p7c file

Public Sub ghs_Split_p7c_file()
' Extracts all X.509 certificates from a PKCS#7 certificate list file
' INPUT:  Name of pkcs7 certificate list file containing sender's X.509 certificate and certificates of all issuers.
' OUTPUT: Set of X.509 certificate files: TheCert1, TheCert2, TheCert3, etc.
    Dim nRet As Long
    Dim strListFile As String
    Dim strCertFile As String
    Dim iCert As Long
    Dim nCerts As Long
    
    strListFile = TESTPATH & YOUR_PKID & "a.p7c"
    ' How many certificates?
    nCerts = X509_GetCertFromP7Chain("", strListFile, 0, 0)
    Debug.Print "X509_GetCertFromP7Chain(0) returns " & nCerts & " for " & strListFile
    ' Enumerate through them all
    If nCerts > 0 Then
        For iCert = 1 To nCerts
            strCertFile = TESTPATH & "TheCert" & iCert & ".cer"
            nRet = X509_GetCertFromP7Chain(strCertFile, strListFile, iCert, 0)
            Debug.Print "X509_GetCertFromP7Chain(" & iCert & ") returns " _
                & nRet & "->" & strCertFile
        Next
    End If
    
' But we don't know which one is ours...so see the next procedure
' (it's most likely that the first one is yours, but we'll check anyway)
End Sub

' Step 5a.
' Find our own X.509 certificate in the .p7c file.
' We do this by using our own private key and comparing it in turn to the public key in each certificate we find.
' If we find a match, we have found our corresponding X.509 certificate.

Public Sub ghs_Check_CertList_With_PrivateKey()
' INPUT:  p7c certificate list file, pkcs-8 encrypted private key file, password.
' OUTPUT: Found (cert-i, private key) match OK => name of sender's X.509 certificate; or failure.
'         The matching cert file is then copied to a new file.
    Dim nRet As Long
    Dim strListFile As String
    Dim strCertFile As String
    Dim iCert As Long
    Dim nCerts As Long
    Dim strPriKeyFile As String
    Dim strPrivateKey As String
    Dim strPublicKey As String
    Dim strPassword As String
    Dim nLen As Long
    Dim strMatchingCert As String
    Dim strNewCertFile As String
    
    strListFile = TESTPATH & YOUR_PKID & "a.p7c"
    strPriKeyFile = TESTPATH & YOUR_PKID & "a_pri.p8"
    strNewCertFile = TESTPATH & YOUR_PKID & "a.cer"
    strPassword = "password"
    
    ' 1. Extract X.509 certificates from P7 cert list...
    ' How many certificates?
    nCerts = X509_GetCertFromP7Chain("", strListFile, 0, 0)
    Debug.Print "X509_GetCertFromP7Chain(0) returns " & nCerts & " for " & strListFile
    ' Enumerate through them all
    If nCerts > 0 Then
        For iCert = 1 To nCerts
            strCertFile = TESTPATH & "TheCert" & iCert & ".cer"
            nRet = X509_GetCertFromP7Chain(strCertFile, strListFile, iCert, 0)
            Debug.Print "X509_GetCertFromP7Chain(" & iCert & ") returns " _
                & nRet & "->" & strCertFile
        Next
    Else
        MsgBox "No certificates extracted from '" & strListFile & "'."
        Exit Sub
    End If
    
    ' 2. Read in private key from encrypted file...
    strPrivateKey = rsaReadPrivateKey(strPriKeyFile, strPassword)
    If Len(strPrivateKey) = 0 Then
        MsgBox "Cannot read private key", vbCritical
        Exit Sub
    End If
    ' clean up as we go
    Call WIPE_String(strPassword, Len(strPassword))
    Debug.Print "Private key is " & RSA_KeyBits(strPrivateKey) & " bits"
    Debug.Print "Private key HashCode = " & Hex(RSA_KeyHashCode(strPrivateKey))
    
    ' 3. Test each certificate in the list against the private key...
    nLen = RSA_KeyBytes(strPrivateKey)
    Debug.Print "Key length is " & nLen & " bytes (" & RSA_KeyBits(strPrivateKey) & " bits)."
    
    strMatchingCert = ""
    For iCert = 1 To nCerts
        Debug.Print "i=" & iCert
        strCertFile = TESTPATH & "TheCert" & iCert & ".cer"
        Debug.Print "For certificate " & strCertFile & "..."
        ' Read in the public key from the certificate
        strPublicKey = rsaGetPublicKeyFromCert(strCertFile)
        If Len(strPublicKey) = 0 Then
            MsgBox "Cannot read public key from cert '" & strCertFile & "'.", vbCritical
            Exit Sub
        End If
        ' Only test if the key lengths match
        Debug.Print "This public key is " & RSA_KeyBits(strPublicKey) & " bits long"
        Debug.Print "Public key HashCode = " & Hex(RSA_KeyHashCode(strPublicKey))
        If RSA_KeyBytes(strPublicKey) = nLen Then
            nRet = RSA_KeyMatch(strPrivateKey, strPublicKey)
            If nRet = 0 Then
                Debug.Print "  FOUND MATCH: private key in '" & strPriKeyFile & "' matches public key in '" & strCertFile & "'"
                ' We are done, so (we could) break loop
                '''Exit For
                strMatchingCert = strCertFile
            Else
                Debug.Print "  Private and public keys do not match."
            End If
        Else
            Debug.Print "  Private and public keys are different lengths."
        End If
    Next
            
    Debug.Print "Compared all public keys."
    If Len(strMatchingCert) > 0 Then
        Debug.Print "Found a match for '" & strMatchingCert & "'"
        FileCopy strMatchingCert, strNewCertFile
        Debug.Print "Copied matching cert to '" & strNewCertFile & "'"
    Else
        Debug.Print "Did not find a match for the private key."
    End If
    
    ' Clean up
    Call WIPE_String(strPrivateKey, Len(strPrivateKey))

End Sub

' Step 5b. Verify your certificate against the issuer's certificate
' Now we have our certificate and all its issuers' certificates in separate files,
' we can verify that they are all valid and that they really were validly issued.
Public Function ghs_TestTheCerts() As Boolean
    Dim nRet As Long
    Dim strCertName As String
    Dim strIssuerCert As String
    Dim strThumbPrint As String
    
    ' Chain: [TheCert1.cer] issued by [TheCert2.cer] issued by [TheCert3.cer] self-issued by [TheCert3.cer].
    ' Assumes we trust the CA's certificate and all certificates issued by it.
    ' Does not deal with certificate revokation (CRL) issues.
    
    ' You will need to alter this. This is the SHA-1 "thumbprint" for our test root certificate...
    Const HARD_CODED_THUMBPRINT As String = "3867c2c9072362fa2565365b1e82b639a42f8220"
    
    ' 1. Is your certificate currently valid?
    strCertName = TESTPATH & "TheCert" & 1 & ".cer"
    nRet = X509_CertIsValidNow(strCertName, 0)
    If nRet > 0 Then
        Debug.Print "Error: " & nRet & " " & pkiGetLastError()
    ElseIf nRet < 0 Then
        MsgBox "Validation error: cert '" & strCertName & "' is no longer valid at this time.", vbCritical
        Exit Function
    Else
        Debug.Print "Cert '" & strCertName & "' is currently valid."
    End If
    
    ' 2. Was your certificate issued by TheCert2?
    strIssuerCert = TESTPATH & "TheCert" & 2 & ".cer"
    nRet = X509_VerifyCert(strCertName, strIssuerCert, 0)
    If nRet > 0 Then
        Debug.Print "Error: " & nRet & " " & pkiGetLastError()
    ElseIf nRet < 0 Then
        MsgBox "Validation error: cert '" & strCertName & "' was not issued by '" & strIssuerCert & "'.", vbCritical
        Exit Function
    Else
        Debug.Print "Verified that cert '" & strCertName & "' was issued by '" & strIssuerCert & "'."
    End If
    
    ' Continuing up the chain...
    ' 3. Is the issuer's certificate currently valid?
    strCertName = strIssuerCert
    nRet = X509_CertIsValidNow(strCertName, 0)
    If nRet > 0 Then
        Debug.Print "Error: " & nRet & " " & pkiGetLastError()
    ElseIf nRet < 0 Then
        MsgBox "Validation error: cert '" & strCertName & "' is no longer valid at this time.", vbCritical
        Exit Function
    Else
        Debug.Print "Cert '" & strCertName & "' is currently valid."
    End If
    
    ' 4. Was the issuer's certificate issued by the root certificate?
    strIssuerCert = TESTPATH & "TheCert" & 3 & ".cer"
    nRet = X509_VerifyCert(strCertName, strIssuerCert, 0)
    If nRet > 0 Then
        Debug.Print "Error: " & nRet & " " & pkiGetLastError()
    ElseIf nRet < 0 Then
        MsgBox "Validation error: cert '" & strCertName & "' was not issued by '" & strIssuerCert & "'.", vbCritical
        Exit Function
    Else
        Debug.Print "Verified that cert '" & strCertName & "' was issued by '" & strIssuerCert & "'."
    End If
    
    ' At the top of the chain we have a self-signed certificate...
    ' 5. Is the root certificate currently valid?
    strCertName = strIssuerCert
    nRet = X509_CertIsValidNow(strCertName, 0)
    If nRet > 0 Then
        Debug.Print "Error: " & nRet & " " & pkiGetLastError()
    ElseIf nRet < 0 Then
        MsgBox "Validation error: cert '" & strCertName & "' is no longer valid at this time.", vbCritical
        Exit Function
    Else
        Debug.Print "Cert '" & strCertName & "' is currently valid."
    End If
    
    ' 6. Was the root certificate issued by itself?
    nRet = X509_VerifyCert(strCertName, strIssuerCert, 0)
    If nRet > 0 Then
        Debug.Print "Error: " & nRet & " " & pkiGetLastError()
    ElseIf nRet < 0 Then
        MsgBox "Validation error: cert '" & strCertName & "' was not issued by '" & strIssuerCert & "'.", vbCritical
        Exit Function
    Else
        Debug.Print "Verified that cert '" & strCertName & "' was issued by '" & strIssuerCert & "'."
    End If
    
    ' Finally, we can hard-code the "thumbprint" (hash digest) of the ultimate CA's certificate
    ' and check that it matches what we have in hand
    ' (you can get this value using CERTMGR.EXE).
    
    ' 7. Is the root certificate the one we expected?
    strThumbPrint = String(PKI_SHA1_CHARS, " ")
    nRet = X509_CertThumb(strCertName, strThumbPrint, Len(strThumbPrint), PKI_HASH_SHA1)
    Debug.Print "ThumbPrint(SHA-1, '" & strCertName & "')=" & strThumbPrint
    If LCase(strThumbPrint) = LCase(HARD_CODED_THUMBPRINT) Then
        Debug.Print "CA cert's thumbprint matches what we expect."
    Else
        MsgBox "Validation error: cert '" & strCertName & "' does not have the thumbprint we expect.", vbCritical
        Exit Function
    End If
    
    ' If we got to here, we have validated the entire chain
    Debug.Print "OK, certificate chain has been validated."
    
    ' RETURN SUCCESS
    ghs_TestTheCerts = True
    
End Function

' Step 5c. A quicker way of validating the p7c certificate chain
Public Function ghs_ChainIsValid() As Boolean
    Dim strP7cFile As String
    Dim strTrustedCert As String
    Dim nRet As Long
    
    strP7cFile = TESTPATH & "999009991a.p7c"
    strTrustedCert = TESTPATH & "CA_Cert.cer"
    nRet = X509_ValidatePath(strP7cFile, strTrustedCert, 0)
    Debug.Print "X509_ValidatePath returns " & nRet & " (expected 0)"
    
    ' RETURN SUCCESS OR FAILURE
    ghs_ChainIsValid = (nRet = 0)
End Function