CODEWITHSUNDEEP
phpvbabase64sha1adobe-analytics
Fubudis
Fubudis

Reputation: 251

Adobe Analytics REST API call with VBA (Original Code in PHP)

I'm trying to make a REST API call to Adobe Analytics, but I'm unable to connect with my current code and can't figure out why. I know I'm reaching the server and the header is formatted correctly because I'm getting the error below:

{"error":"Bad Request","error_description":"Unable to validate authentication.","error_uri":null}

This API specifically requires a few different encrypted components which is where I think the issue is. (Do my SHA1 and Base64 functions look correct below?) The header for the request looks like this:

X-WSSE: UsernameToken Username="will.smith:Google", PasswordDigest="QOmCMlIR4mVPTaiqmuSzM5eKZn0=", Nonce="MTRlYjY2YTM3NmNjMTVlZDk0NDkzZWFj", Created="2016-08-24T23:51:08Z"

Some notes before you read the code:

Their example code in PHP is this:

include_once("SimpleRestClient.class.php");

$username = '%%YOUR-USERNAME%%';
$secret = '%%YOUR-SECRET%%';
$nonce = md5(uniqid(php_uname('n'), true));
$nonce_ts = date('c');

$digest = base64_encode(sha1($nonce.$nonce_ts.$secret));

$server = "https://api.omniture.com";
$path = "/admin/1.3/rest/";

$rc=new SimpleRestClient();
$rc->setOption(CURLOPT_HTTPHEADER, array("X-WSSE: UsernameToken     Username=\"$username\", PasswordDigest=\"$digest\", Nonce=\"$nonce\", Created=\"$nonce_ts\""));

$query="?method=Company.GetTokenUsage";

$rc->getWebRequest($server.$path.$query);

if ($rc->getStatusCode()==200) {
    $response=$rc->getWebResponse();
    var_dump($response);
} else {
    echo "something went wrong\n";
    var_dump($rc->getInfo());
}

This is my interpretation to VBA: 

Sub GetPromoData()
    Dim objHTTP As New WinHttp.WinHttpRequest
    Dim Send    As String

    Dim Username As String
    Dim Secret As String
    Dim EndPoint As String

    Dim Time As String
    Dim nonce As String
    Dim Timestamp As String
    Dim digest As String
    Dim Header As String

    Time = DateAdd("h", 7, Now())
    'Time = Now()
    Username = "Redacted"
    Secret = "Redacted"

    'Randomize
    Timestamp = generateTimestamp(Time)
    nonce = generateNonce()
    digest = generateDigest(nonce & Timestamp & Secret)

    Debug.Print Timestamp
    Debug.Print nonce
    Debug.Print digest


    Header = "UsernameToken Username=""" & Username & """, PasswordDigest=""" & digest & """, Nonce=""" & nonce & """, Created=""" & Timestamp & """"

    Debug.Print Header

    Send = Worksheets("Promo Code Data").Range("A1").Value

    URL = "https://api.omniture.com/admin/1.4/rest/?method=Report.Queue"
    objHTTP.Open "POST", URL, False
    objHTTP.SetRequestHeader "X-WSSE", Header
    objHTTP.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    objHTTP.Send (Send)
    Debug.Print objHTTP.Status
    Debug.Print objHTTP.ResponseText

End Sub

Public Function generateTimestamp(Timestamp As String)

'Debug.Print Application.WorksheetFunction.Text(TimeStamp, "yyyy-MM-ddTHH:mm:ssZ");
generateTimestamp = Application.WorksheetFunction.Text(Timestamp, "yyyy-MM-ddTHH:mm:ssZ")

End Function

Public Function generateNonce()

Dim nonce As String

Dim alphaNumeric As Variant
alphaNumeric = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")

Randomize

For I = 1 To 32
    nonce = nonce & alphaNumeric(61 * Rnd)
Next

generateNonce = nonce

End Function


Public Function generateDigest(Values As String)

'Debug.Print SHA1Base64(Values)
generateDigest = SHA1Base64(Values)

End Function

Public Function SHA1Base64(ByVal sTextToHash As String)

    Dim asc As Object, enc As Object
    Dim TextToHash() As Byte
    Set asc = CreateObject("System.Text.UTF8Encoding")
    Set enc = CreateObject("System.Security.Cryptography.SHA1CryptoServiceProvider")
    TextToHash = asc.Getbytes_4(sTextToHash)
    Dim bytes() As Byte
    bytes = enc.ComputeHash_2((TextToHash))
    SHA1Base64 = EncodeBase64(bytes)
    Set asc = Nothing
    Set enc = Nothing

End Function

Private Function EncodeBase64(ByRef arrData() As Byte) As String

    Dim objXML As MSXML2.DOMDocument
    Dim objNode As MSXML2.IXMLDOMElement

    Set objXML = New MSXML2.DOMDocument

    ' byte array to base64
    Set objNode = objXML.createElement("b64")
    objNode.DataType = "bin.base64"
    objNode.nodeTypedValue = arrData
    EncodeBase64 = objNode.Text

    Set objNode = Nothing
    Set objXML = Nothing

End Function

Adding actual HTTP request for clarity:

{
    ""reportDescription"":{
    ""reportSuiteID"":""Redacted"",
    ""date"":""2016-8-23"",
    ""metrics"":[
        {
            ""id"":""Orders""
        }
    ],
    ""sortBy"":""Orders"",
    ""elements"":[
        {
            ""id"":""evar4"",
            ""top"":""10"",
            ""startingWith"":""1""
        }
    ]
  }
}

Upvotes: 1

Views: 756

Answers (1)

Fubudis
Fubudis

Reputation: 251

I figured out the issue. The SHA1 and Base64 Encoder I had found weren't accurate. The Send variable will have to be updated with the correct payload and the URL variable will need to be udpated with the correct method as well.

Here's a full version of the working code:

Sub CallAPI()
Dim objHTTP As New WinHttp.WinHttpRequest

Dim Send    As String

Dim Username As String
Dim Secret As String
Dim EndPoint As String

Dim Time As String
Dim Nonce As String
Dim Timestamp As String
Dim digest As String
Dim Header As String

Time = DateAdd("h", 7, Now())
'Time = Now()
Username = "USERNAME HERE"
Secret = "SECRETHERE"

Timestamp = generateTimestamp(Time)
Nonce = generateNonce()
digest = generateDigest(Nonce, Timestamp, Secret)

Debug.Print Timestamp
Debug.Print Nonce
Debug.Print digest


Header = "UsernameToken Username=""" & Username & """, PasswordDigest=""" & digest & """, Nonce=""" & Nonce & """, Created=""" & Timestamp & """"

Debug.Print Header

Send = Worksheets("Promo Code Data").Range("A1").Value

URL = "https://api.omniture.com/admin/1.4/rest/?method=Report.Queue"
objHTTP.Open "POST", URL, False
objHTTP.SetRequestHeader "X-WSSE", Header
objHTTP.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
objHTTP.Send (Send)
Debug.Print objHTTP.Status
Debug.Print objHTTP.ResponseText

End Sub

Public Function generateTimestamp(Timestamp As String)

'Debug.Print Application.WorksheetFunction.Text(TimeStamp, "yyyy-MM-ddTHH:mm:ssZ");
generateTimestamp = Application.WorksheetFunction.Text(Timestamp, "yyyy-MM-ddTHH:mm:ssZ")

End Function

Public Function generateNonce()

Dim Nonce As String


Dim alphaNumeric As Variant
alphaNumeric = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")

Randomize

For i = 1 To 32
    Nonce = Nonce & alphaNumeric(61 * Rnd)
Next

generateNonce = Nonce

End Function


Public Function generateDigest(Nonce, Timestamp, Secret)

 generateDigest = Base64EncodeString(SHA1HASH(Nonce & Timestamp & Secret))

End Function


' Based on: http://vb.wikia.com/wiki/SHA-1.bas
Option Explicit

Private Type FourBytes
    a As Byte
    b As Byte
    c As Byte
    d As Byte
End Type
Private Type OneLong
    L As Long
End Type

Function HexDefaultSHA1(message() As Byte) As String
 Dim H1 As Long, H2 As Long, H3 As Long, H4 As Long, H5 As Long
 DefaultSHA1 message, H1, H2, H3, H4, H5
 HexDefaultSHA1 = DecToHex5(H1, H2, H3, H4, H5)
End Function

Function HexSHA1(message() As Byte, ByVal Key1 As Long, ByVal Key2 As Long, ByVal Key3 As Long, ByVal Key4 As Long) As String
 Dim H1 As Long, H2 As Long, H3 As Long, H4 As Long, H5 As Long
 xSHA1 message, Key1, Key2, Key3, Key4, H1, H2, H3, H4, H5
 HexSHA1 = DecToHex5(H1, H2, H3, H4, H5)
End Function

Sub DefaultSHA1(message() As Byte, H1 As Long, H2 As Long, H3 As Long, H4 As Long, H5 As Long)
 xSHA1 message, &H5A827999, &H6ED9EBA1, &H8F1BBCDC, &HCA62C1D6, H1, H2, H3, H4, H5
End Sub

Sub xSHA1(message() As Byte, ByVal Key1 As Long, ByVal Key2 As Long, ByVal Key3 As Long, ByVal Key4 As Long, H1 As Long, H2 As Long, H3 As Long, H4 As Long, H5 As Long)
 'CA62C1D68F1BBCDC6ED9EBA15A827999 + "abc" = "A9993E36 4706816A BA3E2571 7850C26C 9CD0D89D"
 '"abc" = "A9993E36 4706816A BA3E2571 7850C26C 9CD0D89D"

 Dim U As Long, P As Long
 Dim FB As FourBytes, OL As OneLong
 Dim i As Integer
 Dim w(80) As Long
 Dim a As Long, b As Long, c As Long, d As Long, e As Long
 Dim t As Long

 H1 = &H67452301: H2 = &HEFCDAB89: H3 = &H98BADCFE: H4 = &H10325476: H5 = &HC3D2E1F0

 U = UBound(message) + 1: OL.L = U32ShiftLeft3(U): a = U \ &H20000000: LSet FB = OL 'U32ShiftRight29(U)

 ReDim Preserve message(0 To (U + 8 And -64) + 63)
 message(U) = 128

 U = UBound(message)
 message(U - 4) = a
 message(U - 3) = FB.d
 message(U - 2) = FB.c
 message(U - 1) = FB.b
 message(U) = FB.a

 While P < U
     For i = 0 To 15
         FB.d = message(P)
         FB.c = message(P + 1)
         FB.b = message(P + 2)
         FB.a = message(P + 3)
         LSet OL = FB
         w(i) = OL.L
         P = P + 4
     Next i

     For i = 16 To 79
         w(i) = U32RotateLeft1(w(i - 3) Xor w(i - 8) Xor w(i - 14) Xor w(i - 16))
     Next i

     a = H1: b = H2: c = H3: d = H4: e = H5

     For i = 0 To 19
         t = U32Add(U32Add(U32Add(U32Add(U32RotateLeft5(a), e), w(i)), Key1), ((b And c) Or ((Not b) And d)))
         e = d: d = c: c = U32RotateLeft30(b): b = a: a = t
     Next i
     For i = 20 To 39
         t = U32Add(U32Add(U32Add(U32Add(U32RotateLeft5(a), e), w(i)), Key2), (b Xor c Xor d))
         e = d: d = c: c = U32RotateLeft30(b): b = a: a = t
     Next i
     For i = 40 To 59
         t = U32Add(U32Add(U32Add(U32Add(U32RotateLeft5(a), e), w(i)), Key3), ((b And c) Or (b And d) Or (c And d)))
         e = d: d = c: c = U32RotateLeft30(b): b = a: a = t
     Next i
     For i = 60 To 79
         t = U32Add(U32Add(U32Add(U32Add(U32RotateLeft5(a), e), w(i)), Key4), (b Xor c Xor d))
         e = d: d = c: c = U32RotateLeft30(b): b = a: a = t
     Next i

     H1 = U32Add(H1, a): H2 = U32Add(H2, b): H3 = U32Add(H3, c): H4 = U32Add(H4, d): H5 = U32Add(H5, e)
 Wend
End Sub

Function U32Add(ByVal a As Long, ByVal b As Long) As Long
 If (a Xor b) < 0 Then
     U32Add = a + b
 Else
     U32Add = (a Xor &H80000000) + b Xor &H80000000
 End If
End Function

Function U32ShiftLeft3(ByVal a As Long) As Long
 U32ShiftLeft3 = (a And &HFFFFFFF) * 8
 If a And &H10000000 Then U32ShiftLeft3 = U32ShiftLeft3 Or &H80000000
End Function

Function U32ShiftRight29(ByVal a As Long) As Long
 U32ShiftRight29 = (a And &HE0000000) \ &H20000000 And 7
End Function

Function U32RotateLeft1(ByVal a As Long) As Long
 U32RotateLeft1 = (a And &H3FFFFFFF) * 2
 If a And &H40000000 Then U32RotateLeft1 = U32RotateLeft1 Or &H80000000
 If a And &H80000000 Then U32RotateLeft1 = U32RotateLeft1 Or 1
End Function
Function U32RotateLeft5(ByVal a As Long) As Long
 U32RotateLeft5 = (a And &H3FFFFFF) * 32 Or (a And &HF8000000) \ &H8000000 And 31
 If a And &H4000000 Then U32RotateLeft5 = U32RotateLeft5 Or &H80000000
End Function
Function U32RotateLeft30(ByVal a As Long) As Long
 U32RotateLeft30 = (a And 1) * &H40000000 Or (a And &HFFFC) \ 4 And &H3FFFFFFF
 If a And 2 Then U32RotateLeft30 = U32RotateLeft30 Or &H80000000
End Function

Function DecToHex5(ByVal H1 As Long, ByVal H2 As Long, ByVal H3 As Long, ByVal H4 As Long, ByVal H5 As Long) As String
 Dim H As String, L As Long
 DecToHex5 = "00000000 00000000 00000000 00000000 00000000"
 H = Hex(H1): L = Len(H): Mid(DecToHex5, 9 - L, L) = H
 H = Hex(H2): L = Len(H): Mid(DecToHex5, 18 - L, L) = H
 H = Hex(H3): L = Len(H): Mid(DecToHex5, 27 - L, L) = H
 H = Hex(H4): L = Len(H): Mid(DecToHex5, 36 - L, L) = H
 H = Hex(H5): L = Len(H): Mid(DecToHex5, 45 - L, L) = H
End Function

' Convert the string into bytes so we can use the above functions
' From Chris Hulbert: http://splinter.com.au/blog

Public Function SHA1HASH(str)
  Dim i As Integer
  Dim arr() As Byte
  ReDim arr(0 To Len(str) - 1) As Byte
  For i = 0 To Len(str) - 1
   arr(i) = asc(Mid(str, i + 1, 1))
  Next i
  SHA1HASH = Replace(LCase(HexDefaultSHA1(arr)), " ", "")
End Function


' A Base64 Encoder/Decoder.
'
' This module is used to encode and decode data in Base64 format as described in RFC 1521.
'
' Home page: www.source-code.biz.
' License: GNU/LGPL (www.gnu.org/licenses/lgpl.html).
' Copyright 2007: Christian d'Heureuse, Inventec Informatik AG, Switzerland.
' This module is provided "as is" without warranty of any kind.

Option Explicit

Private InitDone  As Boolean
Private Map1(0 To 63)  As Byte
Private Map2(0 To 127) As Byte

' Encodes a string into Base64 format.
' No blanks or line breaks are inserted.
' Parameters:
'   S         a String to be encoded.
' Returns:    a String with the Base64 encoded data.
Public Function Base64EncodeString(ByVal s As String) As String
   Base64EncodeString = Base64Encode(ConvertStringToBytes(s))
   End Function

' Encodes a byte array into Base64 format.
' No blanks or line breaks are inserted.
' Parameters:
'   InData    an array containing the data bytes to be encoded.
' Returns:    a string with the Base64 encoded data.
Public Function Base64Encode(InData() As Byte)
   Base64Encode = Base64Encode2(InData, UBound(InData) - LBound(InData) + 1)
   End Function

' Encodes a byte array into Base64 format.
' No blanks or line breaks are inserted.
' Parameters:
'   InData    an array containing the data bytes to be encoded.
'   InLen     number of bytes to process in InData.
' Returns:    a string with the Base64 encoded data.
Public Function Base64Encode2(InData() As Byte, ByVal InLen As Long) As String
   If Not InitDone Then Init
   If InLen = 0 Then Base64Encode2 = "": Exit Function
   Dim ODataLen As Long: ODataLen = (InLen * 4 + 2) \ 3     ' output length without padding
   Dim OLen As Long: OLen = ((InLen + 2) \ 3) * 4           ' output length including padding
   Dim Out() As Byte
   ReDim Out(0 To OLen - 1) As Byte
   Dim ip0 As Long: ip0 = LBound(InData)
   Dim ip As Long
   Dim op As Long
   Do While ip < InLen
      Dim i0 As Byte: i0 = InData(ip0 + ip): ip = ip + 1
      Dim i1 As Byte: If ip < InLen Then i1 = InData(ip0 + ip): ip = ip + 1 Else i1 = 0
      Dim i2 As Byte: If ip < InLen Then i2 = InData(ip0 + ip): ip = ip + 1 Else i2 = 0
      Dim o0 As Byte: o0 = i0 \ 4
      Dim o1 As Byte: o1 = ((i0 And 3) * &H10) Or (i1 \ &H10)
      Dim o2 As Byte: o2 = ((i1 And &HF) * 4) Or (i2 \ &H40)
      Dim o3 As Byte: o3 = i2 And &H3F
      Out(op) = Map1(o0): op = op + 1
      Out(op) = Map1(o1): op = op + 1
      Out(op) = IIf(op < ODataLen, Map1(o2), asc("=")): op = op + 1
      Out(op) = IIf(op < ODataLen, Map1(o3), asc("=")): op = op + 1
      Loop
   Base64Encode2 = ConvertBytesToString(Out)
   End Function

' Decodes a string from Base64 format.
' Parameters:
'    s        a Base64 String to be decoded.
' Returns     a String containing the decoded data.
Public Function Base64DecodeString(ByVal s As String) As String
   If s = "" Then Base64DecodeString = "": Exit Function
   Base64DecodeString = ConvertBytesToString(Base64Decode(s))
   End Function

' Decodes a byte array from Base64 format.
' Parameters
'   s         a Base64 String to be decoded.
' Returns:    an array containing the decoded data bytes.
Public Function Base64Decode(ByVal s As String) As Byte()
   If Not InitDone Then Init
   Dim IBuf() As Byte: IBuf = ConvertStringToBytes(s)
   Dim ILen As Long: ILen = UBound(IBuf) + 1
   If ILen Mod 4 <> 0 Then Err.Raise vbObjectError, , "Length of Base64 encoded input string is not a multiple of 4."
   Do While ILen > 0
      If IBuf(ILen - 1) <> asc("=") Then Exit Do
      ILen = ILen - 1
      Loop
   Dim OLen As Long: OLen = (ILen * 3) \ 4
   Dim Out() As Byte
   ReDim Out(0 To OLen - 1) As Byte
   Dim ip As Long
   Dim op As Long
   Do While ip < ILen
      Dim i0 As Byte: i0 = IBuf(ip): ip = ip + 1
      Dim i1 As Byte: i1 = IBuf(ip): ip = ip + 1
      Dim i2 As Byte: If ip < ILen Then i2 = IBuf(ip): ip = ip + 1 Else i2 = asc("A")
      Dim i3 As Byte: If ip < ILen Then i3 = IBuf(ip): ip = ip + 1 Else i3 = asc("A")
      If i0 > 127 Or i1 > 127 Or i2 > 127 Or i3 > 127 Then _
         Err.Raise vbObjectError, , "Illegal character in Base64 encoded data."
      Dim b0 As Byte: b0 = Map2(i0)
      Dim b1 As Byte: b1 = Map2(i1)
      Dim b2 As Byte: b2 = Map2(i2)
      Dim b3 As Byte: b3 = Map2(i3)
      If b0 > 63 Or b1 > 63 Or b2 > 63 Or b3 > 63 Then _
         Err.Raise vbObjectError, , "Illegal character in Base64 encoded data."
      Dim o0 As Byte: o0 = (b0 * 4) Or (b1 \ &H10)
      Dim o1 As Byte: o1 = ((b1 And &HF) * &H10) Or (b2 \ 4)
      Dim o2 As Byte: o2 = ((b2 And 3) * &H40) Or b3
      Out(op) = o0: op = op + 1
      If op < OLen Then Out(op) = o1: op = op + 1
      If op < OLen Then Out(op) = o2: op = op + 1
      Loop
   Base64Decode = Out
   End Function

Private Sub Init()
   Dim c As Integer, i As Integer
   ' set Map1
   i = 0
   For c = asc("A") To asc("Z"): Map1(i) = c: i = i + 1: Next
   For c = asc("a") To asc("z"): Map1(i) = c: i = i + 1: Next
   For c = asc("0") To asc("9"): Map1(i) = c: i = i + 1: Next
   Map1(i) = asc("+"): i = i + 1
   Map1(i) = asc("/"): i = i + 1
   ' set Map2
   For i = 0 To 127: Map2(i) = 255: Next
   For i = 0 To 63: Map2(Map1(i)) = i: Next
   InitDone = True
   End Sub

Private Function ConvertStringToBytes(ByVal s As String) As Byte()
   Dim b1() As Byte: b1 = s
   Dim L As Long: L = (UBound(b1) + 1) \ 2
   If L = 0 Then ConvertStringToBytes = b1: Exit Function
   Dim b2() As Byte
   ReDim b2(0 To L - 1) As Byte
   Dim P As Long
   For P = 0 To L - 1
      Dim c As Long: c = b1(2 * P) + 256 * CLng(b1(2 * P + 1))
      If c >= 256 Then c = asc("?")
      b2(P) = c
      Next
   ConvertStringToBytes = b2
   End Function

Private Function ConvertBytesToString(b() As Byte) As String
   Dim L As Long: L = UBound(b) - LBound(b) + 1
   Dim b2() As Byte
   ReDim b2(0 To (2 * L) - 1) As Byte
   Dim p0 As Long: p0 = LBound(b)
   Dim P As Long
   For P = 0 To L - 1: b2(2 * P) = b(p0 + P): Next
   Dim s As String: s = b2
   ConvertBytesToString = s
   End Function

Upvotes: 2

Related Questions