'   Sub OnClientConnect(oClient)
'   End Sub

'   Sub OnAcceptMessage(oClient, oMessage)
'   End Sub

'   Sub OnDeliverMessage(oMessage)
'   End Sub

'   Sub OnBackupFailed(sReason)
'   End Sub

'   Sub OnBackupCompleted()
'   End Sub

' (SS,5/10/07)
Sub ProcessGoogleCheckout(oMessage)
	' (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  
  LBody = LBody + "Callback Content = " & GetWebPageContents(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,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
  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,8/6/07) returns contents of given URL, used to send HTML emails, AURL can contain querystring
Function GetWebPageContents(AURL, APostData)
  Const Request_POST = 1
  Const Request_GET = 2
  Dim objTear, strContents

  Set objTear = CreateObject("SOFTWING.ASPtear")
  On Error Resume Next
  strContents = objTear.Retrieve(AURL, Request_POST, APostData, "", "")

  If Err.Number <> 0 Then
     Response.Write "<b>"
     If Err.Number >= 400 Then
        Response.Write "Server returned error: " & Err.Number
     Else
        Response.Write "Component/WinInet error: " & Err.Description
     End If
     Response.Write "</b>"
     Response.End
  End If
  GetWebPageContents = strContents
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

' (SS,22/11/07)
Sub AddLog(AMessage)
	Dim fs, f
	Set fs = CreateObject("Scripting.FileSystemObject")
	Set f = fs.OpenTextFile("D:\hMailServer\Logs\eventlog.txt", 8, True)
	f.WriteLine(Now & " - " & AMessage)
	f.Close
	Set f = Nothing
	Set fs = Nothing
End Sub