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