Aliases when only allowing to send from your own account

This section contains scripts that hMailServer has contributed with. hMailServer 5 is needed to use these.
Post Reply
User avatar
Spyd
Normal user
Normal user
Posts: 43
Joined: 2008-02-19 10:15
Location: Barcelona, Spain
Contact:

Aliases when only allowing to send from your own account

Post by Spyd » 2014-01-29 18:32

This script lets you send a message using your own account, any of your aliases, and any of your domain aliases, and disallows you from sending using a non existing combination of account, alias or domain alias.
I have tested it with all the possible allowed permutations (account@domain, alias@domain, account@alias, alias@alias), and all the not allowed (false@domain, false@alias, account@false, alias@false). It also checks if you're trying to use an alias that exists but doesn't belong to your account.
As the code isn't commented, I leave the code with debug logging (makes reading the code easier), further down there is the same code without logging.

Known Limitations:
  • If you try to send using an alias that doesn't link to your account (f.e. links to another alias), this script won't let you send email using this alias.
Instructions:
  • Copy the FINAL code
  • Paste it in the EventHandlers.vbs file
  • Replace the ******** with your administration password
  • Replace the Result.Message message (optional)
DEBUG code

Code: Select all

Sub OnAcceptMessage(oClient, oMessage)

  On Error Resume Next
  If oClient.Username <> "" Then
    If LCase(oClient.Username) <> LCase(oMessage.FromAddress) Then
      EventLog.Write("") 'DEBUG
      EventLog.Write("") 'DEBUG
      EventLog.Write("Username <> From Address -> " + oClient.Username + " <> " + oMessage.FromAddress) 'DEBUG
      Dim obBaseApp
      Set obBaseApp = CreateObject("hMailServer.Application")
      Call obBaseApp.Authenticate("Administrator","***************") 'PUT HERE YOUR PASSWORD
      EventLog.Write("Past Athentication") 'DEBUG

      StrClientDomain = Mid(oClient.Username,InStr(oClient.Username,"@") + 1)
      StrFromDomain = Mid(oMessage.FromAddress,InStr(oMessage.FromAddress,"@") + 1) 
      EventLog.Write("ClientDomain: " + StrClientDomain + " - FromDomain: " + StrFromDomain) 'DEBUG
      
      Dim obDomain 
      Set obDomain = obBaseApp.Domains.ItemByName(StrClientDomain) 
      EventLog.Write("Domain object loaded: " + obDomain.Name) 'DEBUG

      Dim obAliases
      Dim obAlias
      AliasFound = False
      If LCase(StrClientDomain) <> LCase(StrFromDomain) Then
        EventLog.Write("Domains do not match, looking for domain aliases...") 'DEBUG
        Set obAliases = obDomain.DomainAliases
        For iAliases = 0 To (obAliases.Count - 1)
          Set obAlias = obAliases.Item(iAliases)
          EventLog.Write("Checking Domain Alias " + CStr(iAliases) + ": " + obAlias.AliasName) 'DEBUG
          if LCase(obAlias.AliasName) = LCase(StrFromDomain) Then
            AliasFound = True
            EventLog.Write("Domain Alias Found!") 'DEBUG
            Exit For
          End If
        Next
        If AliasFound Then
          StrFromAddress = Left(oMessage.FromAddress, Len(oMessage.FromAddress) - Len(StrFromDomain)) + StrClientDomain 
        End If
      Else 
        StrFromAddress = oMessage.FromAddress
        AliasFound = True
      End If
      
      If LCase(oClient.Username) <> LCase(StrFromAddress) Then
        If AliasFound Then
          Set obAliases = obDomain.Aliases
          EventLog.Write("Aliases object loaded. Aliases count: " + CStr(obAliases.Count)) 'DEBUG

          AliasFound = False
          For iAliases = 0 To (obAliases.Count - 1)
            Set obAlias = obAliases.Item(iAliases)
            EventLog.Write("Checking Alias " + CStr(iAliases) + ": " + obAlias.Name) 'DEBUG
            if (obAlias.Active) And (LCase(obAlias.Name) = LCase(StrFromAddress)) And (LCase(obAlias.Value) = LCase(oClient.UserName)) Then
              AliasFound = True
              EventLog.Write("Alias Found!") 'DEBUG
              Exit For
            End If 
          Next
        End If

        If Not AliasFound Then
          EventLog.Write("Alias NOT Found!") 'DEBUG
          Result.Value = 2
          Result.Message = "Solo se permite enviar correos desde tu propia cuenta o un alias que pertenezca a tu cuenta. - You are only allowed to send from your own account or any of its aliases."
        End If
      End If
    End If
  End If   

End Sub
FINAL code

Code: Select all

Sub OnAcceptMessage(oClient, oMessage)

  On Error Resume Next
  If oClient.Username <> "" Then
    If LCase(oClient.Username) <> LCase(oMessage.FromAddress) Then
      Dim obBaseApp
      Set obBaseApp = CreateObject("hMailServer.Application")
      Call obBaseApp.Authenticate("Administrator","***************") 'PUT HERE YOUR PASSWORD

      StrClientDomain = Mid(oClient.Username,InStr(oClient.Username,"@") + 1)
      StrFromDomain = Mid(oMessage.FromAddress,InStr(oMessage.FromAddress,"@") + 1) 
      
      Dim obDomain 
      Set obDomain = obBaseApp.Domains.ItemByName(StrClientDomain) 

      Dim obAliases
      Dim obAlias
      AliasFound = False
      If LCase(StrClientDomain) <> LCase(StrFromDomain) Then
        Set obAliases = obDomain.DomainAliases
        For iAliases = 0 To (obAliases.Count - 1)
          Set obAlias = obAliases.Item(iAliases)
          if LCase(obAlias.AliasName) = LCase(StrFromDomain) Then
            AliasFound = True
            Exit For
          End If
        Next
        If AliasFound Then
          StrFromAddress = Left(oMessage.FromAddress, Len(oMessage.FromAddress) - Len(StrFromDomain)) + StrClientDomain 
        End If
      Else 
        StrFromAddress = oMessage.FromAddress
        AliasFound = True
      End If
      
      If LCase(oClient.Username) <> LCase(StrFromAddress) Then
        If AliasFound Then
          Set obAliases = obDomain.Aliases

          AliasFound = False
          For iAliases = 0 To (obAliases.Count - 1)
            Set obAlias = obAliases.Item(iAliases)
            if (obAlias.Active) And (LCase(obAlias.Name) = LCase(StrFromAddress)) And (LCase(obAlias.Value) = LCase(oClient.UserName)) Then
              AliasFound = True
              Exit For
            End If 
          Next
        End If

        If Not AliasFound Then
          Result.Value = 2
          Result.Message = "Solo se permite enviar correos desde tu propia cuenta o un alias que pertenezca a tu cuenta. - You are only allowed to send from your own account or any of its aliases."
        End If
      End If
    End If
  End If   

End Sub

User avatar
mattg
Moderator
Moderator
Posts: 20003
Joined: 2007-06-14 05:12
Location: 'The Outback' Australia

Re: Aliases when only allowing to send from your own account

Post by mattg » 2014-01-30 00:14

thanks for sharing
Just 'cause I link to a page and say little else doesn't mean I am not being nice.
https://www.hmailserver.com/documentation

Bill48105
Developer
Developer
Posts: 6189
Joined: 2010-04-24 23:16
Location: Michigan, USA

Re: Aliases when only allowing to send from your own account

Post by Bill48105 » 2014-01-30 04:17

mattg wrote:thanks for sharing
+1
Very cool Spyd you beat me to it! I had this on my todo :) It might be nice to allow from that's not an alias (such as when the user has another domain or secondary domains etc) but suspect it'd require config file or secondary table & manual db queries to accomplish. Luckily for aliases on same domain COM can be used to just loop thru them.

Might be a good idea to check that to/from are not "" (like when address is <>) to avoid issues with mid & instr but also to skip some code in that case.
Bill
hMailServer build LIVE on my servers: 5.4-B2014050402
#hmailserver on FreeNode IRC https://webchat.freenode.net/?channels=#hmailserver
*** ABSENT FROM hMail! Those in IRC know how to find me if urgent. ***

User avatar
Spyd
Normal user
Normal user
Posts: 43
Joined: 2008-02-19 10:15
Location: Barcelona, Spain
Contact:

Re: Aliases when only allowing to send from your own account

Post by Spyd » 2014-01-30 13:42

Bill48105 wrote:Might be a good idea to check that to/from are not "" (like when address is <>) to avoid issues with mid & instr but also to skip some code in that case.
Bill
Can't test it, because Outlook won't let me set up an account with an invalid address, but it should work.

Known limitations:
  • If you try to send using an alias that doesn't link to your account (f.e. links to another alias), this script won't let you send email using this alias.
  • Valid address check is basic and can be fooled, but think is enough as it is.

Code: Select all

Sub OnAcceptMessage(oClient, oMessage)

  On Error Resume Next
  If oClient.Username <> "" Then
    StrFromAddress = oMessage.FromAddress 
    If LCase(oClient.Username) <> LCase(StrFromAddress) Then
      AliasFound = False
      If (InStr(StrFromAddress,"@") > 1) And (InStr(StrFromAddress,".") > 3) And (Len(StrFromAddress) > 5) Then
        Dim obBaseApp
        Set obBaseApp = CreateObject("hMailServer.Application")
        Call obBaseApp.Authenticate("Administrator","***************")

        StrClientDomain = Mid(oClient.Username,InStr(oClient.Username,"@") + 1)
        StrFromDomain = Mid(StrFromAddress,InStr(StrFromAddress,"@") + 1) 
      
        Dim obDomain 
        Set obDomain = obBaseApp.Domains.ItemByName(StrClientDomain) 

        Dim obAliases
        Dim obAlias
        If LCase(StrClientDomain) <> LCase(StrFromDomain) Then
          Set obAliases = obDomain.DomainAliases
          For iAliases = 0 To (obAliases.Count - 1)
            Set obAlias = obAliases.Item(iAliases)
            if LCase(obAlias.AliasName) = LCase(StrFromDomain) Then
              AliasFound = True
              Exit For
            End If
          Next
          If AliasFound Then
            StrFromAddress = Left(StrFromAddress, Len(StrFromAddress) - Len(StrFromDomain)) + StrClientDomain 
          End If
        Else 
          AliasFound = True
        End If
      End If
      
      If LCase(oClient.Username) <> LCase(StrFromAddress) Then
        If AliasFound Then
          Set obAliases = obDomain.Aliases

          AliasFound = False
          For iAliases = 0 To (obAliases.Count - 1)
            Set obAlias = obAliases.Item(iAliases)
            if (obAlias.Active) And (LCase(obAlias.Name) = LCase(StrFromAddress)) And (LCase(obAlias.Value) = LCase(oClient.UserName)) Then
              AliasFound = True
              Exit For
            End If 
          Next
        End If

        If Not AliasFound Then
          Result.Value = 2
          Result.Message = "Solo se permite enviar correos desde tu propia cuenta o un alias que pertenezca a tu cuenta. - You are only allowed to send from your own account or any of its aliases."
        End If
      End If
    End If
  End If   

End Sub

Bill48105
Developer
Developer
Posts: 6189
Joined: 2010-04-24 23:16
Location: Michigan, USA

Re: Aliases when only allowing to send from your own account

Post by Bill48105 » 2014-01-30 16:46

Cool thx. Thing is no need to complicate it that much as hmail validates the email address (there's even an INI setting to adjust if you want) but "" (empty) is possible due to <> return address & bounces.

Code: Select all

If (InStr(StrFromAddress,"@") > 1) And (InStr(StrFromAddress,".") > 3) And (Len(StrFromAddress) > 5) Then
to

Code: Select all

If StrFromAddress <> "" Then
Or just use the original version & change one of the earlier If's.

Btw I'd need to check but I am pretty sure hmail rejects mail from <> if FROM is not local even if AUTH'd but if not the new version could have a hole in it and should be altered to block from = "" & AUTH'd to close that hole rather than skipping the checks completely.

Not nit-picking just clarifying what to look for & trying to help out.
Bill
hMailServer build LIVE on my servers: 5.4-B2014050402
#hmailserver on FreeNode IRC https://webchat.freenode.net/?channels=#hmailserver
*** ABSENT FROM hMail! Those in IRC know how to find me if urgent. ***

Post Reply