Attribute VB_Name = "GermanHealthCertsMake"
Option Explicit

' $Id: GermanHealthCertsMake.bas $

' Make some dummy X.509 certificates similar to German Health examples.
' Generate some RSA key pairs, use these to create some X.509 certificates.
' Also create a certficate from a CSR (p10) file, create a p7c chain file, and a text file
' containing all the certificates in base64 format.

'   Last Updated:
'   $Date: 2014-09-05 16:41: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\"

' 1. Make a dummy RSA key pair for each participant
'    NB Only do this once for each participant

Public Function ghs_MakeDummyKeys()
' Call each of these only once
    'ghs_MakeAKeyPair "CA"
    'ghs_MakeAKeyPair "Int"
    'ghs_MakeAKeyPair "999009011a"
    'ghs_MakeAKeyPair "999009021a"
    'ghs_MakeAKeyPair "999009031a"
    'ghs_MakeAKeyPair "999009041a"
    'ghs_MakeAKeyPair "999009051a"
    ghs_MakeAKeyPair "999009991a"
  
End Function

''
' Make an RSA key pair
Private Sub ghs_MakeAKeyPair(strStemName As String)
    Dim strPriKeyFile As String, strPubKeyFile As String
    Dim nRet As Long
    strPriKeyFile = TESTPATH & strStemName & "_pri.p8"
    strPubKeyFile = TESTPATH & strStemName & "_pub.p1"
    
    Debug.Print "About to make keys: " & strPriKeyFile & "/" & strPubKeyFile
    nRet = RSA_MakeKeys(strPubKeyFile, strPriKeyFile, 2048, PKI_RSAEXP_EQ_65537, 64, 2000, "password", _
        "", 0, PKI_PBE_PBES2 + PKI_BC_AES256 + PKI_KEYGEN_INDICATE)
    Debug.Print "RSA_MakeKeys returns " & nRet & " (expecting zero)"
     
End Sub

' 2. Make a self-signed certificate for the CA, serial number 02, signed using sha256RSA
Public Function ghs_Make_SelfSignedCert()
    Dim nRet As Long
    Dim strCertName As String
    Dim strDistName As String
    Dim nCertNum As Long
   
    strCertName = TESTPATH & "CA_Cert.cer"
    strDistName = "C=DE;O=Datenaustausch-Beispielbescheinigungberechtigung"
    nCertNum = 2
  
    nRet = X509_MakeCertSelf(strCertName, TESTPATH & "CA_pri.p8", nCertNum, 12, strDistName, "", _
        PKI_X509_KEYUSAGE_KEYCERTSIGN + PKI_X509_KEYUSAGE_CRLSIGN, _
        "password", PKI_SIG_SHA256RSA)
    Debug.Print "X509_MakeCertSelf returns " & nRet & " (expecting zero)"
   
End Function

' 3. Make intermediate signing certificate, serial number 11, signed using sha256RSA
'    NOTE: Use of PKI_X509_NO_BASIC flag for intermediate signing cert
Public Function ghs_Make_IntCert()
    Dim nRet As Long
    Dim strCertName As String
    Dim strDistName As String
    Dim strIssuerCert As String
    Dim strIssuerKey As String
    Dim strPubKeyFile As String
    Dim nCertNum As Long
    
    strIssuerCert = TESTPATH & "CA_Cert.cer"
    strIssuerKey = TESTPATH & "CA_pri.p8"
    strCertName = TESTPATH & "Int_Cert.cer"
    strPubKeyFile = TESTPATH & "Int_pub.p1"
    strDistName = "C=DE;O=ISTG Beispiel Vertrauen Mitte Nicht"
    nCertNum = 11 ' decimal = 0x0b
  
    nRet = X509_MakeCert(strCertName, strIssuerCert, strPubKeyFile, strIssuerKey, nCertNum, 10, strDistName, "", _
        PKI_X509_KEYUSAGE_KEYCERTSIGN + PKI_X509_KEYUSAGE_CRLSIGN, _
        "password", PKI_SIG_SHA256RSA + PKI_X509_NO_BASIC)
    Debug.Print "X509_MakeCert returns " & nRet & " (expecting zero)"
   
End Function

' 4. Make dummy end-user certificates, signed using sha256RSA
'    Signed by intermediate CA, valid for 7 years, no key usage flags
Public Function ghs_Make_EndUserCert_9011()
    Dim nRet As Long
    Dim strCertName As String
    Dim strDistName As String
    Dim strIssuerCert As String
    Dim strIssuerKey As String
    Dim strPubKeyFile As String
    Dim nCertNum As Long
    
    strIssuerCert = TESTPATH & "Int_Cert.cer"
    strIssuerKey = TESTPATH & "Int_pri.p8"
    strCertName = TESTPATH & "999009011a.cer"
    strPubKeyFile = TESTPATH & "999009011a_pub.p1"
    strDistName = "C=DE;O=ISTG Beispiel Vertrauen Mitte;OU=Schwarz GmbH;OU=IK999009011;CN=Franziska Fischer"
    nCertNum = &H1901
  
    nRet = X509_MakeCert(strCertName, strIssuerCert, strPubKeyFile, strIssuerKey, nCertNum, 7, strDistName, "", _
        0, "password", PKI_SIG_SHA256RSA)
    Debug.Print "X509_MakeCert returns " & nRet & " (expecting zero)"
   
End Function

' 4a. Create more end-user certs in a loop using VB6 variant arrays

Public Sub ghs_MakeCertSet()
    Dim astrIKNums As Variant
    Dim astrDistNames As Variant
    Dim nCertNum As Long
    Dim nBaseNum As Long
    Dim i As Integer
    Dim strDistName As String
    Dim strIKNum As String
    
    astrIKNums = Array("999009021", "999009031", "999009041", "999009051")
    astrDistNames = Array("C=DE;O=ISTG Beispiel Vertrauen Mitte;OU=Grau GmbH;OU=IK999009021;CN=Friedhelm Heinz", _
        "C=DE;O=ISTG Beispiel Vertrauen Mitte;OU=Silber GmbH;OU=IK999009031;CN=Katja Meyer", _
        "C=DE;O=ISTG Beispiel Vertrauen Mitte;OU=Beige GmbH;OU=IK999009041;CN=Liesel Walter", _
        "C=DE;O=ISTG Beispiel Vertrauen Mitte;OU=Weiss GmbH;OU=IK999009051;CN=Ingrid Kruger")
    
    nBaseNum = &H1902
    For i = 0 To UBound(astrIKNums)
        nCertNum = nBaseNum + i
        Debug.Print astrIKNums(i), Hex(nCertNum)
        strDistName = astrDistNames(i)
        strIKNum = astrIKNums(i)
        ' Do the business...
        Call ghs_MakeEndUserCert(strDistName, strIKNum, nCertNum)
    Next
    
End Sub
 
''
' Make an end-user X.509 certificate with given distinguished name
Public Function ghs_MakeEndUserCert(strDistName As String, strIKNum As String, nCertNum As Long)
    Dim nRet As Long
    Dim strCertName As String
    Dim strIssuerCert As String
    Dim strIssuerKey As String
    Dim strPubKeyFile As String
    
    strIssuerCert = TESTPATH & "Int_Cert.cer"
    strIssuerKey = TESTPATH & "Int_pri.p8"
    strCertName = TESTPATH & strIKNum & "a.cer"
    strPubKeyFile = TESTPATH & strIKNum & "a_pub.p1"
  
    nRet = X509_MakeCert(strCertName, strIssuerCert, strPubKeyFile, strIssuerKey, nCertNum, 7, strDistName, "", _
        0, "password", PKI_SIG_SHA256RSA)
    Debug.Print "X509_MakeCert returns " & nRet & " (expecting zero)"
   
End Function

' 5. Make a cert from the Certificate Sending Request (p10) file created by Erika Mustermann
'    An example of using a CSR (p10) file instead of public key file. Note DistName set to "".

Public Function ghs_Make_CertFromRequest()
    Dim nRet As Long
    Dim strCertName As String
    Dim strDistName As String
    Dim strIssuerCert As String
    Dim strIssuerKey As String
    Dim strCsrFile As String
    Dim nCertNum As Long
    
    strIssuerCert = TESTPATH & "Int_Cert.cer"
    strIssuerKey = TESTPATH & "Int_pri.p8"
    strCertName = TESTPATH & "999009991a.cer"
    strCsrFile = TESTPATH & "999009991a.p10"
    strDistName = ""
    nCertNum = &H1999
  
    nRet = X509_MakeCert(strCertName, strIssuerCert, strCsrFile, strIssuerKey, nCertNum, 7, "", "", _
        0, "password", PKI_SIG_SHA256RSA)
    Debug.Print "X509_MakeCert returns " & nRet & " (expecting zero)"
   
End Function

' 6. Make a p7c "cert-only" signed-data chain file for Erika Musterman
'    Included certs: 1) end-user, 2) intermediate CA, 3) ultimate CA.

Public Function ghs_MakeP7Chain()
    Dim nRet As Long
    Dim strOutputFile As String
    Dim strCertList As String
    
    ' Make a list of certs separated by semi-colons (;)
    strCertList = TESTPATH & "999009991a.cer" & ";" & TESTPATH & "Int_Cert.cer" & ";" & TESTPATH & "CA_Cert.cer"
    Debug.Print "CertList=" & strCertList
    strOutputFile = TESTPATH & "999009991a.p7c"
    
    ' Create a certs-only .p7c chain
    nRet = CMS_MakeSigData(strOutputFile, "", strCertList, "", PKI_CMS_CERTS_ONLY)
    Debug.Print "CMS_MakeSigData returns " & nRet
    If nRet <> 0 Then Debug.Print pkiGetLastError()
    
End Function

' 7. Create a text file containing all user certs in base64 format

Public Function ghs_CreateCertsBase64File()
    Dim astrCertNames As Variant
    Dim strCertName As String
    Dim strBase64 As String
    Dim nChars As Long
    Dim i As Integer
    Dim strOutFileName As String
    Dim hFile As Integer
      
    strOutFileName = TESTPATH & "annahme-test-certs-2014.txt"
    
    ' Names of cert files we will process...
    astrCertNames = Array( _
        "999009011a.cer", _
        "999009021a.cer", _
        "999009031a.cer", _
        "999009041a.cer", _
        "999009051a.cer", _
        "999009991a.cer")
        
    ' Open a file for writing
    If Len(Dir(strOutFileName)) > 0 Then
        Kill strOutFileName
    End If
    hFile = FreeFile
    Open strOutFileName For Binary Access Write As #hFile
        
    ' For each X.509 cert file in the list, read in as a base64 string
    For i = 0 To UBound(astrCertNames)
        strCertName = TESTPATH & astrCertNames(i)
        Debug.Print strCertName
        ' a. Get required length
        nChars = X509_ReadStringFromFile("", 0, strCertName, 0)
        If nChars <= 0 Then
            Debug.Print "ERROR: " & nChars & ": " & pkiErrorLookup(nChars) & ": "; pkiGetLastError()
            Exit Function
        End If
        ' b. Allocate a string of required length
        strBase64 = String(nChars, " ")
        ' c. Read in cert data in base64 form
        nChars = X509_ReadStringFromFile(strBase64, Len(strBase64), strCertName, 0)
        
        ' Reformat continuous base64 string to max 64 char line length
        strBase64 = FoldStringToMax64LineLength(strBase64)
        
        ' Write to output file
        Put #hFile, , strBase64
    Next

    Close #hFile
    Debug.Print "Created text file '" & strOutFileName & "'"

End Function

''
' Reformat a string to add a newline (CR-LF) every 64 characters, plus an extra two at the end
' @remark Perhaps not necessarily the most efficient way to do this, but hey! it works for our purposes here
Function FoldStringToMax64LineLength(strInput As String)
    Const LINE_LEN As Long = 64
    Dim iPos As Long
    Dim nChars As Long
    Dim strOut As String
    Dim strRem As String
    
    nChars = Len(strInput)
    strRem = strInput
    strOut = ""
    
    Do While Len(strRem) > LINE_LEN
        strOut = strOut & Left$(strRem, LINE_LEN) & vbCrLf
        strRem = Mid$(strRem, LINE_LEN + 1)
    Loop
    If Len(strRem) > 0 Then
        strOut = strOut & strRem & vbCrLf
    End If
    ' One extra newline
    FoldStringToMax64LineLength = strOut & vbCrLf
End Function