Attribute VB_Name = "ArmREST"
Option Explicit

Private ms_authToken As String         ' authorization string

Public mo_ScriptEngine As ScriptControl

Public ms_Exception As String

Public Sub Load_A_COM()
On Error GoTo ErrorHandler

    If mo_ScriptEngine Is Nothing Then

        Set mo_ScriptEngine = New ScriptControl

        mo_ScriptEngine.Language = "JScript"
    
    End If
    
  Exit Sub
ErrorHandler:
    ms_Exception = Err.Number & ":" & Err.Description & Err.Source & "CallWebService"
End Sub

Public Function JSONParse(as_json As String) As Object
    Set JSONParse = mo_ScriptEngine.Eval("(" + as_json + ")")
End Function

Public Sub SE_AssignObj(ByVal as_json As String)
    
    Dim objJSON As Object
    Set objJSON = JSONParse(as_json)
    
    Call mo_ScriptEngine.Reset
    Call mo_ScriptEngine.addObject("obj", objJSON)
    
End Sub

Public Function SE_ObjProp(ByRef as_propNme) As String
    SE_ObjProp = mo_ScriptEngine.Eval("obj." & as_propNme)
End Function

Public Function PostWebService(ByVal as_link As String, ByVal as_content As String, ByRef as_retVal As Variant, Optional ByVal as_headers As String = "Content-Type:application/x-www-form-urlencoded") As Boolean
    PostWebService = CallWebService("POST", as_link, as_content, as_retVal, as_headers)
End Function

Public Function GetWebService(ByVal as_link As String, ByRef as_retVal As Variant, Optional ByVal as_headers As String = "") As Boolean
    GetWebService = CallWebService("GET", as_link, "", as_retVal, as_headers)
End Function

Public Function DeleteWebService(ByVal as_link As String, ByRef as_retVal As Variant, Optional ByVal as_headers As String = "") As Boolean
    DeleteWebService = CallWebService("DELETE", as_link, "", as_retVal, as_headers)
End Function

Private Function CallWebService(ByVal as_method As String, ByVal as_link As String, ByVal as_content As String, ByRef as_retVal As Variant, ByVal as_headers As String) As Boolean
On Error GoTo ErrHandler
    CallWebService = False
    ms_Exception = ""
    
    Dim lo_MSXML As XMLHTTP
    
    Set lo_MSXML = New XMLHTTP
    Call lo_MSXML.open(as_method, as_link, False)
    If ms_authToken <> "" Then
        Call lo_MSXML.setRequestHeader("Authorization", ms_authToken)
    End If
    Call lo_MSXML.setRequestHeader("User-Agent", "GMail")
    
    If as_headers <> "" Then
        Dim lsa_header() As String
        lsa_header = Split(as_headers, ":", , vbTextCompare)
        If UBound(lsa_header) > 0 Then
            Call lo_MSXML.setRequestHeader(lsa_header(0), lsa_header(1))
        End If
        
    End If
    
    lo_MSXML.send (as_content)
'    lo_MSXML.getResponseHeader ("Preference-Applied")

    Dim ls_contentType As String
    ls_contentType = lo_MSXML.getResponseHeader("Content-type")
    
    If ContainString(ls_contentType, "application/json") Or ContainString(ls_contentType, "text/json") Or ContainString(ls_contentType, "text/plain") Then
        as_retVal = lo_MSXML.responseText
    Else
        as_retVal = lo_MSXML.responseBody
    End If
    
    If Left(lo_MSXML.Status, 1) <> "2" Then
        ' no 200 response
        ms_Exception = ms_Exception & " Status: " & lo_MSXML.Status & "->" & HandleWebError(as_retVal)
        Set lo_MSXML = Nothing
        Exit Function
    End If
    
    Set lo_MSXML = Nothing
    
    CallWebService = True
    Exit Function
ErrHandler:
    Set lo_MSXML = Nothing
    as_retVal = ""
    ms_Exception = Err.Number & ":" & Err.Description & Err.Source & "CallWebService"
End Function

Private Function ContainString(ByVal as_string As String, ByVal as_val As String) As Boolean
    Dim ll_pos As Long
    ll_pos = InStr(1, as_string, as_val, vbTextCompare)
    
    ContainString = (ll_pos > 0)
    
End Function

Public Sub SetAuthToken(ByRef as_tokenType As String, ByRef as_token As String)
    ms_authToken = as_tokenType & " " & as_token
End Sub

Public Function GetRND() As String
    Static counter As Long
    
    If counter = 0 Then
        counter = Now
    End If

    GetRND = ("rnd=" & counter)
    counter = counter + 1
    If counter > 42949672955# Then
        counter = 0
    End If
End Function

Private Function HandleWebError(ByVal as_json) As String

    HandleWebError = ""
    
    On Error Resume Next
    Call ArmREST.SE_AssignObj(as_json)
    If ArmREST.SE_ObjProp("error.code") <> "" Then
        HandleWebError = ArmREST.SE_ObjProp("error.code") & ":" & ArmREST.SE_ObjProp("error.message")
    End If

End Function

Public Function JsonEscape(sText As String) As String
    Const STR_CODES     As String = "\u0000|\u0001|\u0002|\u0003|\u0004|\u0005|\u0006|\u0007|\b|\t|\n|\u000B|\f|\r|\u000E|\u000F|\u0010|\u0011|\u0012|\u0013|\u0014|\u0015|\u0016|\u0017|\u0018|\u0019|\u001A|\u001B|\u001C|\u001D|\u001E|\u001F"
    Static vTranscode   As Variant
    Dim lIdx            As Long
    Dim lAsc            As Long

    If IsEmpty(vTranscode) Then
        vTranscode = Split(STR_CODES, "|")
    End If
    For lIdx = 1 To Len(sText)
        lAsc = AscW(Mid$(sText, lIdx, 1))
        If lAsc = 92 Or lAsc = 34 Then '--- \ and "
            JsonEscape = JsonEscape & "\" & ChrW$(lAsc)
        ElseIf lAsc >= 32 And lAsc < 256 Then
            JsonEscape = JsonEscape & ChrW$(lAsc)
        ElseIf lAsc >= 0 And lAsc < 32 Then
            JsonEscape = JsonEscape & vTranscode(lAsc)
        ElseIf Asc(Mid$(sText, lIdx, 1)) <> 63 Or Mid$(sText, lIdx, 1) = "?" Then '--- ?
            JsonEscape = JsonEscape & ChrW$(AscW(Mid$(sText, lIdx, 1)))
        Else
            JsonEscape = JsonEscape & "\u" & Right$("0000" & Hex$(lAsc), 4)
        End If
    Next
End Function
