Code: Select all
'
' EventHandler script used to check mail attachments on VirusTotal fired from hMailServer
' The script do the following things:
' cycle the message attachments
' save them in a temp folder
' compute a MD5 checksum fo the attachment and delete the temporary file
' query VirusTotal API to check if the MD5 is present
' parse the json response and
' if empty response write to eventlog
' if valid response and response_code is "0", the file is not present in VirusTotal, only write the event log
' if positives <>"0" the file is known to VirusTotal as dangerous, so the attachment is removed and the
' mail subject tagged with the custom prefix
'
' Version 1.0 2017/07/20
' Go to OnAcceptMessage sub and define the following constants
' Const tempPath = "e:\hMailServer\events\temp\" ' existing path where the attachments will be temporarly stored
' Const apikey ="you virustotal api key, got after registration"
' Const prefix = "[VIRUSTOTAL-REMOVED-ATTACHMENT] " ' a prefix injected before original mail subject if dangerous attachment found and removed
'
'
'
' Functions to compute MD5
' source https://stackoverflow.com/questions/10198690/how-to-generate-md5-using-vbscript-in-classic-asp thanks to "SgtWilko"
'
function md5hashBytes(aBytes)
Dim MD5
set MD5 = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
MD5.Initialize()
'Note you MUST use computehash_2 to get the correct version of this method, and the bytes MUST be double wrapped in brackets to ensure they get passed in correctly.
md5hashBytes = MD5.ComputeHash_2( (aBytes) )
end function
function sha1hashBytes(aBytes)
Dim sha1
set sha1 = CreateObject("System.Security.Cryptography.SHA1Managed")
sha1.Initialize()
'Note you MUST use computehash_2 to get the correct version of this method, and the bytes MUST be double wrapped in brackets to ensure they get passed in correctly.
sha1hashBytes = sha1.ComputeHash_2( (aBytes) )
end function
function sha256hashBytes(aBytes)
Dim sha256
set sha256 = CreateObject("System.Security.Cryptography.SHA256Managed")
sha256.Initialize()
'Note you MUST use computehash_2 to get the correct version of this method, and the bytes MUST be double wrapped in brackets to ensure they get passed in correctly.
sha256hashBytes = sha256.ComputeHash_2( (aBytes) )
end function
function sha256HMACBytes(aBytes, aKey)
Dim sha256
set sha256 = CreateObject("System.Security.Cryptography.HMACSHA256")
sha256.Initialize()
sha256.key=aKey
'Note you MUST use computehash_2 to get the correct version of this method, and the bytes MUST be double wrapped in brackets to ensure they get passed in correctly.
sha256HMACBytes = sha256.ComputeHash_2( (aBytes) )
end function
function stringToUTFBytes(aString)
Dim UTF8
Set UTF8 = CreateObject("System.Text.UTF8Encoding")
stringToUTFBytes = UTF8.GetBytes_4(aString)
end function
function bytesToHex(aBytes)
dim hexStr, x
for x=1 to lenb(aBytes)
hexStr= hex(ascb(midb( (aBytes),x,1)))
if len(hexStr)=1 then hexStr="0" & hexStr
bytesToHex=bytesToHex & hexStr
next
end function
Function BytesToBase64(varBytes)
With CreateObject("MSXML2.DomDocument").CreateElement("b64")
.dataType = "bin.base64"
.nodeTypedValue = varBytes
BytesToBase64 = .Text
End With
End Function
'Special version that produces the URLEncoded variant of Base64 used in JWTs.
Function BytesToBase64UrlEncode(varBytes)
With CreateObject("MSXML2.DomDocument").CreateElement("b64")
.dataType = "bin.base64"
.nodeTypedValue = varBytes
BytesToBase64UrlEncode = replace(replace(replace(replace(replace(.Text,chr(13),""),chr(10),""),"+", "-"),"/", "_"),"=", "")
End With
End Function
Function GetBytes(sPath)
With CreateObject("Adodb.Stream")
.Type = 1 ' adTypeBinary
.Open
.LoadFromFile sPath
.Position = 0
GetBytes = .Read
.Close
End With
End Function
'
' Class used to parse Json response
' source http://demon.tw/my-work/vbs-json.html
'
Class VbsJson
'Author: Demon
'Date: 2012/5/3
'Website: http://demon.tw
Private Whitespace, NumberRegex, StringChunk
Private b, f, r, n, t
Private Sub Class_Initialize
Whitespace = " " & vbTab & vbCr & vbLf
b = ChrW(8)
f = vbFormFeed
r = vbCr
n = vbLf
t = vbTab
Set NumberRegex = New RegExp
NumberRegex.Pattern = "(-?(?:0|[1-9]\d*))(\.\d+)?([eE][-+]?\d+)?"
NumberRegex.Global = False
NumberRegex.MultiLine = True
NumberRegex.IgnoreCase = True
Set StringChunk = New RegExp
StringChunk.Pattern = "([\s\S]*?)([""\\\x00-\x1f])"
StringChunk.Global = False
StringChunk.MultiLine = True
StringChunk.IgnoreCase = True
End Sub
'Return a JSON string representation of a VBScript data structure
'Supports the following objects and types
'+-------------------+---------------+
'| VBScript | JSON |
'+===================+===============+
'| Dictionary | object |
'+-------------------+---------------+
'| Array | array |
'+-------------------+---------------+
'| String | string |
'+-------------------+---------------+
'| Number | number |
'+-------------------+---------------+
'| True | true |
'+-------------------+---------------+
'| False | false |
'+-------------------+---------------+
'| Null | null |
'+-------------------+---------------+
Public Function Encode(ByRef obj)
Dim buf, i, c, g
Set buf = CreateObject("Scripting.Dictionary")
Select Case VarType(obj)
Case vbNull
buf.Add buf.Count, "null"
Case vbBoolean
If obj Then
buf.Add buf.Count, "true"
Else
buf.Add buf.Count, "false"
End If
Case vbInteger, vbLong, vbSingle, vbDouble
buf.Add buf.Count, obj
Case vbString
buf.Add buf.Count, """"
For i = 1 To Len(obj)
c = Mid(obj, i, 1)
Select Case c
Case """" buf.Add buf.Count, "\"""
Case "\" buf.Add buf.Count, "\\"
Case "/" buf.Add buf.Count, "/"
Case b buf.Add buf.Count, "\b"
Case f buf.Add buf.Count, "\f"
Case r buf.Add buf.Count, "\r"
Case n buf.Add buf.Count, "\n"
Case t buf.Add buf.Count, "\t"
Case Else
If AscW(c) >= 0 And AscW(c) <= 31 Then
c = Right("0" & Hex(AscW(c)), 2)
buf.Add buf.Count, "\u00" & c
Else
buf.Add buf.Count, c
End If
End Select
Next
buf.Add buf.Count, """"
Case vbArray + vbVariant
g = True
buf.Add buf.Count, "["
For Each i In obj
If g Then g = False Else buf.Add buf.Count, ","
buf.Add buf.Count, Encode(i)
Next
buf.Add buf.Count, "]"
Case vbObject
If TypeName(obj) = "Dictionary" Then
g = True
buf.Add buf.Count, "{"
For Each i In obj
If g Then g = False Else buf.Add buf.Count, ","
buf.Add buf.Count, """" & i & """" & ":" & Encode(obj(i))
Next
buf.Add buf.Count, "}"
Else
Err.Raise 8732,,"None dictionary object"
End If
Case Else
buf.Add buf.Count, """" & CStr(obj) & """"
End Select
Encode = Join(buf.Items, "")
End Function
'Return the VBScript representation of ``str(``
'Performs the following translations in decoding
'+---------------+-------------------+
'| JSON | VBScript |
'+===============+===================+
'| object | Dictionary |
'+---------------+-------------------+
'| array | Array |
'+---------------+-------------------+
'| string | String |
'+---------------+-------------------+
'| number | Double |
'+---------------+-------------------+
'| true | True |
'+---------------+-------------------+
'| false | False |
'+---------------+-------------------+
'| null | Null |
'+---------------+-------------------+
Public Function Decode(ByRef str)
Dim idx
idx = SkipWhitespace(str, 1)
If Mid(str, idx, 1) = "{" Then
Set Decode = ScanOnce(str, 1)
Else
Decode = ScanOnce(str, 1)
End If
End Function
Private Function ScanOnce(ByRef str, ByRef idx)
Dim c, ms
idx = SkipWhitespace(str, idx)
c = Mid(str, idx, 1)
If c = "{" Then
idx = idx + 1
Set ScanOnce = ParseObject(str, idx)
Exit Function
ElseIf c = "[" Then
idx = idx + 1
ScanOnce = ParseArray(str, idx)
Exit Function
ElseIf c = """" Then
idx = idx + 1
ScanOnce = ParseString(str, idx)
Exit Function
ElseIf c = "n" And StrComp("null", Mid(str, idx, 4)) = 0 Then
idx = idx + 4
ScanOnce = Null
Exit Function
ElseIf c = "t" And StrComp("true", Mid(str, idx, 4)) = 0 Then
idx = idx + 4
ScanOnce = True
Exit Function
ElseIf c = "f" And StrComp("false", Mid(str, idx, 5)) = 0 Then
idx = idx + 5
ScanOnce = False
Exit Function
End If
Set ms = NumberRegex.Execute(Mid(str, idx))
If ms.Count = 1 Then
idx = idx + ms(0).Length
ScanOnce = CDbl(ms(0))
Exit Function
End If
Err.Raise 8732,,"No JSON object could be ScanOnced"
End Function
Private Function ParseObject(ByRef str, ByRef idx)
Dim c, key, value
Set ParseObject = CreateObject("Scripting.Dictionary")
idx = SkipWhitespace(str, idx)
c = Mid(str, idx, 1)
If c = "}" Then
Exit Function
ElseIf c <> """" Then
Err.Raise 8732,,"Expecting property name"
End If
idx = idx + 1
Do
key = ParseString(str, idx)
idx = SkipWhitespace(str, idx)
If Mid(str, idx, 1) <> ":" Then
Err.Raise 8732,,"Expecting : delimiter"
End If
idx = SkipWhitespace(str, idx + 1)
If Mid(str, idx, 1) = "{" Then
Set value = ScanOnce(str, idx)
Else
value = ScanOnce(str, idx)
End If
ParseObject.Add key, value
idx = SkipWhitespace(str, idx)
c = Mid(str, idx, 1)
If c = "}" Then
Exit Do
ElseIf c <> "," Then
Err.Raise 8732,,"Expecting , delimiter"
End If
idx = SkipWhitespace(str, idx + 1)
c = Mid(str, idx, 1)
If c <> """" Then
Err.Raise 8732,,"Expecting property name"
End If
idx = idx + 1
Loop
idx = idx + 1
End Function
Private Function ParseArray(ByRef str, ByRef idx)
Dim c, values, value
Set values = CreateObject("Scripting.Dictionary")
idx = SkipWhitespace(str, idx)
c = Mid(str, idx, 1)
If c = "]" Then
idx = idx + 1
ParseArray = values.Items
Exit Function
End If
Do
idx = SkipWhitespace(str, idx)
If Mid(str, idx, 1) = "{" Then
Set value = ScanOnce(str, idx)
Else
value = ScanOnce(str, idx)
End If
values.Add values.Count, value
idx = SkipWhitespace(str, idx)
c = Mid(str, idx, 1)
If c = "]" Then
Exit Do
ElseIf c <> "," Then
Err.Raise 8732,,"Expecting , delimiter"
End If
idx = idx + 1
Loop
idx = idx + 1
ParseArray = values.Items
End Function
Private Function ParseString(ByRef str, ByRef idx)
Dim chunks, content, terminator, ms, esc, char
Set chunks = CreateObject("Scripting.Dictionary")
Do
Set ms = StringChunk.Execute(Mid(str, idx))
If ms.Count = 0 Then
Err.Raise 8732,,"Unterminated string starting"
End If
content = ms(0).Submatches(0)
terminator = ms(0).Submatches(1)
If Len(content) > 0 Then
chunks.Add chunks.Count, content
End If
idx = idx + ms(0).Length
If terminator = """" Then
Exit Do
ElseIf terminator <> "\" Then
Err.Raise 8732,,"Invalid control character"
End If
esc = Mid(str, idx, 1)
If esc <> "u" Then
Select Case esc
Case """" char = """"
Case "\" char = "\"
Case "/" char = "/"
Case "b" char = b
Case "f" char = f
Case "n" char = n
Case "r" char = r
Case "t" char = t
Case Else Err.Raise 8732,,"Invalid escape"
End Select
idx = idx + 1
Else
char = ChrW("&H" & Mid(str, idx + 1, 4))
idx = idx + 5
End If
chunks.Add chunks.Count, char
Loop
ParseString = Join(chunks.Items, "")
End Function
Private Function SkipWhitespace(ByRef str, ByVal idx)
Do While idx <= Len(str) And _
InStr(Whitespace, Mid(str, idx, 1)) > 0
idx = idx + 1
Loop
SkipWhitespace = idx
End Function
End Class
'
' functions to query url
'
Function BinaryToString(Binary)
Dim I,S
For I = 1 to LenB(Binary)
S = S & Chr(AscB(MidB(Binary,I,1)))
Next
BinaryToString = S
End Function
Function getURL(URL)
'Create an Http object, use any of the four objects
Dim Http
Dim origHTML
' Set Http = CreateObject("Microsoft.XMLHTTP")
' Set Http = CreateObject("MSXML2.ServerXMLHTTP")
Set Http = CreateObject("MSXML2.ServerXMLHTTP.3.0")
' Set Http = CreateObject("WinHttp.WinHttpRequest.5.1")
'' Set Http = CreateObject("WinHttp.WinHttpRequest")
'Set Http = CreateObject("Microsoft.XmlHttp")
' Set Http = CreateObject("microsoft.xmlhttp")
'Send request To URL
Http.Open "POST", URL, FALSE
Http.Send ""
'Get response data As a string
getURL = BinaryToString(Http.ResponseBody)
'BinaryGetURL = Http.ResponseText
set Httpd = nothing
End Function
'
' EventHandler
'
Sub OnAcceptMessage(oClient, oMessage)
Const tempPath = "e:\hMailServer\events\temp\"
Const apikey ="your api key"
Const prefix = "[VIRUSTOTAL] "
Dim oAttachment
dim filesys
dim fil
dim tempName
For oAttachment = 0 to oMessage.Attachments.Count-1
Set filesys = CreateObject("Scripting.FileSystemObject")
tempname = tempPath & filesys.GetTempName '& "_" & oMessage.Attachments(oAttachment).Filename
oMessage.Attachments(oAttachment).SaveAs(tempname)
dim hash
hash = bytesToHex(md5hashBytes(GetBytes(tempname)))
set fil = filesys.GetFile(tempname)
fil.Delete
set fil = Nothing
set filesys = Nothing
EventLog.Write ("Checking attachment in VirusTotal: " _
& oMessage.Attachments(oAttachment).Filename & " Size : " _
& oMessage.Attachments(oAttachment).Size & " Computed MD5 : " & hash)
' Test for undesirable attachments
Dim retVal
retVal = getURL("https://www.virustotal.com/vtapi/v2/file/report?apikey=" & apikey & "&resource=" & hash)
If IsNull(retVal) or retVal = "" then
EventLog.Write ("*** EMPTY response from VirusTotal")
else
EventLog.Write ("VirusTotal response: <" & retVal & ">")
' get response data
Set json = New VbsJson
Set o = json.Decode(retVal)
dim resp
dim posit
resp = o("response_code")
posit = o("positives")
if resp = "1" then
if posit <>"0" then
oMessage.Subject = prefix & oMessage.Subject
' Log in event log
EventLog.Write ("Email Rejected: Attachment unacceptable: " _
& oMessage.Attachments(oAttachment).Filename & " Size : " _
& oMessage.Attachments(oAttachment).Size & " VirusTotal SHA : " & o("sha256"))
oMessage.Attachments(oAttachment).Delete()
oMessage.Save()
else
EventLog.Write ("Attachment present in VirusTotal but SAFE: " _
& oMessage.Attachments(oAttachment).Filename & " Size : " _
& oMessage.Attachments(oAttachment).Size & " VirusTotal SHA : " & o("sha256"))
end if
else
EventLog.Write ("Attachment not present in VirusTotal: " _
& oMessage.Attachments(oAttachment).Filename)
end if
end if
Next
Result.Value = 0
End Sub
