Mail Going To Junk Folder

[xydon1]

So I gave up on SpamAssassin as I felt it just wasnt doing the job. I was being bitched at by most people in my company still getting bulk emails and some spam.

We are now using a company called Barracuda, they are about 98% effective. However, some email is still going to the Junk folder of some users. If i set my Spam mark threshold=100 and Spam delete threshold=100 will this make hmailserver think all mail is legitimate and NOT send to Junk folder?

If this methodology is incorrect, is there a setting to never send mail to Junk folder?

[tochi]

hmailserver doesn't move emails from users' inbox to junk folder unless you define rules to do that. Do you still have those rules enabled in hmailserver? Some email clients have spam protections. Are you sure emails were not moved by email client?

[SorenR]

So I gave up on SpamAssassin as I felt it just wasnt doing the job. I was being bitched at by most people in my company still getting bulk emails and some spam.

We are now using a company called Barracuda, they are about 98% effective. However, some email is still going to the Junk folder of some users. If i set my Spam mark threshold=100 and Spam delete threshold=100 will this make hmailserver think all mail is legitimate and NOT send to Junk folder?

If this methodology is incorrect, is there a setting to never send mail to Junk folder?

Bulk emails can be really hard to get rid of - especially if people DON'T tell you they don't want them...

I flag domains on a blacklist rule and run this function to unsubscribe whoever I can:

Code: Select all

   Sub Unsubscribe(oMessage)
      If (InStr(oMessage.HeaderValue("List-Unsubscribe"), "http") > 0) Then
         Dim x, y, sURL, sResponseText
         y = Split(oMessage.HeaderValue("List-Unsubscribe"), ",")
         For Each x In y
            If (InStr(x, "http") > 0) Then
               If (InStr(x, "<") > 0) Then
                  sURL = Mid(Trim(x), 2, Len(Trim(x))-2)
               Else
                  sURL = Trim(x)
               End If
               Eventlog.Write("From: " & oMessage.From & " :: To: " & oMessage.To & " :: Subject: " & oMessage.Subject)
               Eventlog.Write("Attempting to unsubscribe URL: " & sURL)
               On Error Resume Next
               With CreateObject("MSXML2.ServerXMLHTTP")
                  .setoption(2) = (.getoption(2) & " - SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS")
                  .open "GET", sURL, False
                  .setrequestheader "User-Agent", "Mozilla/5.0 (compatible, MSIE 11, Windows NT 6.3; Trident/7.0;  rv:11.0) like Gecko"
                  .send ("")
                  sResponseText = LCase(.ResponseText)
               End With
               On Error Goto 0
               If (Err.Number <> 0) Then
                  EventLog.Write("ERROR: Sub Unsubscribe(oMessage)")
                  EventLog.Write("Error       : " & Err.Number)
                  EventLog.Write("Error (hex) : 0x" & Hex(Err.Number))
                  EventLog.Write("Source      : " & Err.Source)
                  EventLog.Write("Description : " & Err.Description)
                  Err.Clear
               Else
                  Select Case True
                     Case InStr(sResponseText, "er blevet afmeldt") > 0
                          Eventlog.Write("- unsubscribed/removed")
                     Case InStr(sResponseText, "afmelding udført") > 0
                          Eventlog.Write("- unsubscribed/removed")
                     Case InStr(sResponseText, "afmeldt") > 0
                          Eventlog.Write("- unsubscribed/removed")
                     Case InStr(sResponseText, "er blevet fjernet") > 0
                          Eventlog.Write("- unsubscribed/removed")
                     Case InStr(sResponseText, "unsubscribed") > 0
                          Eventlog.Write("- unsubscribed/removed")
                     Case InStr(sResponseText, "has been removed") > 0
                          Eventlog.Write("- unsubscribed/removed")
                     Case InStr(sResponseText, "was removed") > 0
                          Eventlog.Write("- unsubscribed/removed")
                     Case InStr(sResponseText, "successfully removed") > 0
                          Eventlog.Write("- unsubscribed/removed")
                     Case InStr(sResponseText, "gennemført") > 0
                          Eventlog.Write("- unsubscribed/removed")
                     Case Else
                          Eventlog.Write("- unsubscribtion/removal NOT CONFIRMED")
                  End Select
               End If
            End If
         Next
      End If
   End Sub

[jimimaseye]

Soren, arent you concerned that doing an automatic 'unsubscribe' is just validating the existance of the email address? I know that using an 'unsubscribe link' header is a policy to make the email conform to antispam policies and make them seem more genuine, but spammers know about it include the header and link even though that it doesnt ACTUALLY do the job you expect of it. (It can simply confirm existence and make your unauthorised stay on this list of addresses that you have found yourself on be made a LOT longer....and passed to a lot more list hotels).

I find that we keep receiving emails to address that do not, have not and never will officially exist (they get caught in the CATCHALL) and yet they seem to be personalised. In truth they have been guessed from UK Government 'Companies House' which list directors and secretaries of the company and then people have simply combined these names to the company domain name.

eg
COMPANIES HOUSE has our Company as
SpaceRockers Ltd
Directors: Geoff Rocket, Gynette Rocket
Secretary: Billy Boil

and we now receive emails to "billy@spacerocket.co.uk", "Geoff@spacerocket.co.uk" and "Gynette@spacerocket.co.uk" despite Gynette being a sleeping partner and doesnt have an address and Billy has been dead for years! Even the naming convention of the address doesnt conform.

These emails were then processed by clicking the 'unsubscribe' link and it seems all that happened was this address became more abused seemingly appearing on emails from genuine marketing lists AND rogue shitty spammy stuff (pills, russian babes etc)

My policy: at best INVESTIGATE the source and try to contact the list owners for removal if it looks genuine enough, or at worst just delete!

[SorenR]

Soren, arent you concerned that doing an automatic 'unsubscribe' is just validating the existance of the email address?

Nah... They already have it from somewhere else and it only to save space in my junk folder - where it will end up anyways

I get next to no emails to nonexisting accounts and most of the time I see a pattern... Eg. it seems one list contain my daughter, my son and myself so they always come in three at the time...

90% of the bulk emails says "you subscribed to this email" and doing just a minimal behavior analyzing it's almost always some Facebook crap post they viewed... "Press LIKE to watch bla bla bla..."

When you do this you subscribe to about 450 other lists.... DOH!

Sometimes you just want to pour glue in the keyboard and kill the mouse with a hammer...

[jimimaseye]

Sometimes you just want to pour glue in the keyboard and kill the mouse with a hammer...

....or even the kids!! That would stop the junk mail AND cost less on replacement parts.

[palinka]

So I gave up on SpamAssassin as I felt it just wasnt doing the job. I was being bitched at by most people in my company still getting bulk emails and some spam.

We are now using a company called Barracuda, they are about 98% effective. However, some email is still going to the Junk folder of some users. If i set my Spam mark threshold=100 and Spam delete threshold=100 will this make hmailserver think all mail is legitimate and NOT send to Junk folder?

If this methodology is incorrect, is there a setting to never send mail to Junk folder?

Bulk emails can be really hard to get rid of - especially if people DON'T tell you they don't want them...

I flag domains on a blacklist rule and run this function to unsubscribe whoever I can:

Code: Select all

   Sub Unsubscribe(oMessage)
      If (InStr(oMessage.HeaderValue("List-Unsubscribe"), "http") > 0) Then
         Dim x, y, sURL, sResponseText
         y = Split(oMessage.HeaderValue("List-Unsubscribe"), ",")
         For Each x In y
            If (InStr(x, "http") > 0) Then
               If (InStr(x, "<") > 0) Then
                  sURL = Mid(Trim(x), 2, Len(Trim(x))-2)
               Else
                  sURL = Trim(x)
               End If
               Eventlog.Write("From: " & oMessage.From & " :: To: " & oMessage.To & " :: Subject: " & oMessage.Subject)
               Eventlog.Write("Attempting to unsubscribe URL: " & sURL)
               On Error Resume Next
               With CreateObject("MSXML2.ServerXMLHTTP")
                  .setoption(2) = (.getoption(2) & " - SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS")
                  .open "GET", sURL, False
                  .setrequestheader "User-Agent", "Mozilla/5.0 (compatible, MSIE 11, Windows NT 6.3; Trident/7.0;  rv:11.0) like Gecko"
                  .send ("")
                  sResponseText = LCase(.ResponseText)
               End With
               On Error Goto 0
               If (Err.Number <> 0) Then
                  EventLog.Write("ERROR: Sub Unsubscribe(oMessage)")
                  EventLog.Write("Error       : " & Err.Number)
                  EventLog.Write("Error (hex) : 0x" & Hex(Err.Number))
                  EventLog.Write("Source      : " & Err.Source)
                  EventLog.Write("Description : " & Err.Description)
                  Err.Clear
               Else
                  Select Case True
                     Case InStr(sResponseText, "er blevet afmeldt") > 0
                          Eventlog.Write("- unsubscribed/removed")
                     Case InStr(sResponseText, "afmelding udført") > 0
                          Eventlog.Write("- unsubscribed/removed")
                     Case InStr(sResponseText, "afmeldt") > 0
                          Eventlog.Write("- unsubscribed/removed")
                     Case InStr(sResponseText, "er blevet fjernet") > 0
                          Eventlog.Write("- unsubscribed/removed")
                     Case InStr(sResponseText, "unsubscribed") > 0
                          Eventlog.Write("- unsubscribed/removed")
                     Case InStr(sResponseText, "has been removed") > 0
                          Eventlog.Write("- unsubscribed/removed")
                     Case InStr(sResponseText, "was removed") > 0
                          Eventlog.Write("- unsubscribed/removed")
                     Case InStr(sResponseText, "successfully removed") > 0
                          Eventlog.Write("- unsubscribed/removed")
                     Case InStr(sResponseText, "gennemført") > 0
                          Eventlog.Write("- unsubscribed/removed")
                     Case Else
                          Eventlog.Write("- unsubscribtion/removal NOT CONFIRMED")
                  End Select
               End If
            End If
         Next
      End If
   End Sub

I know you're using the other unsubscribe script you posted in the sa-learn thread. That one appears to work only on URLs while this one uses mailto: addresses. I installed the newer one but disabled the rule today after thinking maybe a spammer could have used a malicious link and I don't want to download a virus onto my server.

Maybe you could let me know why you think the URL one is better. Thanks.

[SorenR]

Ah, well... The one in the SpamAssassin thread is a newer version of the one you quoted. I've never used the "mailto:" link, allthough I have thought about it, but if the URL does not work, chances are that the mailto: won't either.

Good point about the virus thing, never really thought about that. On the other hand, why would they turn their business into a weapon that potentially could ruin them.

[palinka]

Ah, well... The one in the SpamAssassin thread is a newer version of the one you quoted. I've never used the "mailto:" link, allthough I have thought about it, but if the URL does not work, chances are that the mailto: won't either.

Good point about the virus thing, never really thought about that. On the other hand, why would they turn their business into a weapon that potentially could ruin them.

"They" be scurvy internet pirates! Yarrr! A smart hacker/spammer/phisher may do it. I read that Google will only use mailto unsubscribe links because of that threat. The threat seems plausible at least.

It's a smart scam. Set up legit bulk mail with dkim,SPF,etc and everything looks safe. Send messages 3 or 4 times a day - just enough to be annoying without anyone getting suspicious. Unsuspecting user clicks unsubscribe link and BAM! Virus gives control to the scurvy dogs.

No such worries with mailto unsubscribe. The worst case is it becomes a dead letter.

Legit retailers are not the scurvy, lower than whale dung sea creatures you need to worry about. I'm on lots of lists I never signed up for. I never even heard of some of them. In fact, I've been getting spam from some guy (ns8.com?) that I'm sure that my email was harvested from one of the legit tech discussion lists I actually signed up for. "I'm a salesman but I'm not a pest." Yes you are, you scurvy pirate scum! Go down with your burning pirate vessel to Davey Jones locker where you belong!! Bayes_999 for you!!

[SorenR]

Its prolly 2 l8 now but ... hMailAdmin -> Domain -> "mydomain" -> Advanced ... Plus addressing (Select "%")

That way if you use "john.doe%amazon@acme.inc" mails will come to "john.doe@acme.inc" with a tag "%amazon". If suddenly you get a mail re ***-enlargements to "john.doe%amazon@acme.inc" then you'll know who sold the address.

jimimaseye made a script a while back to the same effect PLUS it can discard those addresses that are abused.

For some reason I do not get much SPAM. 3 mails over the last 30 days on an address created in 2003. It has been used in a million places HOWEVER !! If I ever had any doubt about a site/forum/etc I signed up to, then I created an alias. I still get email to an alias I killed in 2005 ...

[jimimaseye]

jimimaseye made a script a while back to the same effect PLUS it can discard those addresses that are abused.

viewtopic.php?f=20&t=29306

[palinka]

^^ I knew someone many years ago that effectively did this with real mail.

[jimimaseye]

^^ I knew someone many years ago that effectively did this with real mail.

I got the idea as a combination of disposable addresses (as I use with Yahoo etc), 'on the fly' disposable (as allowed by Gmail) and the Mail control panel we have (had!) with our Mail provider (enabling specific forwarding and rejections of individual addresses). So I combined the ideas and came up with that.

[SorenR]

^^ I knew someone many years ago that effectively did this with real mail.

Totally OT... I got a letter today Haven't had one of those in a while, totally forgot how it felt like

[jimimaseye]

Totally OT... I got a letter today Haven't had one of those in a while, totally forgot how it felt like

Ah, that's where it went. Bugger. It was meant for my Gran.

[SorenR]

Totally OT... I got a letter today Haven't had one of those in a while, totally forgot how it felt like

Ah, that's where it went. Bugger. It was meant for my Gran.

It was actually a 100 nF 275VAC X2 paper capacitor I ordered for my electric fence controller, no... Cattle/Horse fence, not "keep peeps out" fence however I do believe it works the same way. It an old analog system from the 80's that will hold a spike of 2-3 kV for about a second or two. Not like the modern ones that use a narrow spike

The main capacitor in it is about the size of a standard RedBull can

[jimimaseye]

It was actually a 100 nF 275VAC X2 paper capacitor

Exactly. It was meant for my Gran. (The witch.)

[SorenR]

https://photos.app.goo.gl/9ibkcpFMmxrBm5ReA

If only you could attach this to the mailserver when SPAM is coming in

[palinka]

https://photos.app.goo.gl/9ibkcpFMmxrBm5ReA

If only you could attach this to the mailserver when SPAM is coming in

That is one crazy picture. With that weird futuristic high rise in the background, it looks like a scene from blade runner or something.

I was just looking through my spam honey pot. I happened to notice this in one false positive (commercial mailing list):

Code: Select all

List-Unsubscribe: <http://em.searshomeservices.com/pub/optout/UnsubscribeOneStepConfirmAction?YES=true&_ri_=X0Gzc2X%3DYQpglLjHJlTQGNzgvDCKeNPss6GebGcacXDPvAzgGzfzgTt8UXsos5DDPLvmvfzfze9sDA&_ei_=EuNQ3Rmuva1qi0bkiY6gHuxBmoTW5i6ZzKL5VZAssUXsVJoHvxbIC3qFVvf7hnRlp-qym7GPeIkF4quO9Yoc5CEq6ANqj-EZmU5fw3JGKOOKeQIZmXRMDmouA0m0sYuZJIn2QNP3WIg3yxKsfFzrIUHxV3hZ5oW7HUlgXw>,
 <mailto:unsubscribe-YQpglLjHJlTQGNzgvDCKeNPss6GebGcacXDPvAzgGzfzgTt8UXsos5DDPLvmvfzfze9sDA@imh.rsys2.com?subject=List-Unsubscribe>

It was scored high by spamassassin and while it may be legit, it's annoying. Just about every message with an unsubscribe link in the body has a mailto link in the header.

Wink wink, oh great and wise (and generous) master of the scripts.

[SorenR]

Wink wink, oh great and wise (and generous) master of the scripts.

Where is all the SPAM when you need it

I'll probably end up having to SPAM myself

[SorenR]

I have NO IDEA if this is going to work. I tend to test on live data for a couple of days before releasing but so far... NO suitable SPAM has hit this... Yeah, I know, I should do active testing...

I'm running a "debug Alpha" version on my system, but this should look like the final version.

You can delete the ".Body=" line if it causes any trouble with AntiVirus

Code: Select all

Function oLookup(strRegEx, strMatch, bGlobal)
   With CreateObject("VBScript.RegExp")
      .Pattern = strRegEx
      .Global = bGlobal
      .MultiLine = True
      .IgnoreCase = True
      Set oLookup = .Execute(strMatch)
   End With
End Function

Sub Unsubscribe2(oMessage)
   Dim a, i, strRegEx, Match, Matches, sMailTo, sURL
   Const MailBeforeWeb = True
   If MailBeforeWeb Then
      strRegEx = "([^\<]*?)(mailto:[\s\S]*?)(?=\>)"
      Set Matches = oLookup(strRegEx, oMessage.HeaderValue("List-Unsubscribe"), True)
      If Matches.Count > 0 Then
         For Each Match In Matches
            sMailTo = Right(Trim(Match.Value), 7)
            a = Split(sMailTo, "?")
            On Error Resume Next
            With CreateObject("hMailServer.Message")
               .From = "Wile E. Coyote"
               .FromAddress = "wile.e.coyote@acme.inc"
               If LBound(a) = UBound(a) Then
                  .Subject = oMessage.Subject
               Else
                  .Subject = Replace(a(1), "subject=", "")
               End If
               .AddRecipient a(0), a(0)
               .Body = "X5O!P%@AP" & "[4\PZX54(P^)7CC)7}$" & "EICAR-STANDARD-ANTIVIRUS-TEST-FILE" & "!$H+H*"
               .Save
            End With
            On Error Goto 0
            If (Err.Number <> 0) Then
               EventLog.Write( "ERROR: Sub Unsubscribe(oMessage)" )
               EventLog.Write( "Error       : " & Err.Number )
               EventLog.Write( "Error (hex) : 0x" & Hex(Err.Number) )
               EventLog.Write( "Source      : " & Err.Source )
               EventLog.Write( "Description : " & Err.Description )
               Err.Clear
               Exit Sub
            End If
         Next
      End If
   Else
      strRegEx = "([^\<]*?)((http|https):[\s\S]*?)(?=\>)"
      Set Matches = oLookup(strRegEx, oMessage.HeaderValue("List-Unsubscribe"), True)
      If Matches.Count > 0 Then
         For Each Match In Matches
            sURL = Trim(Match.Value)
            On Error Resume Next
            With CreateObject("MSXML2.ServerXMLHTTP.6.0")
               .setoption(2) = (.getoption(2) & " - SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS")
               .open "GET", sURL, False
               .setrequestheader "User-Agent", "online link validator (http://www.dead-links.com/)"
               .send ("")
            End With
            On Error Goto 0
            If (Err.Number <> 0) Then
               EventLog.Write( "ERROR: Sub Unsubscribe(oMessage)" )
               EventLog.Write( "Error       : " & Err.Number )
               EventLog.Write( "Error (hex) : 0x" & Hex(Err.Number) )
               EventLog.Write( "Source      : " & Err.Source )
               EventLog.Write( "Description : " & Err.Description )
               Err.Clear
               Exit Sub
            End If
         Next
      End If
   End If
End Sub

[palinka]

Cool. Thanks. I'll set it up tonight and keep an eye on the event log.

[palinka]

Wink wink, oh great and wise (and generous) master of the scripts.

Where is all the SPAM when you need it

I'll probably end up having to SPAM myself

Magic 8 ball says "Be Patient, Grasshopper"

[SorenR]

Cool. Thanks. I'll set it up tonight and keep an eye on the event log.

Still no SPAM with "mailto" links in them... They're all "http(s)"... Figures...

My test version have both "On Error Resume Next" to "On Error Goto 0" sections commented out and a lot of

Code: Select all

' <= debug
     EventLog.Write( "UNSUB: bla bla " & variable )
'    debug =>

throughout the code.

Just in case, you know... declaring war on Jotunheim... Heimdal is not exactly around to help

[palinka]

Just in case, you know... declaring war on Jotunheim... Heimdal is not exactly around to help

I'm always ready to declare war and I'm sometimes ready to prosecute it.

[SorenR]

Hmm... Bugs... Will... Return... After... Coffee... Break...

[SorenR]

c/Right/Mid/**

[palinka]

I'm going to have to tighten up SA rules to get anything triggered. I must take the advice of the magic 8 ball.

[palinka]

Got one! This is like fishing. You never know what you'll get.

But, I think its not working. This is 2 of the same marketing email addressed to two different users on different local domains.

awstats log:

Code: Select all

2018-08-06 15:21:26	jetblue.52783@envfrm.rsys5.com	recipient@mydomain-1.tld	199.7.204.138	127.0.0.1	SMTP	?	550	0
2018-08-06 15:21:26	jetblue.52783@envfrm.rsys5.com	recipient@mydomain-1.tld	199.7.204.138	127.0.0.1	SMTP	?	550	0
2018-08-06 15:21:27	wile.e.coyote@acme.inc	bscribe	127.0.0.1	127.0.0.1	SMTP	?	550	0
2018-08-06 15:21:27	wile.e.coyote@acme.inc	bscribe	127.0.0.1	127.0.0.1	SMTP	?	550	0
2018-08-06 15:22:29		wile.e.coyote@acme.inc	127.0.0.1	127.0.0.1	SMTP	?	550	0
2018-08-06 15:22:29		wile.e.coyote@acme.inc	127.0.0.1	127.0.0.1	SMTP	?	550	0
2018-08-06 15:22:30	jetblue.52783@envfrm.rsys5.com	spam@my-honeypot.tld	199.7.204.138	127.0.0.1	SMTP	?	250	99063
2018-08-06 15:22:31	wile.e.coyote@acme.inc	bscribe	127.0.0.1	127.0.0.1	SMTP	?	550	0
2018-08-06 15:22:31	wile.e.coyote@acme.inc	bscribe	127.0.0.1	127.0.0.1	SMTP	?	550	0
2018-08-06 15:23:08	jetblue.52783@envfrm.rsys5.com	user@my-other-domain.com	199.7.204.138	127.0.0.1	SMTP	?	550	0
2018-08-06 15:23:08	jetblue.52783@envfrm.rsys5.com	user@my-other-domain.com	199.7.204.138	127.0.0.1	SMTP	?	550	0
2018-08-06 15:23:08		wile.e.coyote@acme.inc	127.0.0.1	127.0.0.1	SMTP	?	550	0
2018-08-06 15:23:08		wile.e.coyote@acme.inc	127.0.0.1	127.0.0.1	SMTP	?	550	0
2018-08-06 15:23:08	wile.e.coyote@acme.inc	bscribe	127.0.0.1	127.0.0.1	SMTP	?	550	0
2018-08-06 15:23:08	wile.e.coyote@acme.inc	bscribe	127.0.0.1	127.0.0.1	SMTP	?	550	0
2018-08-06 15:24:11	jetblue.52783@envfrm.rsys5.com	spam@my-honeypot.tld	199.7.204.138	127.0.0.1	SMTP	?	250	98314
2018-08-06 15:24:11		wile.e.coyote@acme.inc	127.0.0.1	127.0.0.1	SMTP	?	550	0
2018-08-06 15:24:11		wile.e.coyote@acme.inc	127.0.0.1	127.0.0.1	SMTP	?	550	0
2018-08-06 15:24:11	wile.e.coyote@acme.inc	bscribe	127.0.0.1	127.0.0.1	SMTP	?	550	0
2018-08-06 15:24:11	wile.e.coyote@acme.inc	bscribe	127.0.0.1	127.0.0.1	SMTP	?	550	0
2018-08-06 15:25:14		wile.e.coyote@acme.inc	127.0.0.1	127.0.0.1	SMTP	?	550	0
2018-08-06 15:25:14		wile.e.coyote@acme.inc	127.0.0.1	127.0.0.1	SMTP	?	550	0

Plus, there was an error:

Code: Select all

"ERROR"	7320	"2018-08-06 15:22:29.317"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A0046 - Description: Permission denied - Line: 1668 Column: 3 - Code: (null)"

Which is this:

Code: Select all

			Set f = fs.opentextfile(fnl, ForWriting, true)

I can't make much sense of it, but I would guess that "bscribe" is not a valid email. Are you getting the same thing?

I just deleted all other scripts in EventHandlers.vbs, plus I changed wile.e.coyote to a valid email. I know that won't make a difference at this point, but maybe the event log will show something different.

[SorenR]

There are some bugs in the string handling. I belive my coffee levels were low at the time. The bugs are rookie mistakes

Anyways, I'll let it sit for today and see if there is anything else I have forgotten.

[palinka]

OK cool.

I got another spam with a list-unsubscribe (the attempt to mailto bounced with bad/partial address). Anyway, this appeared to be bona fide spam with a bogus list-unsubscribe address and SA correctly scored it very high as spam.

Therefore, I'm going to change my rule: if marked as spam AND score below delete threshold, THEN run function unsubscribe. That way it doesn't attempt to run on real spam that's going to be deleted anyway.

[SorenR]

Ok, try this...

Rule: Unsubscribe
Criteria:
Custom header field :: X-hMailServer-Reason-Score > 5
Action:
Set Header value :: X-hMailServer-Unsubscribe = 1:0
Run function :: Unsubscribe

1:0 = Do mailto check, but no url
0:1 = Do url check, but no mailto

If you don't add the header, both mailto and url wil be checked.

Code: Select all

Sub Unsubscribe(oMessage)
   Dim a, i, strRegEx, Match, Matches, sMailTo, sURL, doMail, doURL

   strRegEx = "^[0-1]:[0-1]$"
   If Lookup(strRegEx, oMessage.HeaderValue("X-hMailServer-Unsubscribe")) Then
      a = Split(oMessage.HeaderValue("X-hMailServer-Unsubscribe"), ":")
      doMail = a(0)
      doURL = a(1)
   Else
      doMail = True
      doURL = True
   End If

   If doMail Then
      strRegEx = "([^\<]*?)(mailto:[\s\S]*?)(?=\>)"
      Set Matches = oLookup(strRegEx, oMessage.HeaderValue("List-Unsubscribe"), True)
      If Matches.Count > 0 Then
         For Each Match In Matches
            sMailTo = Mid(Trim(Match.Value), 8)
            a = Split(sMailTo, "?")
            On Error Resume Next
            With CreateObject("hMailServer.Message")
               .From = "Wile E. Coyote"
               .FromAddress = "wile.e.coyote@acme.inc"
               If UBound(a) > 0 Then
                  .Subject = oMessage.Subject
               Else
                  .Subject = Replace(a(1), "subject=", "")
               End If
               .AddRecipient a(0), a(0)
               .Save
            End With
            On Error Goto 0
            If (Err.Number <> 0) Then
               EventLog.Write( "ERROR: Sub Unsubscribe(oMessage)" )
               EventLog.Write( "Error       : " & Err.Number )
               EventLog.Write( "Error (hex) : 0x" & Hex(Err.Number) )
               EventLog.Write( "Source      : " & Err.Source )
               EventLog.Write( "Description : " & Err.Description )
               Err.Clear
               Exit Sub
            End If
         Next
      End If
   End If

   If doURL Then
      strRegEx = "([^\<]*?)((http|https):[\s\S]*?)(?=\>)"
      Set Matches = oLookup(strRegEx, oMessage.HeaderValue("List-Unsubscribe"), True)
      If Matches.Count > 0 Then
         For Each Match In Matches
            sURL = Trim(Match.Value)
            On Error Resume Next
            With CreateObject("MSXML2.ServerXMLHTTP.6.0")
               .setoption(2) = (.getoption(2) & " - SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS")
               .open "GET", sURL, False
               .setrequestheader "User-Agent", "online link validator (http://www.dead-links.com/)"
               .send ("")
            End With
            On Error Goto 0
            If (Err.Number <> 0) Then
               EventLog.Write( "ERROR: Sub Unsubscribe(oMessage)" )
               EventLog.Write( "Error       : " & Err.Number )
               EventLog.Write( "Error (hex) : 0x" & Hex(Err.Number) )
               EventLog.Write( "Source      : " & Err.Source )
               EventLog.Write( "Description : " & Err.Description )
               Err.Clear
               Exit Sub
            End If
         Next
      End If
   End If

End Sub

[palinka]

Feels like Christmas morning! I can't wait to play with my new toy!

[palinka]

ah, shoot. I got one prospect right before enabling this. Maybe I'll get another one tomorrow.

[SorenR]

Remember I wrote I have the "acme.inc" domain on my server?

Code: Select all

"SMTPD"	3176	5308	"2018-08-11 13:27:49.328"	"192.64.237.189"	"RECEIVED: EHLO epic-a.sailthru.com"
"SMTPD"	3176	5308	"2018-08-11 13:28:09.094"	"192.64.237.189"	"SENT: 250-mx.mydomain.tld[nl]250 SIZE"
"SMTPD"	3176	5308	"2018-08-11 13:28:09.219"	"192.64.237.189"	"RECEIVED: MAIL FROM:<delivery_20180811112728.5b6ec820cdb7ec16e61fb3a7@mx.sailthru.com>"
"SMTPD"	3176	0	"2018-08-11 13:28:09.344"	"TCP"	"DNS lookup: 189.237.64.192.zen.spamhaus.org, 0 addresses found: (none), Match: False"
"SMTPD"	3176	0	"2018-08-11 13:28:09.906"	"TCP"	"DNS lookup: 189.237.64.192.b.barracudacentral.org, 0 addresses found: (none), Match: False"
"SMTPD"	3176	0	"2018-08-11 13:28:10.094"	"TCP"	"DNS lookup: 189.237.64.192.bl.spamcop.net, 1 addresses found: 127.0.0.2, Match: True"
"SMTPD"	3176	5308	"2018-08-11 13:28:10.234"	"192.64.237.189"	"SENT: 250 OK"
"SMTPD"	3176	5308	"2018-08-11 13:28:10.344"	"192.64.237.189"	"RECEIVED: RCPT TO:<benjamin@mydomain.tld>"
"SMTPD"	3176	5308	"2018-08-11 13:28:10.344"	"192.64.237.189"	"SENT: 250 OK"
"SMTPD"	3176	5308	"2018-08-11 13:28:10.469"	"192.64.237.189"	"RECEIVED: DATA"
"SMTPD"	3176	5308	"2018-08-11 13:28:30.109"	"192.64.237.189"	"SENT: 354 OK, send."
"SMTPD"	2328	5308	"2018-08-11 13:28:33.344"	"192.64.237.189"	"SENT: 250 Queued (3.172 seconds)"
"SMTPD"	568	5308	"2018-08-11 13:28:33.453"	"192.64.237.189"	"RECEIVED: QUIT"
"SMTPD"	568	5308	"2018-08-11 13:28:33.453"	"192.64.237.189"	"SENT: 221 goodbye"
"SMTPD"	3964	0	"2018-08-11 13:29:33.468"	"TCP"	"DNS - MX Lookup: mx.sailthru.com"
"SMTPD"	3964	0	"2018-08-11 13:29:33.577"	"TCP"	"DNS - MX Result: 2 IP addresses were found."
"SMTPC"	568	5310	"2018-08-11 13:29:33.827"	"173.228.155.173"	"RECEIVED: 220 nj1-hotwhite.flt ESMTP service ready"
"SMTPC"	568	5310	"2018-08-11 13:29:33.827"	"173.228.155.173"	"SENT: HELO mx.mydomain.tld"
"SMTPC"	568	5310	"2018-08-11 13:29:33.952"	"173.228.155.173"	"RECEIVED: 250 nj1-hotwhite.flt says hello"
"SMTPC"	568	5310	"2018-08-11 13:29:33.952"	"173.228.155.173"	"SENT: MAIL FROM:<wile.e.coyote@acme.inc>"
"SMTPC"	568	5310	"2018-08-11 13:29:34.077"	"173.228.155.173"	"RECEIVED: 250 2.1.0 MAIL ok"
"SMTPC"	568	5310	"2018-08-11 13:29:34.077"	"173.228.155.173"	"SENT: RCPT TO:<unsubscribe_20180811112728.5b6ec820cdb7ec16e61fb3a7@mx.sailthru.com>"
"SMTPC"	568	5310	"2018-08-11 13:29:34.202"	"173.228.155.173"	"RECEIVED: 250 2.1.5 <unsubscribe_20180811112728.5b6ec820cdb7ec16e61fb3a7@mx.sailthru.com> ok"
"SMTPC"	568	5310	"2018-08-11 13:29:34.202"	"173.228.155.173"	"SENT: DATA"
"SMTPC"	568	5310	"2018-08-11 13:29:34.311"	"173.228.155.173"	"RECEIVED: 354 send message"
"SMTPC"	568	5310	"2018-08-11 13:29:34.311"	"173.228.155.173"	"SENT: [nl]."
"SMTPC"	568	5310	"2018-08-11 13:29:34.608"	"173.228.155.173"	"RECEIVED: 250 2.6.0 message received"
"SMTPC"	568	5310	"2018-08-11 13:29:34.608"	"173.228.155.173"	"SENT: QUIT"
"SMTPC"	568	5310	"2018-08-11 13:29:34.733"	"173.228.155.173"	"RECEIVED: 221 2.0.0 nj1-hotwhite.flt says goodbye"

[palinka]

Nice!

I finally got one today too. But it didn't work.

Code: Select all

"DEBUG"	7588	"2018-08-11 15:29:51.186"	"Applying rules"
"DEBUG"	7588	"2018-08-11 15:29:51.186"	"Applying rule Unsubscribe"
"DEBUG"	7588	"2018-08-11 15:29:51.186"	"Performing rule action"
"DEBUG"	7588	"2018-08-11 15:29:51.201"	"Performing rule action"
"DEBUG"	7588	"2018-08-11 15:29:51.201"	"Executing event Unknown"
"ERROR"	7588	"2018-08-11 15:29:51.201"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01F4 - Description: Variable is undefined: 'Lookup' - Line: 38 Column: 3 - Code: (null)"
"DEBUG"	7588	"2018-08-11 15:29:51.201"	"Event completed"

Not sure what "event Unknown" is about. Right now this is the only script in eventhandler.vbs.

Line 38 is this:

Code: Select all

   If Lookup(strRegEx, oMessage.HeaderValue("X-hMailServer-Unsubscribe")) Then

Any idea what could be causing this?

[SorenR]

Ah, missing a function.

Code: Select all

Function Lookup(strRegEx, strMatch) : Lookup = False
   With CreateObject("VBScript.RegExp")
      .Pattern = strRegEx
      .Global = False
      .MultiLine = True
      .IgnoreCase = True
      If .Test(strMatch) Then Lookup = True
   End With
End Function

[palinka]

Thanks! Now it's a waiting game again.

It takes a while because my rule will only trigger on messages below the delete threshold. If it's truly spam, then why acknowledge a bona fide email address? Not many messages marked as spam qualify. It took 3 days I think to finally get the one yesterday.

A stupid byproduct of all this is that I check my spam account regularly. It's like fishing!

[palinka]

Ah, missing a function.

Code: Select all

Function Lookup(strRegEx, strMatch) : Lookup = False
   With CreateObject("VBScript.RegExp")
      .Pattern = strRegEx
      .Global = False
      .MultiLine = True
      .IgnoreCase = True
      If .Test(strMatch) Then Lookup = True
   End With
End Function

I got another HOT PROSPECT today! But it still failed.

Code: Select all

"DEBUG"	7280	"2018-08-13 13:36:13.186"	"Applying rule Unsubscribe"
"DEBUG"	7280	"2018-08-13 13:36:13.186"	"Performing rule action"
"DEBUG"	7280	"2018-08-13 13:36:13.186"	"Performing rule action"
"DEBUG"	7280	"2018-08-13 13:36:13.186"	"Executing event Unknown"
"ERROR"	7280	"2018-08-13 13:36:13.202"	"Script Error: Source: Microsoft VBScript runtime error - Error: 800A01F4 - Description: Variable is undefined: 'oLookup' - Line: 59 Column: 6 - Code: (null)"
"DEBUG"	7280	"2018-08-13 13:36:13.217"	"Event completed"

I added Function Lookup (per the quote) to EventHandlers.vbs ABOVE "Sub Unsubscribe" as you had shown in this post above in this thread.

The script error points to:

Code: Select all

      Set Matches = oLookup(strRegEx, oMessage.HeaderValue("List-Unsubscribe"), True)

WTF am I doing wrong? I'm THIS close to sorting this out with a nudge in the right direction. I know whatever it is is probably simple and almost punching me in the face.

Here is my full EventHandlers.vbs:

Code: Select all

option explicit

'   Sub OnClientConnect(oClient)
'   End Sub

'   Sub OnSMTPData(oClient, oMessage)
'   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(oFetchAccount, oMessage, sRemoteUID)
'   End Sub

Function Lookup(strRegEx, strMatch) : Lookup = False
   With CreateObject("VBScript.RegExp")
      .Pattern = strRegEx
      .Global = False
      .MultiLine = True
      .IgnoreCase = True
      If .Test(strMatch) Then Lookup = True
   End With
End Function

Sub Unsubscribe(oMessage)
   Dim a, i, strRegEx, Match, Matches, sMailTo, sURL, doMail, doURL

   strRegEx = "^[0-1]:[0-1]$"
   If Lookup(strRegEx, oMessage.HeaderValue("X-hMailServer-Unsubscribe")) Then
      a = Split(oMessage.HeaderValue("X-hMailServer-Unsubscribe"), ":")
      doMail = a(0)
      doURL = a(1)
   Else
      doMail = True
      doURL = True
   End If

   If doMail Then
      strRegEx = "([^\<]*?)(mailto:[\s\S]*?)(?=\>)"
      Set Matches = oLookup(strRegEx, oMessage.HeaderValue("List-Unsubscribe"), True)
      If Matches.Count > 0 Then
         For Each Match In Matches
            sMailTo = Mid(Trim(Match.Value), 8)
            a = Split(sMailTo, "?")
            On Error Resume Next
            With CreateObject("hMailServer.Message")
               .From = "Wile E. Coyote"
               .FromAddress = "wile.e.coyote@acme.inc"
               If UBound(a) > 0 Then
                  .Subject = oMessage.Subject
               Else
                  .Subject = Replace(a(1), "subject=", "")
               End If
               .AddRecipient a(0), a(0)
               .Save
            End With
            On Error Goto 0
            If (Err.Number <> 0) Then
               EventLog.Write( "ERROR: Sub Unsubscribe(oMessage)" )
               EventLog.Write( "Error       : " & Err.Number )
               EventLog.Write( "Error (hex) : 0x" & Hex(Err.Number) )
               EventLog.Write( "Source      : " & Err.Source )
               EventLog.Write( "Description : " & Err.Description )
               Err.Clear
               Exit Sub
            End If
         Next
      End If
   End If

   If doURL Then
      strRegEx = "([^\<]*?)((http|https):[\s\S]*?)(?=\>)"
      Set Matches = oLookup(strRegEx, oMessage.HeaderValue("List-Unsubscribe"), True)
      If Matches.Count > 0 Then
         For Each Match In Matches
            sURL = Trim(Match.Value)
            On Error Resume Next
            With CreateObject("MSXML2.ServerXMLHTTP.6.0")
               .setoption(2) = (.getoption(2) & " - SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS")
               .open "GET", sURL, False
               .setrequestheader "User-Agent", "online link validator (http://www.dead-links.com/)"
               .send ("")
            End With
            On Error Goto 0
            If (Err.Number <> 0) Then
               EventLog.Write( "ERROR: Sub Unsubscribe(oMessage)" )
               EventLog.Write( "Error       : " & Err.Number )
               EventLog.Write( "Error (hex) : 0x" & Hex(Err.Number) )
               EventLog.Write( "Source      : " & Err.Source )
               EventLog.Write( "Description : " & Err.Description )
               Err.Clear
               Exit Sub
            End If
         Next
      End If
   End If

End Sub

Could it be "Option Explicit"?

[palinka]

And it takes 3 days to test.

[SorenR]

Go back to my post on 05 Aug 2018, 21:28. There you'll find the function oLookup.

[palinka]

Go back to my post on 05 Aug 2018, 21:28. There you'll find the function oLookup.

That's what I did. See my posting of my entire EventHandlers.vbs above (posted yesterday).

And sorry for dragging you into this quagmire of scripting questions since my scripting skills are basically limited to copy and paste and your help is greatly appreciated.

Edit - I think it might be option explicit, so I removed it and we'll find out in 3 days if that was it.

[jimimaseye]

Go back to my post on 05 Aug 2018, 21:28. There you'll find the function oLookup.

That's what I did. See my posting of my entire EventHandlers.vbs above (posted yesterday).

And sorry for dragging you into this quagmire of scripting questions since my scripting skills are basically limited to copy and paste and your help is greatly appreciated.

Edit - I think it might be option explicit, so I removed it and we'll find out in 3 days if that was it.

Your eventhandlers doesnt have the olookup function. (You have 'lookup').

[palinka]

Your eventhandlers doesnt have the olookup function. (You have 'lookup').

See? It had to be the simplest of things, nearly slapping me in the face.

[jimimaseye]

The problem here is that there are 2 diffrent suites of scripts published by Soren in this thread and they have the same function repeated but named slightly different in each one:

Ah, missing a function.

Code: Select all

Function Lookup(strRegEx, strMatch) : Lookup = False
   With CreateObject("VBScript.RegExp")
      .Pattern = strRegEx
      .Global = False
      .MultiLine = True
      .IgnoreCase = True
      If .Test(strMatch) Then Lookup = True
   End With
End Function

and

Code: Select all

Function oLookup(strRegEx, strMatch, bGlobal)
   With CreateObject("VBScript.RegExp")
      .Pattern = strRegEx
      .Global = bGlobal
      .MultiLine = True
      .IgnoreCase = True
      Set oLookup = .Execute(strMatch)
   End With
End Function

[SorenR]

The "Lookup" function is pretty simple and will return True or False based on RegEx.

The "oLookup" will return an object containing first (or all) found instances based on RegEx AND the value of "bGlobal" (True or False)

So, f.eks. if I want to find (AND LIST) all IP Addresses in a text string I can use:

Code: Select all

Dim strRegEx, Match, Matches
strRegEx = "(?:[0-9]{1,3}\.){3}[0-9]{1,3}"
Set Matches = oLookup(strRegEx, text_string, True)
If Matches.Count > 0 Then
   For Each Match In Matches
      Do_Stuff_With(Match.Value)
   Next
End If

[jimimaseye]

See. Easy.

[palinka]

See. Easy.

Yeah... umm... EASY!

Lookup vs oLookup. I changed Lookup to oLookup because I thought it was a typo. Now its as clear as mud. But I think I finally have it. We'll see in a day or 2. Thanks for the help with this.

[SorenR]

See. Easy.

Easy peasy lemon squeezy

Not like my usual "selfadjusting" code...

Code: Select all

m_InitCOM = "oApp"
...
...
ExecuteGlobal "Option Explicit:" &_
              "Dim TempLogDirectory:" &_
              "TempLogDirectory = " & m_InitCOM & ".Settings.Directories.LogDirectory"
m_LogDirectory = TempLogDirectory

[palinka]

Ok, try this...

Rule: Unsubscribe
Criteria:
Custom header field :: X-hMailServer-Reason-Score > 5
Action:
Set Header value :: X-hMailServer-Unsubscribe = 1:0
Run function :: Unsubscribe

1:0 = Do mailto check, but no url
0:1 = Do url check, but no mailto

If you don't add the header, both mailto and url wil be checked.

Code: Select all

Sub Unsubscribe(oMessage)
   Dim a, i, strRegEx, Match, Matches, sMailTo, sURL, doMail, doURL

   strRegEx = "^[0-1]:[0-1]$"
   If Lookup(strRegEx, oMessage.HeaderValue("X-hMailServer-Unsubscribe")) Then
      a = Split(oMessage.HeaderValue("X-hMailServer-Unsubscribe"), ":")
      doMail = a(0)
      doURL = a(1)
   Else
      doMail = True
      doURL = True
   End If

   If doMail Then
      strRegEx = "([^\<]*?)(mailto:[\s\S]*?)(?=\>)"
      Set Matches = oLookup(strRegEx, oMessage.HeaderValue("List-Unsubscribe"), True)
      If Matches.Count > 0 Then
         For Each Match In Matches
            sMailTo = Mid(Trim(Match.Value), 8)
            a = Split(sMailTo, "?")
            On Error Resume Next
            With CreateObject("hMailServer.Message")
               .From = "Wile E. Coyote"
               .FromAddress = "wile.e.coyote@acme.inc"
               If UBound(a) > 0 Then
                  .Subject = oMessage.Subject
               Else
                  .Subject = Replace(a(1), "subject=", "")
               End If
               .AddRecipient a(0), a(0)
               .Save
            End With
            On Error Goto 0
            If (Err.Number <> 0) Then
               EventLog.Write( "ERROR: Sub Unsubscribe(oMessage)" )
               EventLog.Write( "Error       : " & Err.Number )
               EventLog.Write( "Error (hex) : 0x" & Hex(Err.Number) )
               EventLog.Write( "Source      : " & Err.Source )
               EventLog.Write( "Description : " & Err.Description )
               Err.Clear
               Exit Sub
            End If
         Next
      End If
   End If

   If doURL Then
      strRegEx = "([^\<]*?)((http|https):[\s\S]*?)(?=\>)"
      Set Matches = oLookup(strRegEx, oMessage.HeaderValue("List-Unsubscribe"), True)
      If Matches.Count > 0 Then
         For Each Match In Matches
            sURL = Trim(Match.Value)
            On Error Resume Next
            With CreateObject("MSXML2.ServerXMLHTTP.6.0")
               .setoption(2) = (.getoption(2) & " - SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS")
               .open "GET", sURL, False
               .setrequestheader "User-Agent", "online link validator (http://www.dead-links.com/)"
               .send ("")
            End With
            On Error Goto 0
            If (Err.Number <> 0) Then
               EventLog.Write( "ERROR: Sub Unsubscribe(oMessage)" )
               EventLog.Write( "Error       : " & Err.Number )
               EventLog.Write( "Error (hex) : 0x" & Hex(Err.Number) )
               EventLog.Write( "Source      : " & Err.Source )
               EventLog.Write( "Description : " & Err.Description )
               Err.Clear
               Exit Sub
            End If
         Next
      End If
   End If

End Sub

I got another match and another fail.

From above:

If Lookup(strRegEx, oMessage.HeaderValue("X-hMailServer-Unsubscribe")) Then

Is this supposed to be "oLookup"?

I'm using this as function:

Code: Select all

Function oLookup(strRegEx, strMatch, bGlobal)
   With CreateObject("VBScript.RegExp")
      .Pattern = strRegEx
      .Global = bGlobal
      .MultiLine = True
      .IgnoreCase = True
      Set oLookup = .Execute(strMatch)
   End With
End Function

Help me obi wan, you're my only hope!

[jimimaseye]

You need both the oLookup and the Lookup functions in your eventhandlers.vbs

[palinka]

You need both the oLookup and the Lookup functions in your eventhandlers.vbs

Understando, friendo.

[SorenR]

The version I use (including both functions) ... Contains logging to "hmailserver_events.log".

Code: Select all

Function Lookup(strRegEx, strMatch) : Lookup = False
   With CreateObject("VBScript.RegExp")
      .Pattern = strRegEx
      .Global = False
      .MultiLine = True
      .IgnoreCase = True
      If .Test(strMatch) Then Lookup = True
   End With
End Function

Function oLookup(strRegEx, strMatch, bGlobal)
   With CreateObject("VBScript.RegExp")
      .Pattern = strRegEx
      .Global = bGlobal
      .MultiLine = True
      .IgnoreCase = True
      Set oLookup = .Execute(strMatch)
   End With
End Function

Sub Unsubscribe(oMessage)

' <== debug
      EventLog.Write( "UNSUB: Function called" )
'     debug ==>

   Dim a, i, strRegEx, Match, Matches, sMailTo, sURL, doMail, doURL
   strRegEx = "^[0-1]:[0-1]$"
   If Lookup(strRegEx, oMessage.HeaderValue("X-hMailServer-Unsubscribe")) Then
      a = Split(oMessage.HeaderValue("X-hMailServer-Unsubscribe"), ":")
      doMail = a(0)
      doURL = a(1)
   Else
      doMail = True
      doURL = True
   End If
   If doMail Then
      strRegEx = "([^\<]*?)(mailto:[\s\S]*?)(?=\>)"
      Set Matches = oLookup(strRegEx, oMessage.HeaderValue("List-Unsubscribe"), True)
      If Matches.Count > 0 Then
         For Each Match In Matches

' <== debug
      EventLog.Write( "UNSUB: Match = " & Match )
'     debug ==>

            sMailTo = Mid(Trim(Match.Value), 8)

' <== debug
      EventLog.Write( "UNSUB: sMailTo = " & sMailTo )
'     debug ==>

            a = Split(sMailTo, "?")

' <== debug
      For i = 0 To UBound(a)
         EventLog.Write( "UNSUB: a(" & i & ") = " & a(i) )
      Next
'     debug ==>

            On Error Resume Next
            With CreateObject("hMailServer.Message")
               .From = "Wile E. Coyote"
               .FromAddress = "wile.e.coyote@acme.inc"
               If UBound(a) > 0 Then
                  .Subject = oMessage.Subject
               Else
                  .Subject = Replace(a(1), "subject=", "")
               End If
               .AddRecipient a(0), a(0)

' <== debug
'     .Body = "X5O!P%@AP" & "[4\PZX54(P^)7CC)7}$" & "EICAR-STANDARD-ANTIVIRUS-TEST-FILE" & "!$H+H*"
'     debug ==>

               .Save
            End With
            On Error Goto 0
            If (Err.Number <> 0) Then
               EventLog.Write( "ERROR: Sub Unsubscribe(oMessage)" )
               EventLog.Write( "Error       : " & Err.Number )
               EventLog.Write( "Error (hex) : 0x" & Hex(Err.Number) )
               EventLog.Write( "Source      : " & Err.Source )
               EventLog.Write( "Description : " & Err.Description )
               Err.Clear
               Exit Sub
            End If

' <== debug
      If UBound(a) > 0 Then
         EventLog.Write( "UNSUB: .Subject = " & Replace(a(1), "subject=", "") )
      End If
      EventLog.Write( "UNSUB: .AddRecipient " & a(0) & ", " & a(0) )
'     debug ==>

         Next
      End If
   End If
   If doURL Then
      strRegEx = "([^\<]*?)((http|https):[\s\S]*?)(?=\>)"
      Set Matches = oLookup(strRegEx, oMessage.HeaderValue("List-Unsubscribe"), True)
      If Matches.Count > 0 Then
         For Each Match In Matches
            sURL = Trim(Match.Value)

' <== debug
      EventLog.Write( "UNSUB: sURL = " & sURL )
'     debug ==>

            On Error Resume Next
            With CreateObject("MSXML2.ServerXMLHTTP.6.0")
               .setoption(2) = (.getoption(2) & " - SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS")
               .open "GET", sURL, False
               .setrequestheader "User-Agent", "online link validator (http://www.dead-links.com/)"
               .send ("")
            End With
            On Error Goto 0
            If (Err.Number <> 0) Then
               EventLog.Write( "ERROR: Sub Unsubscribe(oMessage)" )
               EventLog.Write( "Error       : " & Err.Number )
               EventLog.Write( "Error (hex) : 0x" & Hex(Err.Number) )
               EventLog.Write( "Source      : " & Err.Source )
               EventLog.Write( "Description : " & Err.Description )
               Err.Clear
               Exit Sub
            End If
         Next
      End If
   End If
End Sub

[palinka]

See? Easy peasy!

Thank you! You are a gentleman and a scholar.

[palinka]

Another match, another fail, but this time not due to the script not working.

550 unable to verify sender address

My relay (I'm on a residential IP) rejected wile e coyote. That poor guy never wins. So I will change the send to a real address. Looks good finally. The fog has lifted.

By the way, the message being tested on is from Pinterest. Spamcop rejects their IP which is why it got marked as spam by HMS. Spamassassin score was -11. Go figure.

[palinka]

Code: Select all

2018-08-16 19:01:41	spam@mydomain.tld	unsubscribe-mc.us2_a17b9eba794a6c40b3ed4be00.d1f766c1e2-f531b4d44a@mailin.mcsv.net	127.0.0.1	mail.smtp2go.com	SMTP	?	250	418

AWStats log for first bona fide strike. Log shows at least one other since then. Taking back the internet one message at a time.

[SorenR]

https://www.youtube.com/watch?v=Dceyy0cX6J4

[jimimaseye]

Thats why the 'auto-reply' was invented and included in to RFC's I guess.

[palinka]

That guy was funny. I might do that and post the results here if its funny.

[SorenR]

Well... This is what some may call "a rough sketch"... It may evolve into a functioning routine or it may silently die here.

Code: Select all

'******************************************************************************************************************************
'********** hMailServer Case number Code                                                                             **********
'******************************************************************************************************************************

' If CheckCaseNum(oMessage.From) Then
'    EventLog.Write( "Got one :-)" )
' Else
'    EventLog.Write( "Oops, something went wrong :-(" )
' End If

Private Const CaseNumDB = "C:\hMailServer\Temp\casenum.db3"

Function CreateCaseNumDB(sDB)
   Dim oConn
   Set oConn = CreateObject("ADODB.Connection")
   oConn.Open "DRIVER={SQLite3 ODBC Driver};Database="& sDB & ";LongNames=0;Timeout=1000;NoTXN=0;SyncPragma=NORMAL;StepAPI=0;"
   oConn.Execute "CREATE TABLE casenum (" &_
                   "id        INTEGER       PRIMARY KEY AUTOINCREMENT," &_
                   "timestamp DATETIME," &_
                   "address   VARCHAR (192) UNIQUE," &_
                   "count     INTEGER" &_
                 ");"
   oConn.Close
End Function

Function CheckCaseNum(sAddress) : CheckCaseNum = False
   Dim oConn, oRecord, CaseNum, a
   With LockFile("c:\hmailserver\temp\casenum.lck")
      On Error Resume Next
      Set oConn = CreateObject("ADODB.Connection")
      oConn.Open "DRIVER={SQLite3 ODBC Driver};Database="& CaseNumDB & ";LongNames=0;Timeout=1000;NoTXN=0;SyncPragma=NORMAL;StepAPI=0;"
      Set oRecord = oConn.Execute("SELECT * FROM casenum WHERE address='" & sAddress & "';")
      If (Err.Number = 0) Then
         If Not oRecord.EOF Then
            ' Address is known - bump counter
            CaseNum = Right("0000000" & (oRecord("casenum") + 1), 8)
            oConn.Execute "UPDATE casenum SET count=(count+1),timestamp=DATETIME('NOW','LOCALTIME') WHERE address='" & sAddress & "';"
         Else
            CaseNum = "00000001"
            ' Address is NEW!
            ' FYI: Small trick to bypass error from UNIQUE constraint on address. Needed to compensate for multiple concurrent connects.
            oConn.Execute "INSERT OR IGNORE INTO casenum (timestamp,address,count) VALUES (DATETIME('NOW','LOCALTIME'),'" & sAddress & "'," & 0 & ");"
            oConn.Execute "UPDATE casenum SET count=(count+1),timestamp=DATETIME('NOW','LOCALTIME') WHERE address='" & sAddress & "';"
         End If
         a = Split(Replace(sAddress, ">", ""), "<")
         With CreateObject("hMailServer.Message")
            .From = "Wile E. Coyote"
            .FromAddress = "wile.e.coyote@acme.inc"
            .Subject = "Your email report."
            .AddRecipient a(0), a(1)
            .Body = vbCrLf &_
                    vbCrLf &_
                    "Thank you for contacting us." & vbCrLf &_
                    "We have opened a case for your issue, the case number is: " & CaseNum & "." & vbCrLf &_
                    vbCrLf &_
                    "We will be contacting you if we need further information." & vbCrLf &_
                    "If you would like to check on the status of your ticket, please contact the Client Support team." & vbCrLf &_
                    vbCrLf &_
                    vbCrLf &_
                    "Thank You." & vbCrLf
            .Save
         End With
         oRecord.Close
         oConn.Close
         CheckCaseNum = True
         On Error Goto 0
      Else
         On Error Goto 0
         ' OOPS No database !
         CreateCaseNumDB(CaseNumDB)
      End If
      .Close
   End With
End Function