File: D:/hMailServer/Events/EventHandlers (prev).vbs
Option Explicit
' (SS,2/9/12) added ProcessWorldPayCallbackFailure, GetAttachmentAsString, GetURL
' removed GetWebPageContents, also added SetLogFileName
' logs now saved in "D:\logs\hMailServer Events\" instead of "D:\hMailServer\Logs\eventlog.txt"
' Also added Option Explicit
' (SS,23/12/14) added Sub ProcessSpamDeletion (global rule: Spam Deletion)
' Sub OnClientConnect(oClient)
' End Sub
' Sub OnAcceptMessage(oClient, oMessage)
' End Sub
' Sub OnDeliveryStart(oMessage)
' End Sub
' Sub OnDeliverMessage(oMessage)
' End Sub
' Sub OnBackupFailed(sReason)
' End Sub
' Sub OnBackupCompleted()
' End Sub
' Sub OnError(iSeverity, iCode, sSource, sDescription)
' End Sub
' Sub OnDeliveryFailed(oMessage, sRecipient, sErrorMessage)
' End Sub
' Sub OnExternalAccountDownload(oMessage, sRemoteUID)
' End Sub
' (SS,2/9/12)
Const LOG_FOLDER = "D:\logs\hMailServer Events\"
Dim NL
NL = Chr(13) + Chr(10)
Dim FLogFileName, FLogText
SetLogFileName "log.txt"
FLogText = ""
' (SS,5/10/07)
Sub ProcessGoogleCheckout(oMessage)
SetLogFileName "google-checkouts.txt" ' (SS,2/9/12)
' (SS,25/2/09) modified hmailserver rules to check for noreply@checkout.google.com in From address
' previously was "Purchase Receipt for Order" in subject
AddLog ""
' (SS,24/10/08) added & oMessage.To to show which email address / site
AddLog "1. ProcessGoogleCheckout called for " & oMessage.To
Dim NL
NL = Chr(13) + Chr(10)
' (SS,22/11/07) removed following check, wasn't working
' check email is from noreply@checkout.google.com i.e. in oMessage.FromAddress
'If oMessage.FromAddress <> "noreply@checkout.google.com" Then
' AddLog "1.1 Process aborted, reply email doesn't match noreply@checkout.google.com"
' Exit Sub
' End If
AddLog "2. Email from " & oMessage.FromAddress
' check subject contains with "Purchase Receipt for Order"
' (SS,25/2/09) removed subject check because it on longer contains 'Purchase Receipt for Order'
'If InStr(1, oMessage.Subject, "Purchase Receipt for Order", 1) = 0 Then
' AddLog "2.1 Process aborted, subject doesn't contain 'Purchase Receipt for Order'"
' Exit Sub
'End If
'AddLog "3. Email subject contains Purchase Receipt for Order"
Dim LPos, LDomain, LCallbackURL, LGoogleOrderNo, LOrderNo, LBuyer, LTotal, LEmailSubject, LBody
' NB. oMessage.Body has HTML tags removed
LGoogleOrderNo = Trim(GetString(oMessage.Subject,"Purchase Receipt for Order #", "", "A"))
' (SS,25/2/09) replaced above with following because subject now contains just the number
' (SS,16/3/09) now copes with both cases, because Google reverted back to previous template
If LGoogleOrderNo = "" Then
LGoogleOrderNo = Trim(oMessage.Subject)
End If
' (SS,16/3/09) added following to show google order no in log
AddLog "3. Email subject contains Google Order No: " & LGoogleOrderNo
' (SS,25/2/09) added following to convert newlines (0D & 0A) to spaces, the original email must be encoded
' the word Order No was being split across two lines, line ending "..Order" and next line starting with "No.."
LBody = ConvertNewlineToSpaces(oMessage.Body)
LOrderNo = Trim(GetString(LBody, "Order No GC#", " ", "A"))
' body must contain "Order No GC#"
If LOrderNo = "" Then
AddLog "3.1 Process aborted, order no missing"
Exit Sub
End If
' (SS,25/2/09) added following to detect cancellation email
If InStr(1, LBody, "Order cancelled", 1) > 0 Then
AddLog "3.2 Process aborted, order was cancelled"
Exit Sub
End If
AddLog "4. Order Number is " & LOrderNo
' (SS,25/2/09) replaced all oMessage.Body with LBody, removed NL replaced with " "
LBuyer = Trim(GetString(LBody, " has just completed a", " ", "B"))
LTotal = Trim(GetString(LBody, " Total: ", " ", "A"))
LTotal = Trim(Replace(LTotal, "=C2=A3", "")) ' remove unicode pound
' remove characters after and including the space
LPos = InStr(1, LTotal, " ", 1)
If LPos > 0 Then LTotal = Mid(LTotal, 1, LPos - 1)
LDomain = Trim(GetString(oMessage.To, "@", ">", "A"))
LCallbackURL = "http://www." & LDomain & "/googlecheckout-callback.asp"
Dim LPostData
LPostData = ""
LPostData = AddPostData(LPostData, "OrderNo", LOrderNo)
LPostData = AddPostData(LPostData, "GoogleOrderNo", LGoogleOrderNo)
LPostData = AddPostData(LPostData, "Buyer", LBuyer)
LPostData = AddPostData(LPostData, "Total", LTotal)
LPostData = AddPostData(LPostData, "EmailSubject", oMessage.Subject)
LPostData = AddPostData(LPostData, "EmailContents", oMessage.Body)
LBody = ""
LBody = LBody + "OrderNo = " & LOrderNo & NL
LBody = LBody + "GoogleOrderNo = " & LGoogleOrderNo & NL
LBody = LBody + "Buyer = " & LBuyer & NL
LBody = LBody + "Total = " & LTotal & NL
LBody = LBody + "To Address = " & oMessage.To & NL
LBody = LBody + "From Address = " & oMessage.FromAddress & NL
LBody = LBody + "Subject = " & oMessage.Subject & NL
LBody = LBody + "CallbackURL = " & LCallbackURL & NL
LBody = LBody + "Email Content = " & oMessage.Body & NL
' (SS,2/9/12) replaced GetWebPageContents(LCallbackURL, LPostData) with GetURL(LCallbackURL & "?" & LPostData)
LBody = LBody + "Callback Content = " & GetURL(LCallbackURL & "?" & LPostData)
AddLog "5. Callback executed: " & LCallbackURLBody & " - " & LPostData
' send the new email message
Dim oNewMessage
Set oNewMessage = CreateObject("hMailServer.Message")
oNewMessage.From = "hMailServer (Google Checkout Event)"
oNewMessage.FromAddress = "googlecheckout@itpartnership.com"
oNewMessage.Subject = "Google Checkout Payment Received for Order " & LOrderNo
oNewMessage.AddRecipient "", oMessage.To
oNewMessage.Body = LBody
oNewMessage.Save
Set oNewMessage = Nothing
AddLog "6. Email sent"
AddLog "7. ProcessGoogleCheckout completed"
End Sub
' (SS,2/9/12)
Sub ProcessWorldPayCallbackFailure(oMessage)
SetLogFileName "worldpay-callback-failures.txt"
AddLog ""
AddLog "1. ProcessWorldPayCallbackFailure"
AddLog "2. Email to " & oMessage.To
AddLog "3. Email from " & oMessage.FromAddress
Dim LTransactionID, LCartID, LInstallationID, LCallbackURL
' NB. oMessage.Body has HTML tags removed
LTransactionID = Trim(GetString(oMessage.Body, "Transaction ID: ", NL, "A"))
LCartID = Trim(GetString(oMessage.Body, "Cart ID: ", NL, "A"))
LInstallationID = Trim(GetString(oMessage.Body, "Installation ID: ", NL, "A"))
LCallbackURL = Trim(GetString(oMessage.Body, "Callback to: ", ": ", "A"))
' (SS,16/3/09) added following to show values in log
AddLog "4. Transaction ID: " & LTransactionID
AddLog "5. Cart ID: " & LCartID
AddLog "6. Installation ID: " & LInstallationID
AddLog "7. Callback URL: " & LCallbackURL
Dim LHost, LQueryString
LHost = ""
LQueryString = ""
If oMessage.Attachments.Count > 0 Then
Dim LAttachmentString
LAttachmentString = GetAttachmentAsString(oMessage.Attachments.Item(0))
AddLog "8.1 Attachment found: " & oMessage.Attachments.Item(0).Filename
LHost = Trim(GetString(LAttachmentString, "Host: ", NL, "A"))
LQueryString = Trim(GetString(LAttachmentString, NL & NL, "", "A")) ' everything after two new lines
End if
AddLog "8.2 Host from attachment: " & LHost
AddLog "8.3 Query String from attachment: " & LQueryString
If LCallbackURL <> "" And LQueryString <> "" Then
AddLog "8.4 Attempting callback to: " & LCallbackURL & "?" & LQueryString
AddLog "8.5 Callback response = " & GetURL(LCallbackURL & "?" & LQueryString)
Else
AddLog "8.4 Nothing to do"
End If
' send email message with log
Dim oNewMessage
Set oNewMessage = CreateObject("hMailServer.Message")
oNewMessage.From = "hMailServer (WorldPay Callback Failure Handler)"
oNewMessage.FromAddress = "worldpaycallbackfailure@itpartnership.com"
oNewMessage.Subject = "WorldPay Callback Failure Handled for " & LHost & " Order " & LCartID
oNewMessage.AddRecipient "", "purchases@itpartnership.com" 'oMessage.To
oNewMessage.Body = FLogText
oNewMessage.Save
Set oNewMessage = Nothing
AddLog "8. Email sent"
AddLog "9. ProcessWorldPayCallbackFailure completed"
End Sub
' (SS,5/10/07) returns part of given string after given string ending at given string
' ADirection can be "A" for after, "B" for before
' e.g. GetString("abc def ghi", "def", "h", "A") returns " g"
' e.g. GetString("abcd def ghi", "def", "bc", "B") returns "d "
' StrComp used for Text comparison to work with unicode strings
Function GetString(ASearchIn, ASearchFor, AEndsWith, ADirection)
Dim LStr, LPos, i, LLenSearchIn, LLenSearchFor, LLenEndsWith
LStr = ""
LPos = InStr(1, ASearchIn, ASearchFor, 1)
If LPos > 0 Then
LLenSearchIn = Len(ASearchIn)
LLenSearchFor = Len(ASearchFor)
LLenEndsWith = Len(AEndsWith)
If ADirection = "A" Then
LPos = LPos + LLenSearchFor
For i = LPos To LLenSearchIn
If LLenEndsWith <> 0 And StrComp(Mid(ASearchIn, i, LLenEndsWith), AEndsWith, 1) = 0 Then
Exit For
End If
LStr = LStr + Mid(ASearchIn, i, 1)
Next
Else
LPos = LPos - 1
For i = LPos To 1 Step -1
If LLenEndsWith <> 0 Then
If i - LLenEndsWith + 1 > 0 Then
If StrComp(Mid(ASearchIn, i - LLenEndsWith + 1, LLenEndsWith), AEndsWith, 1) = 0 Then
Exit For
End If
End If
End If
LStr = Mid(ASearchIn, i, 1) + LStr
Next
End If
End If
' (SS,25/2/09) added following to help with debugging
' (SS,2/9/12) removed debugged
'AddLog "GetString called with ASearchIn=" & ASearchIn & ", ASearchFor=" & ASearchFor & ", AEndsWith=" & AEndsWith & ", ADirection=" & ADirection
'AddLog "GetString returned " & LStr & ", LPos=" & LPos
GetString = LStr
End Function
' (SS,25/2/09)
Function ConvertNewlineToSpaces(AString)
ConvertNewlineToSpaces = Replace(AString, Chr(13) + Chr(10), " ")
End Function
' (SS,5/10/07)
Function AddPostData(APostData, AFieldName, AFieldValue)
Dim LPostData
LPostData = APostData
If LPostData <> "" Then LPostData = LPostData & "&"
LPostData = LPostData & AFieldName & "=" & URLEncode(AFieldValue)
AddPostData = LPostData
End Function
' (SS/2/9/12) returns contents of given URL, used to send HTML emails, AURL can contain querystring
Function GetURL(AURL)
Dim LResult, LHttp
LResult = ""
Set LHttp = CreateObject("Msxml2.ServerXMLHTTP.3.0")
LHttp.open "GET", AURL, False
LHttp.send
If LHttp.status <> 200 then
LResult = "Error: " & LHttp.status
Else
LResult = LHttp.responseText
End If
GetURL = LResult
End Function
' (SS,5/10/07) Server.URLEncode doesn't work here (only in for ASP)
' modified to work with scripts (i.e. removed variable types and error handling code)
'**************************************
' Name: URLEncode Function
' Description:Encodes a string to create
' legally formatted
'QueryString For URL. This Function is more flexible
'than the IIS Server.Encode Function because you can
'pass In the WHOLE URL and only the QueryString data
'will be converted. IIS strangely converts EVERYTHING
'(ie "http://" becomes "http%3A%2F%2F").
' By: Markus Diersbock
'
' Inputs:sRawURL - String to Encode
'
' Returns:Encoded String
'
'This code is copyrighted and has' limited warranties.Please see http://w
' ww.Planet-Source-Code.com/vb/scripts/Sho
' wCode.asp?txtCodeId=43806&lngWId=1'for details.'**************************************
Function URLEncode(sRawURL)
Dim iLoop
Dim sRtn
Dim sTmp
Const sValidChars = "1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz:/.?=_-$(){}~&"
If Len(sRawURL) > 0 Then
' Loop through each char
For iLoop = 1 To Len(sRawURL)
sTmp = Mid(sRawURL, iLoop, 1)
If InStr(1, sValidChars, sTmp, vbBinaryCompare) = 0 Then
' If not ValidChar, convert to HEX and p
' refix with %
sTmp = Hex(Asc(sTmp))
If sTmp = "20" Then
sTmp = "+"
ElseIf Len(sTmp) = 1 Then
sTmp = "%0" & sTmp
Else
sTmp = "%" & sTmp
End If
End If
sRtn = sRtn & sTmp
Next
URLEncode = sRtn
End If
End Function
Sub SetLogFileName(AFileName)
FLogFileName = LOG_FOLDER + AFileName
End Sub
' (SS,22/11/07)
Sub AddLog(AMessage)
Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(FLogFileName, 8, True)
f.WriteLine(Now & " - " & AMessage)
f.Close
Set f = Nothing
Set fs = Nothing
' add to log text, which may be used in email
If AMessage <> "" Then FLogText = FLogText & Now & " - " & AMessage & NL
End Sub
' (SS,2/9/12) return contents of attachment as string, it has to be saved as file first
Function GetAttachmentAsString(AAttachment)
' save to file
Dim LFileName
LFileName = LOG_FOLDER + AAttachment.Filename
AAttachment.SaveAs(LFileName)
' read from file into string
Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(LFileName, 1)
GetAttachmentAsString = f.ReadAll
f.Close
Set f = Nothing
Set fs = Nothing
End Function
' (SS,23/12/14) logs from and to address of the spam email, subject and name of the attached file (added to a Rule via function)
Sub ProcessSpamDeletion(oMessage)
SetLogFileName "spam-deletion.txt"
Dim LAttachmentFilename
If oMessage.Attachments.Count > 0 Then
LAttachmentFilename = oMessage.Attachments.Item(0).Filename
Else
LAttachmentFilename = ""
End if
AddLog "ProcessSpamDeletion, " & oMessage.To & ", " & oMessage.FromAddress & ", " & oMessage.Subject & ", " & LAttachmentFilename
End Sub