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""
}
]
}
}
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