Attribute VB_Name = "GermanHealthExamples"
Option Explicit

' $Id: GermanHealthExamples.bas $
' Examples using CryptoSys PKI to create and read signed-and-enveloped PKCS7 (CMS) objects suitable for
' the Security interface for data exchange in the health service version 3.0 (as far as we know).
'   Last Updated:
'   $Date: 2014-09-05 17:19: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\"


'********************
' GENERIC FUNCTIONS *
' *******************
Public Function ghs_Make_Signed_And_EnvelopedData( _
    strOutputFile As String, _
    strMsg As String, _
    strPriKeyFile As String, _
    strPassword As String, _
    strSignersCertList As String, _
    strRecipCertFile As String, _
    Optional fKeepInterFile As Boolean _
) As Long

    Dim nRet As Long
    Dim strPrivateKey As String
    Dim strSigFile As String
    
    ' Intermediate signed-data file we will create
    strSigFile = strOutputFile & ".int.tmp"
    
    ' Read in the private key string
    Debug.Print "Reading private key from PRI file..."
    strPrivateKey = rsaReadPrivateKey(strPriKeyFile, strPassword)
    ' Check for success
    If Len(strPrivateKey) = 0 Then
        MsgBox "Cannot read private key", vbCritical
        Exit Function
    Else
        Debug.Print "...OK, read private key: key length=" & RSA_KeyBits(strPrivateKey) & " bits"
    End If
    
    ' Create a signed-data object with signed attributes and signing-time and all certificates.
    nRet = CMS_MakeSigDataFromString(strSigFile, strMsg, strSignersCertList, _
        strPrivateKey, PKI_CMS_INCLUDE_ATTRS + PKI_CMS_ADD_SIGNTIME _
        + PKI_HASH_SHA256)  ' ADDED 2014-08-03
    Debug.Print "CMS_MakeSigDataFromString returns " & nRet & " (expecting 0)"
    ' Clean up as we go
    Call WIPE_String(strPrivateKey, Len(strPrivateKey))
    ' Check for success
    If nRet <> 0 Then
        Debug.Print "ERROR (" & nRet & "): " & pkiErrorLookup(nRet) & ": " & pkiGetLastError()
        MsgBox "Cannot create signed-data file", vbCritical
        Exit Function
    Else
        Debug.Print "OK, created signed-data file '" & strSigFile & "'"
    End If
    
    ' Now we encrypt the signed-data object directly using the recipient's certificate
    ' this produces a binary enveloped-data file
    nRet = CMS_MakeEnvData(strOutputFile, strSigFile, strRecipCertFile, "", 0, 0)
    Debug.Print "CMS_MakeEnvData returns " & nRet & " (expecting 1)"
    If nRet <= 0 Then
        Debug.Print "ERROR (" & nRet & "): " & pkiErrorLookup(nRet) & ": " & pkiGetLastError()
        MsgBox "Cannot create enveloped-data file", vbCritical
        Exit Function
    Else
        Debug.Print "OK, created enveloped-data file '" & strOutputFile & "'"
    End If
    
    ' Clean up sensitive data
    If Not fKeepInterFile Then
        Call WIPE_File(strSigFile, 0)
    End If
    
    ' Now send the output file to the recipient...
    
End Function

Public Function ghs_Read_Signed_and_Enveloped_Data( _
    strInputFile As String, _
    strPriKeyFile As String, _
    strPassword As String, _
    Optional strCertFile As String, _
    Optional fKeepInterFile As Boolean _
) As String
' Returns string containing output message or an empty string on error
    Dim nRet As Long
    Dim strPrivateKey As String
    Dim strSigFile As String
    Dim strOutput As String
    Dim strQuery As String
       
    ' Read in the recipient's private key
    strPrivateKey = rsaReadPrivateKey(strPriKeyFile, strPassword)
    If Len(strPrivateKey) = 0 Then
        Debug.Print "ERROR:  " & pkiGetLastError()
        MsgBox "Cannot read private key", vbCritical
        Exit Function
    End If
    
    ' Intermediate file we will create
    strSigFile = strInputFile & ".i2.tmp"
    
    ' Read the encrypted data from the enveloped-data file
    nRet = CMS_ReadEnvData(strSigFile, strInputFile, "", strPrivateKey, 0)
    Debug.Print "CMS_ReadEnvData returns " & nRet & " (expected 0)"
    If nRet <> 0 Then
        Debug.Print "ERROR (" & nRet & "): " & pkiErrorLookup(nRet) & ": " & pkiGetLastError()
    Else
        Debug.Print "Extracted signed-data file '" & strSigFile & "'"
    End If
    
    ' Pre-dimension output string for query result
    strOutput = String(64, " ")
    
    Debug.Print "For SigData file '" & strSigFile & "'..."
    nRet = CMS_QuerySigData(strOutput, Len(strOutput), strSigFile, "version", 0)
    Debug.Print "Version=" & nRet
    nRet = CMS_QuerySigData(strOutput, Len(strOutput), strSigFile, "signingTime", 0)
    If nRet > 0 Then
        Debug.Print "signingTime=" & Left$(strOutput, nRet)
    Else
        Debug.Print "ERROR=" & nRet
    End If
    strQuery = "messageDigest"
    nRet = CMS_QuerySigData(strOutput, Len(strOutput), strSigFile, strQuery, 0)
    If nRet > 0 Then
        Debug.Print strQuery & "=" & Left$(strOutput, nRet)
    Else
        Debug.Print "ERROR=" & nRet
    End If
    
    strQuery = "CountOfSignerInfos"
    nRet = CMS_QuerySigData(strOutput, Len(strOutput), strSigFile, strQuery, 0)
    If nRet > 0 Then
        Debug.Print strQuery & "=" & nRet
    Else
        Debug.Print "ERROR=" & nRet
    End If
    
    strQuery = "CountOfCertificates"
    nRet = CMS_QuerySigData(strOutput, Len(strOutput), strSigFile, strQuery, 0)
    If nRet > 0 Then
        Debug.Print strQuery & "=" & nRet
    Else
        Debug.Print "ERROR=" & nRet
    End If
    
    nRet = CMS_VerifySigData(strSigFile, "", "", 0)
    Debug.Print "CMS_VerifySigData('') returns " & nRet & " (expecting 0)"

    nRet = CMS_VerifySigData(strSigFile, strCertFile, "", 0)
    Debug.Print "CMS_VerifySigData('" & strCertFile & "') returns " & nRet & " (expecting 0)"

    Dim nDataLen As Long
    Dim strData As String
    ' How long is the content to be read?
    nDataLen = CMS_ReadSigDataToString("", 0, strSigFile, 0)
    If nDataLen <= 0 Then
        Debug.Print "ERROR (" & nRet & "): " & pkiErrorLookup(nRet) & ": " & pkiGetLastError()
        MsgBox "Cannot read signed-data file", vbCritical
        Exit Function
    End If
    ' Pre-dimension string to receive data
    strData = String(nDataLen, " ")
    nRet = CMS_ReadSigDataToString(strData, nDataLen, strSigFile, 0)
    Debug.Print "CMS_ReadSigDataToString returns " & nRet
    Debug.Print "Data is [" & strData & "]"
    
    ' Return message string
    ghs_Read_Signed_and_Enveloped_Data = strData
    
    ' Clean up sensitive data
    If Not fKeepInterFile Then
        Call WIPE_File(strSigFile, 0)
    End If
    Call WIPE_String(strData, Len(strData))

End Function

' ***********************************
' TEST PROGRAMS FOR ABOVE FUNCTIONS *
' ***********************************
Public Sub ghs_Test_Make_Signed_And_EnvelopedData()
    Dim nRet As Long
    Dim strOutputFile As String
    Dim strMsg As String
    Dim strPriKeyFile As String
    Dim strPassword As String
    Dim strSignersCertList As String
    Dim strRecipCertFile As String
    
    ' The message we want to send
    strMsg = "Hallo Walt"
    ' Final enveloped-data file to send to recipient
    strOutputFile = TESTPATH & "To_999009051a.p7m"
    ' Our private key data
    strPriKeyFile = TESTPATH & "999009991a_pri.p8"
    strPassword = "password"    ' CAUTION: DO NOT HARDCODE YOUR PRODUCTION PASSWORD!
    ' Signer's certificate plus (optionally) the certs in the chain that signed it. Separated by a semi-colon ";".
    ' NOTE: the first cert in the list MUST be the signers
    ' -- it's up to you to work out which is which (see Check_CertList_With_PrivateKey() above)
    strSignersCertList = TESTPATH & "999009991a.cer" & ";" & TESTPATH & "TheCert2.cer" & ";" & TESTPATH & "TheCert3.cer"
    ' The certificate of the recipient -- this must be provided (otherwise we wouldn't know whom to send it to)
    strRecipCertFile = TESTPATH & "999009051a.cer"

    nRet = ghs_Make_Signed_And_EnvelopedData(strOutputFile, strMsg, strPriKeyFile, strPassword, strSignersCertList, strRecipCertFile, fKeepInterFile:=True)
    Debug.Print "ghs_Make_Signed_And_EnvelopedData returns " & nRet & " (expecting zero)"
    
    ' Clean up password string
    Call WIPE_String(strPassword, Len(strPassword))
End Sub

Public Sub ghs_Test_Read_Signed_and_Enveloped_Data()
' NOTE: We can only do this because we have the private key for the dummy user with id IK999009051.
' To test yourself, send a test message to yourself signed by yourself.
    Dim strMsg As String
    Dim strInputFile As String
    Dim strPriKeyFile As String
    Dim strPassword As String
    Dim strCertFile As String
    
    ' Input data file
    strInputFile = TESTPATH & "To_999009051a.p7m"
    ' Recipient's private key data
    strPriKeyFile = TESTPATH & "999009051a_pri.p8"
    strPassword = "password"    ' CAUTION: DO NOT HARDCODE YOUR PRODUCTION PASSWORD!
    ' The certificate of the sender -- optional
    strCertFile = ""
    
    strMsg = ghs_Read_Signed_and_Enveloped_Data(strInputFile, strPriKeyFile, strPassword)
    Debug.Print "ghs_Read_Signed_and_Enveloped_Data returns '" & strMsg & "'"
    
    ' Clean up password string
    Call WIPE_String(strPassword, Len(strPassword))
End Sub

' *****************
' OTHER UTILITIES
' *****************
Public Sub ghs_DoExtractCerts()
' Extract and examine all the certificates from the input file...
    Dim nCerts As Integer
    Dim strFileName As String
    Dim strOutDir As String
    
    strFileName = TESTPATH & "annahme-test-certs-2014.txt"
    strOutDir = TESTPATH & "TestCerts"
    ' If dir does not exist, create it
    If Len(Dir(strOutDir, vbDirectory)) = 0 Then
        MkDir strOutDir
    End If
    
    nCerts = ghs_ExtractCertsFromB64File(strFileName, strOutDir)
    Debug.Print nCerts & " X.509 certificates found"
End Sub

Private Function ghs_ExtractCertsFromB64File(strFileIn As String, ByVal strOutPath As String) As Integer
' Given a text file consisting of base64-encoded X.509 certificates separated by a blank line
' extract all the certificates [cert01.cer, cert02.cer, ..., certN.cer] and return N on success
' or 0 if no certs found, or -1 if file error.

    Dim hFile As Integer
    Dim strLine As String
    Dim strData As String
    Dim iCert As Integer
    Dim strCertName As String
    Dim nRet As Long
    
    ' Make sure strOutpath has a trailing backslash, unless blank
    strOutPath = Trim(strOutPath)
    If Len(strOutPath) > 0 And Right$(strOutPath, 1) <> "\" Then
        strOutPath = strOutPath & "\"
    End If
    
    ' Make sure file exists
    If Len(Dir(strFileIn)) = 0 Then
        MsgBox "Cannot find file '" & strFileIn & "'", vbCritical
        ghs_ExtractCertsFromB64File = -1
        Exit Function
    End If
    
    hFile = FreeFile
    Open strFileIn For Input As #hFile
    If LOF(hFile) = 0 Then
        MsgBox "File is empty", vbExclamation
        Close #hFile
        Exit Function
    End If
    
    ' Read in the data file line-by-line until find a blank line or EOF
    iCert = 0
    strData = ""
    Do Until EOF(hFile)
        Line Input #hFile, strLine
        If Len(Trim(strLine)) = 0 Then
            ' We have blank line, so save what we have so far as an X.509 cert
            iCert = iCert + 1
            strCertName = strOutPath & "cert" & Format(iCert, "00") & ".cer"
            ''Debug.Print strData
            
            ' Save from base64 string to a DER-encoded X.509 certificate file
            nRet = X509_SaveFileFromString(strCertName, strData, 0)
            Debug.Print "X509_SaveFileFromString returns " & nRet & " (expecting 0)"
            If nRet = 0 Then
                Debug.Print "Saved X.509 certificate file '" & strCertName & "'"
            Else
                Debug.Print "ERROR (" & nRet & ") saving cert file: " & pkiErrorLookup(nRet)
            End If
            
            ' NOTE: we can actually use the X509_CertSerialNumber, X509_QueryCert, etc. functions
            ' to query directly the base64 string itself instead of the file.
            Call ghs_ShowCertDetailsFromString(strData)
            
            strData = ""
        Else
            ' Just append the line to existing base64 data
            strData = strData & strLine
        End If
    Loop
    ' Catch final cert, if any
    If Len(strData) > 0 Then
        iCert = iCert + 1
        strCertName = strOutPath & "cert" & Format(iCert, "00")
        Debug.Print strData
        strData = ""
    End If
    Close #hFile
    
    ' Return number of X.509 cert files created
    ghs_ExtractCertsFromB64File = iCert

End Function

Public Function ghs_ShowCertDetailsFromString(strData As String)
' NOTE: We can replace the strCertFile parameter with a string containing the cert as a base64 string
    Dim strOutput As String
    Dim strQuery As String
    Dim nRet As Long
    
    ' Make a large buffer to receive output
    strOutput = String(1024, " ")
    
    strQuery = "serialNumber"
    nRet = X509_QueryCert(strOutput, Len(strOutput), strData, strQuery, 0)
    If nRet <= 0 Then Exit Function ' catch error
    Debug.Print strQuery & "=" & Left(strOutput, nRet)

    strQuery = "subjectName"
    nRet = X509_QueryCert(strOutput, Len(strOutput), strData, strQuery, 0)
    If nRet <= 0 Then Exit Function ' catch error
    Debug.Print strQuery & ": " & Left(strOutput, nRet)
End Function