'Version 1.2
'Greg Lovern, July 2009
'http://PrecisionCalc.com
Option Explicit
Private Declare Sub GetSystemTime Lib "kernel32.dll" (lpSystemTime As SYSTEMTIME)
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
'====================================================================================================
'THIS IS FOR AWS (NOW PRODUCT ADVERTIZING?) SIGNED REQUESTS.
'http://developer.amazonwebservices.com/connect/thread.jspa?threadID=33204&start=15&tstart=0
'To get a signed URL, call GetSignedURL, passing in:
'Your unsigned URL (the URL that would do what you want if signatures were not required).
'Your Access Key ID
'Your Secret Access Key
'To get your "Access Key ID" and "Secret Access Key":
'browse to http://aws.amazon.com
'from the menu, choose Your Account | Access Identifiers.
'when the login page appears, enter the AWS account email and password.
'then see:
'"Your Access Key ID:"
'"Your Secret Access Key:"
'(click Show)
'Example of calling GetSignedURL is test_GetSignedURL:
Sub test_GetSignedURL()
Dim strURL As String
Dim strAccessKeyID As String
Dim strSecretAccessKey As String
Dim strSignedURL As String
'example URL from AWS documentation:
strURL = "http://webservices.amazon.com/onca/xml?Service=AWSECommerceService&Operation=ItemLookup&ItemId=0679722769&ResponseGroup=ItemAttributes%2COffers%2CImages%2CReviews&Version=2009-01-06"
'strURL must NOT include these parameters, which will be added by GetSignedURL:
'Timestamp
'AWSAccessKeyId
'Signature
'domain must be "webservices.amazon.com". "ecs.amazonaws.com" will not work with signed requests.
strAccessKeyID = "PUT_YOUR_ACCESS_KEY_ID_HERE" 'Access Key ID
strSecretAccessKey = "PUT_YOUR_SECRET_ACCESS_KEY_HERE" 'Secret Access Key
strSignedURL = GetSignedURL(strURL, strAccessKeyID, strSecretAccessKey)
Debug.Print "Enter this URL in a browser:"
Debug.Print strSignedURL
End Sub
'====================================================================================================
Public Function GetSignedURL(strURL As String, strAccessKeyID As String, strSecretAccessKey As String) 'GJL
'strURL must NOT include these parameters, which will be added to the URL returned by this function:
'Timestamp
'AWSAccessKeyId
'Signature
'The domain in strURL must be "webservices.amazon.com". "ecs.amazonaws.com" will not work with signed requests.
Dim strSignature As String
strURL = strURL & "&Timestamp=" & GetIsoTimestamp
strURL = strURL & "&AWSAccessKeyId=" & strAccessKeyID
GetSignedURL = signEncode(strURL, strSecretAccessKey)
End Function
Private Function GetIsoTimestamp() As String
'Return an ISO 8601 compliant timestamp.
Dim st As SYSTEMTIME
'Get the local date and time.
GetSystemTime st
'Format the result.
GetIsoTimestamp = _
Format$(st.wYear, "0000") & "-" & _
Format$(st.wMonth, "00") & "-" & _
Format$(st.wDay, "00") & "T" & _
Format$(st.wHour, "00") & ":" & _
Format$(st.wMinute, "00") & ":" & _
Format$(st.wSecond, "00") & "Z"
End Function
Function signEncode(ByVal URL As String, SKey As String) As String
Dim http As String
Dim i As Integer, j As Integer
Dim tmp As String
Dim LF As String
Dim header As String
Dim Signature As String
Dim originalURL As String
Dim PVP As Variant 'will become array, but do not declare as array.
'Typical request:
'http://webservices.amazon.com/onca/xml?Service=AWSECommerceService&AWSAccessKeyId=00000000000000000000&Operation=ItemLookup&ItemId=0679722769&ResponseGroup=ItemAttributes,Offers,Images,Reviews&Version=2009-01-06
originalURL = URL
'Encode commas and colon characters
URL = URLClean(URL)
'Split and sort your parameter/value pairs by byte value (not alphabetically, lowercase parameters will be
'listed after uppercase ones).
http = Left$(URL, InStr(URL, "?"))
URL = Mid$(URL, Len(http) + 1)
PVP = Split(URL, "&")
For i = LBound(PVP) To UBound(PVP) - 1
For j = i + 1 To UBound(PVP)
If PVP(i) > PVP(j) Then
tmp = PVP(i)
PVP(i) = PVP(j)
PVP(j) = tmp
End If
Next
Next
'Rejoin the sorted parameter/value list with ampersands. The result is the canonical string that we'll sign
URL = ""
For i = LBound(PVP) To UBound(PVP)
If i UBound(PVP) Then
URL = URL & PVP(i) & "&"
Else
URL = URL & PVP(i)
End If
Next
'Prepend the following three lines (with line breaks) before the canonical string:
'GET
'webservices.amazon.com
'/onca/xml
LF = Chr(10)
Dim strDomain As String
strDomain = GetDomainFromURL(http) 'to handle webservices.amazon.ca, webservices.amazon.co.uk, etc.
header = "GET" & LF & strDomain & LF & "/onca/xml" & LF
'Calculate an RFC 2104-compliant HMAC with the SHA256 hash algorithm using the string above
Signature = HMAC(header & URL, SKey)
Signature = Replace(Signature, "=", "%3D")
Signature = Replace(Signature, "+", "%2B")
signEncode = http & URL & "&Signature=" & Signature
End Function
Function HMAC(ByVal Text As String, ByVal Key As String) As String
Dim oSHA256 As CSHA256
Dim i As Integer
Dim HASH As String
Dim arKey() As Byte
Dim ipad As String, opad As String
'HMAC(key, message) is
'hash ((Key ^ outerpad) + hash((Key ^ innerpad) + message))
'where + denotes concatenation, ^ denotes XOR, and outerpad and innerpad
'are bytes 0x36 and 0x5C, respectively, repeated for the length of the
'key, which is padded with zeros to the block size of the hash.
Set oSHA256 = New CSHA256
'key needs to be 64 bytes long
ReDim arKey(0 To 63)
'first hash the key if it's longer than 64 bytes
If Len(Key) > 64 Then
HASH = oSHA256.SHA256(Key)
Key = StringHex(HASH)
For i = 0 To 63
arKey(i) = Asc(Mid(Key, i + 1, 1))
Next
Else
For i = 0 To Len(Key) - 1
arKey(i) = Asc(Mid(Key, i + 1, 1))
Next
'pad the key array with 0
For i = Len(Key) To 63
arKey(i) = 0
Next
End If
'generate the inner pad and outer pad strings
ipad = ""
opad = ""
For i = 0 To 63
ipad = ipad & Chr(arKey(i) Xor &H36)
opad = opad & Chr(arKey(i) Xor &H5C)
Next
'get the hash of the inner pad and the string
HASH = oSHA256.SHA256(ipad & Text)
'get the hash of the outerpad and the previous hash converted to a string
HASH = oSHA256.SHA256(opad & StringHex(HASH))
'convert the final hash to a string
HASH = StringHex(HASH)
'base64 encode the hash
HMAC = Base64Enc01(HASH)
End Function
Function URLClean(Text As String) As String
'translate only the commas, colons, and spaces
Dim i As Integer
Dim acode As Integer
Dim char As String
URLClean = Text
For i = Len(URLClean) To 1 Step -1
acode = Asc(Mid$(URLClean, i, 1))
Select Case acode
Case 58, 44, 32
'replace punctuation chars with "%hex"
URLClean = Left$(URLClean, i - 1) & "%" & Hex$(acode) & Mid$(URLClean, i + 1)
End Select
If Mid$(URLClean, i, 1) = "?" Then
Exit For
End If
Next
End Function
Function GetDomainFromURL(strURL As String) As String
'looks for "//", and then looks for "/" after the "//", and returns everything between.
'returns empty string on failure.
Dim strTmp As String
Dim iPosDoubleSlash As Long
Dim iPosThirdSlash As Long
iPosDoubleSlash = InStr(strURL, "//")
If iPosDoubleSlash = 0 Then Exit Function 'strURL does not contain "//".
strTmp = Right(strURL, Len(strURL) - (iPosDoubleSlash + 1))
If Len(strURL) = iPosDoubleSlash Then Exit Function 'strURL looks like "http://".
iPosThirdSlash = InStr(strTmp, "/")
If iPosThirdSlash = 0 Then
GetDomainFromURL = strTmp 'strURL looks like "http://MyDomain.com".
Else
GetDomainFromURL = Left(strTmp, iPosThirdSlash - 1)
End If
End Function
Function StringHex(Text As String) As String
Dim lCount 'As Long
Dim sResult 'As String
Dim lLength 'As Long
lLength = Len(Text)
For lCount = 1 To lLength Step 2
sResult = sResult & Chr(Val("&H" & Mid(Text, lCount, 2)))
Next
StringHex = sResult
End Function
Public Function Base64Enc01(S$) As String
'by Nobody, 20011204
Static Enc() As Byte
Dim b() As Byte, Out() As Byte, i&, j&, L&
If (Not Val(Not Enc)) = 0 Then 'Null-Ptr = not initialized
Enc = StrConv("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/", vbFromUnicode)
End If
L = Len(S): b = StrConv(S, vbFromUnicode)
ReDim Preserve b(0 To (UBound(b) \ 3) * 3 + 2)
ReDim Preserve Out(0 To (UBound(b) \ 3) * 4 + 3)
For i = 0 To UBound(b) - 1 Step 3
Out(j) = Enc(b(i) \ 4): j = j + 1
Out(j) = Enc((b(i + 1) \ 16) Or (b(i) And 3) * 16): j = j + 1
Out(j) = Enc((b(i + 2) \ 64) Or (b(i + 1) And 15) * 4): j = j + 1
Out(j) = Enc(b(i + 2) And 63): j = j + 1
Next i
For i = 1 To i - L: Out(UBound(Out) - i + 1) = 61: Next i
Base64Enc01 = StrConv(Out, vbUnicode)
End Function
