MassMailer/tools/common.vbs

' Shared configuration code for 32-bit and 64-bit Windows Script Host.
Option Explicit

Function ProjectRoot()
    Dim fs
    Set fs = CreateObject("Scripting.FileSystemObject")
    ProjectRoot = fs.GetParentFolderName(fs.GetParentFolderName(WScript.ScriptFullName))
End Function

Function ConfigFilePath()
    Dim fs
    Set fs = CreateObject("Scripting.FileSystemObject")
    ConfigFilePath = fs.BuildPath(ProjectRoot(), "config.ini")
End Function

Function LoadConfig(configPath)
    Dim fs, stream, content, lines, line, equalAt, key, value, settings, i
    Set fs = CreateObject("Scripting.FileSystemObject")
    If Not fs.FileExists(configPath) Then
        Err.Raise vbObjectError + 1001, "MassMailer config", _
            "Missing config.ini. Copy config.example.ini to config.ini and edit it."
    End If

    Set stream = CreateObject("ADODB.Stream")
    stream.Type = 2
    stream.Charset = "utf-8"
    stream.Open
    stream.LoadFromFile configPath
    content = stream.ReadText
    stream.Close
    If Len(content) > 0 Then
        If Left(content, 1) = ChrW(&HFEFF) Then content = Mid(content, 2)
    End If

    Set settings = CreateObject("Scripting.Dictionary")
    settings.CompareMode = 1
    lines = Split(Replace(Replace(content, vbCrLf, vbLf), vbCr, vbLf), vbLf)
    For i = 0 To UBound(lines)
        line = Trim(lines(i))
        If Len(line) > 0 Then
            If Left(line, 1) <> "#" And Left(line, 1) <> ";" Then
                equalAt = InStr(line, "=")
                If equalAt < 2 Then ConfigError "Invalid setting at line " & (i + 1)
                key = UCase(Trim(Left(line, equalAt - 1)))
                value = Trim(Mid(line, equalAt + 1))
                If Not IsAllowedKey(key) Then ConfigError "Unknown setting: " & key
                If settings.Exists(key) Then ConfigError "Duplicate setting: " & key
                settings.Add key, value
            End If
        End If
    Next

    ValidateConfig settings
    Set LoadConfig = settings
End Function

Sub ConfigError(message)
    Err.Raise vbObjectError + 1002, "MassMailer config", message
End Sub

Function IsAllowedKey(key)
    Dim name
    IsAllowedKey = False
    For Each name In Array("SMTP_HOST", "SMTP_PORT", "SMTP_USER", "SMTP_TLS", _
        "SMTP_STARTTLS", "SMTP_FROM", "SMTP_REPLY_TO", "SMTP_TEST_TO", "SMTP_SECRET_ID", _
        "DB_PATH", "DB_PROVIDER", "DB_BITNESS", "QUEUE_INTERVAL", _
        "SEND_MODE", "DISPLAY_TIME_ZONE", "TEMPLATE_ROOT", _
        "TEMPLATE_IMAGE_MODE", "TEMPLATE_IMAGE_TYPES", _
        "TEMPLATE_IMAGE_MAX_BYTES", "TEMPLATE_MESSAGE_MAX_BYTES", _
        "OPT_OUT_REVIEW_HOURS", "BUSINESS_POSTAL_ADDRESS", "REPORT_DIR", "BACKUP_DIR")
        If key = name Then IsAllowedKey = True: Exit Function
    Next
End Function

Sub ValidateConfig(settings)
    Dim name
    For Each name In Array("SMTP_HOST", "SMTP_PORT", "SMTP_USER", "SMTP_TLS", _
        "SMTP_STARTTLS", "SMTP_FROM", "SMTP_REPLY_TO", "SMTP_SECRET_ID", _
        "DB_PATH", "DB_PROVIDER", "DB_BITNESS", "QUEUE_INTERVAL", _
        "SEND_MODE", "DISPLAY_TIME_ZONE", "TEMPLATE_ROOT", _
        "TEMPLATE_IMAGE_MODE", "TEMPLATE_IMAGE_TYPES", _
        "TEMPLATE_IMAGE_MAX_BYTES", "TEMPLATE_MESSAGE_MAX_BYTES", _
        "OPT_OUT_REVIEW_HOURS", "BUSINESS_POSTAL_ADDRESS")
        If Not settings.Exists(name) Then ConfigError "Missing setting: " & name
        If name <> "BUSINESS_POSTAL_ADDRESS" Then
            If Len(settings(name)) = 0 Then ConfigError "Empty setting: " & name
        End If
    Next

    CheckWholeNumber settings, "SMTP_PORT", 1, 65535
    CheckWholeNumber settings, "QUEUE_INTERVAL", 60, 86400
    CheckWholeNumber settings, "TEMPLATE_IMAGE_MAX_BYTES", 1, 10485760
    CheckWholeNumber settings, "TEMPLATE_MESSAGE_MAX_BYTES", 1, 52428800
    CheckWholeNumber settings, "OPT_OUT_REVIEW_HOURS", 1, 168
    If CLng(settings("TEMPLATE_IMAGE_MAX_BYTES")) > CLng(settings("TEMPLATE_MESSAGE_MAX_BYTES")) Then
        ConfigError "Image limit exceeds message limit"
    End If
    If LCase(settings("SMTP_TLS")) <> "on" Or LCase(settings("SMTP_STARTTLS")) <> "on" Then
        ConfigError "SMTP_TLS and SMTP_STARTTLS must both be on"
    End If
    If LCase(settings("DB_BITNESS")) <> "x86" And LCase(settings("DB_BITNESS")) <> "x64" Then
        ConfigError "DB_BITNESS must be x86 or x64"
    End If
    Select Case LCase(settings("DB_PROVIDER"))
        Case "microsoft.jet.oledb.4.0", "microsoft.ace.oledb.12.0", "microsoft.ace.oledb.16.0"
        Case Else: ConfigError "Unsupported DB_PROVIDER"
    End Select
    If LCase(settings("SEND_MODE")) <> "always" Then ConfigError "SEND_MODE must be always"
    If LCase(settings("DISPLAY_TIME_ZONE")) <> "local" Then ConfigError "DISPLAY_TIME_ZONE must be local"
    If LCase(settings("TEMPLATE_IMAGE_MODE")) <> "inline_cid" Then ConfigError "TEMPLATE_IMAGE_MODE must be inline_cid"
End Sub

Sub CheckWholeNumber(settings, name, minimum, maximum)
    Dim re, value
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "^[0-9]+$"
    If Not re.Test(settings(name)) Then ConfigError name & " must be a whole number"
    If Len(settings(name)) > 10 Then ConfigError name & " is too large"
    value = CDbl(settings(name))
    If value < minimum Or value > maximum Then
        ConfigError name & " must be between " & minimum & " and " & maximum
    End If
End Sub

Function ResolveDbPath(settings)
    Dim fs, path
    Set fs = CreateObject("Scripting.FileSystemObject")
    path = settings("DB_PATH")
    If Left(path, 2) = "\\" Then ConfigError "DB_PATH must be on a local drive"
    If fs.GetDriveName(path) = "" Then path = fs.BuildPath(ProjectRoot(), path)
    path = fs.GetAbsolutePathName(path)
    If LCase(fs.GetExtensionName(path)) <> "mdb" Then ConfigError "DB_PATH must end in .mdb"
    ResolveDbPath = path
End Function