Attribute VB_Name = "GermanHealthExamples2018"
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 [2018].
' Last Updated:
' $Date: 2018-04-29 17:31:00 $
' $Revision: 1.3.0 $
' ******************************************************************************
' Copyright (c) 2007-25 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 ghs2018_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_SIG_RSA_PSS_SHA256) ' NEW IN 2018
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, _
PKI_KT_RSAES_OAEP + PKI_HASH_SHA256 + PKI_BC_AES256) ' NEW IN 2018
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 ghs2018_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
ghs2018_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 ghs2018_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_999009051b.p7m"
' Our private key data with 4096-bit key
strPriKeyFile = TESTPATH & "999009991b_pri.p8e"
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
strSignersCertList = TESTPATH & "999009991b.cer" & ";" & TESTPATH & "Int_4096_Cert.cer" & ";" & TESTPATH & "CA_4096_Cert.cer"
' The certificate of the recipient -- this must be provided (otherwise we wouldn't know whom to send it to)
strRecipCertFile = TESTPATH & "999009051b.cer"
nRet = ghs2018_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 ghs2018_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_999009051b.p7m"
' Recipient's private key data (4096 bits)
strPriKeyFile = TESTPATH & "999009051b_pri.p8e"
strPassword = "password" ' CAUTION: DO NOT HARDCODE YOUR PRODUCTION PASSWORD!
' The certificate of the sender -- optional
strCertFile = ""
strMsg = ghs2018_Read_Signed_and_Enveloped_Data(strInputFile, strPriKeyFile, strPassword)
Debug.Print "ghs2018_Read_Signed_and_Enveloped_Data returns '" & strMsg & "'"
' Clean up password string
Call WIPE_String(strPassword, Len(strPassword))
End Sub