ZUGFeRD: Send original message as attachment in error case

This commit is contained in:
Jonathan Jenne 2019-03-13 16:14:39 +01:00
parent e4ba39f19c
commit 76ff4a5daa
2 changed files with 31 additions and 11 deletions

View File

@ -1,11 +1,11 @@
Imports System.Collections.Generic
Imports System.IO
Imports System.Linq
Imports System.Text.RegularExpressions
Imports DigitalData.Modules.Database
Imports DigitalData.Modules.Interfaces
Imports DigitalData.Modules.Logging
Imports System.Text.RegularExpressions
Imports DigitalData.Modules.Jobs.Exceptions
Imports DigitalData.Modules.Logging
Imports FirebirdSql.Data.FirebirdClient
Public Class ImportZUGFeRDFiles
@ -54,7 +54,7 @@ Public Class ImportZUGFeRDFiles
Return oRandomValue
End Function
Private Function GetEmailAddressForFileGUID(FileGuid As String) As String
Private Function GetEmailAddressForMessageId(FileGuid As String) As String
Dim oSQL = $"SELECT EMAIL_FROM FROM TBEDM_EMAIL_PROFILER_HISTORY WHERE EMAIL_MSGID = '{FileGuid}'"
Try
Dim emailAddress = _firebird.GetScalarValue(oSQL)
@ -68,7 +68,7 @@ Public Class ImportZUGFeRDFiles
End Try
End Function
Private Function GetOriginalFileNameForFileGUID(FileGuid As String) As String
Private Function GetOriginalFileNameForMessageId(FileGuid As String) As String
Dim oSQL = $"SELECT EMAIL_ATTMT1 FROM TBEDM_EMAIL_PROFILER_HISTORY WHERE EMAIL_MSGID = '{FileGuid}'"
Try
Dim originalFilename = _firebird.GetScalarValue(oSQL)
@ -82,35 +82,52 @@ Public Class ImportZUGFeRDFiles
End Try
End Function
Private Sub AddToEmailQueue(FileGuid As String, BodyText As String)
Private Function GetOriginalEmailPath(MessageId As String)
Dim oAttachmentDirectory = ""
Dim oAttachmentFile = MessageId & ".eml"
Dim oAttachmentPath = Path.Combine(oAttachmentDirectory, oAttachmentFile)
If File.Exists(oAttachmentPath) Then
Return oAttachmentPath
Else
Return String.Empty
End If
End Function
Private Sub AddToEmailQueue(MessageId As String, BodyText As String)
Try
Dim oJobId = RandomValue(1, 10000)
Dim oReference = FileGuid
Dim oReference = MessageId
Dim oEmailTo = ""
Dim oSubject = "Your email was rejected"
Dim oAccountId = 1
Dim oCreatedWho = "ZUGFeRD Service"
Dim oEmailAddress = GetEmailAddressForFileGUID(FileGuid)
Dim oOriginalFilename = GetOriginalFileNameForFileGUID(FileGuid)
Dim oAttachment = ""
Dim oEmailAddress = GetEmailAddressForMessageId(MessageId)
Dim oOriginalFilename = GetOriginalFileNameForMessageId(MessageId)
If IsNothing(oEmailAddress) OrElse String.IsNullOrWhiteSpace(oEmailAddress) Then
_logger.Warn("Could not find email-address for MessageId {0}", MessageId)
oEmailTo = String.Empty
Else
oEmailTo = oEmailAddress
End If
oAttachment = GetOriginalEmailPath(MessageId)
_logger.Debug("Generated Email:")
_logger.Debug("To: {0}", oEmailTo)
_logger.Debug("Subject: {0}", oSubject)
_logger.Debug("Body {0}", BodyText)
Dim oSQLInsert = $"INSERT INTO TBEDM_EMAIL_QUEUE "
oSQLInsert &= "(JOB_ID, REFERENCE1, EMAIL_ACCOUNT_ID, EMAIL_TO, EMAIL_SUBJ, EMAIL_BODY, CREATEDWHO) VALUES "
oSQLInsert &= $"({oJobId}, '{oReference}', {oAccountId}, '{oEmailTo}', '{oSubject}', '{BodyText}', '{oCreatedWho}')"
oSQLInsert &= "(JOB_ID, REFERENCE1, EMAIL_ACCOUNT_ID, EMAIL_TO, EMAIL_SUBJ, EMAIL_BODY, CREATEDWHO, EMAIL_ATTMT1) VALUES "
oSQLInsert &= $"({oJobId}, '{oReference}', {oAccountId}, '{oEmailTo}', '{oSubject}', '{BodyText}', '{oCreatedWho}', '{oAttachment}')"
_firebird.ExecuteNonQuery(oSQLInsert)
_logger.Debug("Email Queue updated for MessageId {0}.", FileGuid, oEmailTo)
_logger.Debug("Email Queue updated for MessageId {0}.", MessageId, oEmailTo)
Catch ex As Exception
_logger.Error(ex)
End Try

View File

@ -60,6 +60,9 @@ Public Class ZUGFeRDInterface
oProcessOutput = oProcess.StandardOutput.ReadToEnd()
oProcessError = oProcess.StandardError.ReadToEnd()
oProcess.WaitForExit()
_logger.Debug("Process Output:")
_logger.Debug(oProcessOutput)
Catch ex As Exception
_logger.Error(ex)
Throw ex