Kyle--
You received this message because you are subscribed to the Google Groups "Excel Liberation" group.
To unsubscribe from this group and stop receiving emails from it, send an email to excel-ramblin...@googlegroups.com.
For more options, visit https://groups.google.com/groups/opt_out.
Implements IAuthenticator
Option Explicit
' --------------------------------------------- '
' Properties
' --------------------------------------------- '
Public ClientId As String
Public ClientSecret As String
Public Username As String
Public Password As String
Public TokenUrl As String
Public TokenKey As String
Public Token As String
Public AuthUrl As String
Public AuthCode As String
Public CacheToken As Boolean
Private ieComplete As Boolean
Private WithEvents oIExplorer As InternetExplorer
' ============================================= '
' Public Methods
' ============================================= '
''
' Helper for setting required parameters at once
'
' @param {String} ClientId
' @param {String} ClientSecret
' --------------------------------------------- '
Public Sub Setup(ClientId As String, ClientSecret As String)
Me.ClientId = ClientId
Me.ClientSecret = ClientSecret
End Sub
''
' Setup token url that is used to request token
'
' @param (String) AuthUrl
' @param {String} TokenUrl
' @param {String} [TokenKey="access_token"] The key used to retrieve the token from the response
' --------------------------------------------- '
Public Sub SetupTokenUrl(AuthUrl As String, TokenUrl As String, Optional TokenKey As String = "access_token")
Me.TokenUrl = TokenUrl
Me.TokenKey = TokenKey
Me.AuthUrl = AuthUrl
End Sub
Private Sub IAuthenticator_BeforeExecute(Request As RestRequest)
On Error GoTo ErrorHandling
If (Me.Token = "" Or Not Me.CacheToken) And (Me.TokenUrl <> "" And Me.TokenKey <> "") Then
Set oIExplorer = New InternetExplorer
With oIExplorer
.Navigate CreateAuthRequest()
.AddressBar = False
.MenuBar = False
.Resizable = False
.Visible = True
End With
'Wait for userInteraction
Do: DoEvents: Loop Until ieComplete
'Do we have an Authentication Code?
If Len(Me.AuthCode) = 0 Then
Err.Raise vbObjectError + 2, _
Description:="User cancelled Authentication"
End If
'Now Get a new Token
Dim http As MSXML2.ServerXMLHTTP
Set http = New MSXML2.ServerXMLHTTP
Call http.Open("POST", Me.TokenUrl, False)
http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
Call http.send(CreateTokenRequest())
If http.Status <> 200 Then
' Error getting OAuth2 token
Err.Raise vbObjectError + http.Status, _
Description:="Failed to retrieve OAuth2 Token - " & http.Status & ": " & http.responseText
End If
Dim Response As Dictionary
Set Response = RestHelpers.ParseJSON(http.responseText)
If Not Response Is Nothing Then
If Response.Exists(Me.TokenKey) Then
Me.Token = Response(Me.TokenKey)
End If
' (Salesforce specific, but shouldn't affect any other OAuth2 clients)
If Response.Exists("instance_url") Then
Request.BaseUrl = Response("instance_url")
End If
Else
Err.Raise vbObjectError + 2, _
Description:="Failed to read OAuth2 Token"
End If
End If
Call Request.AddHeader("Authorization", CreateHeader())
ErrorHandling:
If Not http Is Nothing Then Set http = Nothing
If Not Response Is Nothing Then Set Response = Nothing
If Err.Number <> 0 Then
' Rethrow error
Err.Raise Err.Number, Description:=Err.Description
End If
End Sub
Private Sub IAuthenticator_HttpOpen(http As MSXML2.IXMLHTTPRequest, Request As RestRequest, BaseUrl As String, Optional useAsync As Boolean = False)
' Perform standard http open
Call http.Open(Request.MethodName(), Request.FullUrl(BaseUrl), useAsync)
End Sub
' ============================================= '
' Private Methods
' ============================================= '
Private Function CreateHeader() As String
' Create standard OAuth2 header
CreateHeader = "Bearer " & Me.Token
End Function
Private Function CreateAuthRequest() As String
' Generate initial Authentication Request
' Using installed application flow: https://developers.google.com/accounts/docs/OAuth2InstalledApp
CreateAuthRequest = Me.AuthUrl
If InStr(1, CreateAuthRequest, "?") < 1 Then: CreateAuthRequest = CreateAuthRequest & "?"
CreateAuthRequest = CreateAuthRequest & "response_type=code"
CreateAuthRequest = CreateAuthRequest & "&client_id=" & Me.ClientId
CreateAuthRequest = CreateAuthRequest & "&&redirect_uri=urn:ietf:wg:oauth:2.0:oob"
CreateAuthRequest = CreateAuthRequest & "&scope=openid"
End Function
Private Function CreateTokenRequest() As String
CreateTokenRequest = "code=" & Me.AuthCode
CreateTokenRequest = CreateTokenRequest & "&client_id=" & Me.ClientId
CreateTokenRequest = CreateTokenRequest & "&client_secret=" & Me.ClientSecret
CreateTokenRequest = CreateTokenRequest & "&redirect_uri=urn:ietf:wg:oauth:2.0:oob" 'More Likely than not to be static
CreateTokenRequest = CreateTokenRequest & "&grant_type=authorization_code" 'More Likely than not to be static
End Function
'Break Loop on user Quit of IE
Private Sub oIExplorer_OnQuit()
ieComplete = True
End Sub
Private Sub oIExplorer_TitleChange(ByVal Text As String)
If InStr(1, Text, "Success") > 0 Then
Me.AuthCode = oIExplorer.Document.getElementbyid("code").Value
oIExplorer.Quit
ElseIf InStr(1, Text, "Denied") > 0 Then
oIExplorer.Quit
End If
End Sub
Option Explicit
Private Enum AuthenticationStatus NotAuthenticated = 1 TokenExpired = 2 Authenticated = 3End Enum
Private strClientId As StringPrivate strClientSecret As String
Private strTokenKey As StringPrivate strToken As StringPrivate strRefreshToken As String
Private strAuthUrl As StringPrivate strTokenUrl As StringPrivate strAuthCode As String
Private dtExpiresWhen As Date
Private blnCacheToken As BooleanPrivate blnIeComplete As Boolean
Private oScriptControl As ObjectPrivate strResponseText As StringPrivate oResponse As Object
Private strRedirectUri As StringPrivate Const CONST_STR_GRANT_TYPE As String = "grant_type=authorization_code"Private Const CONST_STR_AUTH_RESPONSE_TYPE As String = "response_type=code"
Private WithEvents oIExplorer As InternetExplorer
Private Sub Class_Initialize() 'Import the refreshy stuff strToken = GetSetting("GoogleAuth", "Tokens", "Token") strRefreshToken = GetSetting("GoogleAuth", "Tokens", "RefreshKey") Dim sDate As String sDate = GetSetting("GoogleAuth", "Tokens", "TokenExpiry") If Len(sDate) > 0 Then dtExpiresWhen = CDate(sDate) Else dtExpiresWhen = #1/1/1900# End IfEnd SubPublic Sub InitEndPoints( _ Optional ByVal AuthUrl As String = "https://accounts.google.com/o/oauth2/auth", _ Optional ByVal TokenUrl As String = "https://accounts.google.com/o/oauth2/token", _ Optional ByVal RedirectUri As String = "urn:ietf:wg:oauth:2.0:oob" _) strAuthUrl = AuthUrl strTokenUrl = TokenUrl strRedirectUri = RedirectUri End SubPublic Sub InitClientCredentials(ByVal ClientId As String, ByVal ClientSecret As String)
strClientId = ClientId strClientSecret = ClientSecret
End SubPrivate Function getAuthenticationStatus() As AuthenticationStatus If Len(strRefreshToken) = 0 Then getAuthenticationStatus = NotAuthenticated Exit Function End If If dtExpiresWhen < DateAdd("s", 10, Now()) Then getAuthenticationStatus = TokenExpired Exit Function End If getAuthenticationStatus = Authenticated End FunctionPrivate Sub GetNewToken() Dim http As MSXML2.ServerXMLHTTP ' If (strToken = "" Or Not blnCacheToken) And (strTokenUrl <> "" And strTokenKey <> "") Then
Set oIExplorer = New InternetExplorer With oIExplorer .Navigate CreateAuthRequest() .AddressBar = False .MenuBar = False .Resizable = False .Visible = True End With 'Wait for userInteraction
Do: DoEvents: Loop Until blnIeComplete
'Do we have an Authentication Code?
If Len(strAuthCode) = 0 Then
Err.Raise vbObjectError + 2, _ Description:="User cancelled Authentication" End If 'Now Get a new Token
Set http = New MSXML2.ServerXMLHTTP
Call http.Open("POST", strTokenUrl, False)
http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded" Call http.send(CreateTokenRequest())
If http.Status <> 200 Then ' Error getting OAuth2 token Err.Raise vbObjectError + http.Status, _ Description:="Failed to retrieve OAuth2 Token - " & http.Status & ": " & http.responseText End If
strToken = GetProp("access_token", http.responseText) strRefreshToken = GetProp("refresh_token") dtExpiresWhen = DateAdd("s", CLng(GetProp("expires_in")), Now()) 'Persist the Refresh key and expiry - the above should only ever need running once per application SaveSetting "GoogleAuth", "Tokens", "RefreshKey", strRefreshToken SaveSetting "GoogleAuth", "Tokens", "Token", strToken SaveSetting "GoogleAuth", "Tokens", "TokenExpiry", CStr(dtExpiresWhen) ' End IfEnd Sub
Private Sub RefreshToken()
Dim http As MSXML2.ServerXMLHTTP Set http = New MSXML2.ServerXMLHTTP
Call http.Open("POST", strTokenUrl, False) http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded" Call http.send(CreateRefreshRequest())
If http.Status <> 200 Then ' Error getting OAuth2 token Err.Raise vbObjectError + http.Status, _ Description:="Failed to retrieve OAuth2 Token - " & http.Status & ": " & http.responseText End If
strToken = GetProp("access_token", http.responseText) dtExpiresWhen = DateAdd("s", CLng(GetProp("expires_in")), Now()) SaveSetting "GoogleAuth", "Tokens", "Tokens", strToken SaveSetting "GoogleAuth", "Tokens", "TokenExpiry", CStr(dtExpiresWhen) End Sub
Private Function CreateAuthRequest() As String ' Generate initial Authentication Request ' Using installed application flow: https://developers.google.com/accounts/docs/OAuth2InstalledApp
CreateAuthRequest = strAuthUrl
If InStr(1, CreateAuthRequest, "?") < 1 Then: CreateAuthRequest = CreateAuthRequest & "?"
CreateAuthRequest = CreateAuthRequest & CONST_STR_AUTH_RESPONSE_TYPE CreateAuthRequest = CreateAuthRequest & "&client_id=" & strClientId CreateAuthRequest = CreateAuthRequest & "&redirect_uri=" & strRedirectUri CreateAuthRequest = CreateAuthRequest & "&scope=https%3A%2F%2Fwww.googleapis.com%2Fauth%2Fanalytics.readonly"
End Function
Private Function CreateTokenRequest() As String
CreateTokenRequest = "code=" & strAuthCode CreateTokenRequest = CreateTokenRequest & "&client_id=" & strClientId CreateTokenRequest = CreateTokenRequest & "&client_secret=" & strClientSecret
CreateTokenRequest = CreateTokenRequest & "&redirect_uri=urn:ietf:wg:oauth:2.0:oob" 'More Likely than not to be static
CreateTokenRequest = CreateTokenRequest & "&" & CONST_STR_GRANT_TYPE 'More Likely than not to be static
End Function
Private Function CreateRefreshRequest() As String
CreateRefreshRequest = "client_id=" & strClientId CreateRefreshRequest = CreateRefreshRequest & "&client_secret=" & strClientSecret CreateRefreshRequest = CreateRefreshRequest & "&refresh_token=" & strRefreshToken CreateRefreshRequest = CreateRefreshRequest & "&grant_type=refresh_token" End Function
Private Function GetProp(strPropName As String, Optional strJSObject As String = "") As String If oScriptControl Is Nothing Then Set oScriptControl = CreateObject("ScriptControl") With oScriptControl .Language = "JScript" .AddCode "function getProp(json, prop) { return json[prop]; }" If Len(strJSObject) > 0 Then strResponseText = strJSObject Set oResponse = .eval("(" & strJSObject & ")") End If GetProp = .Run("getProp", oResponse, strPropName) End With
End Function'IE handling
'Break Loop on user Quit of IEPrivate Sub oIExplorer_OnQuit()
blnIeComplete = TrueEnd Sub
'Check the title Window, if Success or Denied Found End the IE interaction
Private Sub oIExplorer_TitleChange(ByVal Text As String) If InStr(1, Text, "Success") > 0 Then
strAuthCode = oIExplorer.Document.getElementbyid("code").value
oIExplorer.Quit ElseIf InStr(1, Text, "Denied") > 0 Then oIExplorer.Quit End IfEnd Sub
Public Function Query(strQuery As String) As String Dim eAuthStatus As AuthenticationStatus Dim Request As MSXML2.ServerXMLHTTP eAuthStatus = getAuthenticationStatus If eAuthStatus = NotAuthenticated Then GetNewToken ElseIf eAuthStatus = TokenExpired Then RefreshToken End If Set Request = New MSXML2.ServerXMLHTTP With Request .Open "GET", strQuery, False .setRequestHeader "Authorization", "Bearer " & strToken .send Query = .responseText End With End Function
Sub test()Dim o As OAuth2GoogleAuthenticatorSet o = New OAuth2GoogleAuthenticatoro.InitClientCredentials "ID", "Secret"o.InitEndPointsDebug.Print o.Query("https://www.googleapis.com/analytics/v3/data/ga?ids=sdfd")
End Sub
' ================================================================================== ''' OAuth 2.0 Google Authenticator' Developed by Kyle Beachill' licence: MIT (http://www.opensource.org/licenses/mit-license.php)'' Inspired loosely by Tim Halls authentication classes in his Excel-Rest library:''' Features:' Simple class to handle Google OAuth 2.0 Authentication' Follows the Installed Application Flow' Returns Simply the value for the Authorization header in API requests'' Gotchas:' Tokens are held in plain text in the registry'' Required References:' - Microsoft Internet Controls' - Microsoft XML'' ================================================================================== '
Option Explicit
'// Simple enum for current authentication status
Private Enum AuthenticationStatus NotAuthenticated = 1 TokenExpired = 2 Authenticated = 3End Enum
'// Application Client ID and Application Secret
Private strClientId As StringPrivate strClientSecret As String
'// Authentication codes, tokens and expiry date
Private strTokenKey As StringPrivate strToken As StringPrivate strRefreshToken As String
Private dtExpiresWhen As DatePrivate strAuthCode As String
'// Url End points for the authentication
Private strAuthUrl As StringPrivate strTokenUrl As String
Private strRedirectUri As String
'// Internet Explorer variables for initial authentication request
Private WithEvents oIExplorer As InternetExplorer
Private blnIeComplete As Boolean
Private strResponseText As StringPrivate oResponse As Object
'// Save the request object to prevent being created for each token expiryPrivate objXMLRequest As MSXML2.ServerXMLHTTP
'// Since we are persisting the credentials to the registry, we need to read these in each time the class'// is initialized, if they aren't found - these will be default values, "" for strings and 1900/01/01 for te datePrivate Sub Class_Initialize() Dim sDate As String
strToken = GetSetting("GoogleAuth", "Tokens", "Token") strRefreshToken = GetSetting("GoogleAuth", "Tokens", "RefreshKey")
sDate = GetSetting("GoogleAuth", "Tokens", "TokenExpiry") If Len(sDate) > 0 Then dtExpiresWhen = CDate(sDate) Else dtExpiresWhen = #1/1/1900# End If End Sub
'// Allows the overriding of the default google EndPoints - these are unlikely to change
Public Sub InitEndPoints( _ Optional ByVal AuthUrl As String = "https://accounts.google.com/o/oauth2/auth", _ Optional ByVal TokenUrl As String = "https://accounts.google.com/o/oauth2/token", _ Optional ByVal RedirectUri As String = "urn:ietf:wg:oauth:2.0:oob" _) strAuthUrl = AuthUrl strTokenUrl = TokenUrl strRedirectUri = RedirectUri End Sub
'// Application ID and Secret will always need passing, since they are required for refresh calls'// Though these *could* be persisted in the registry also
Public Sub InitClientCredentials(ByVal ClientId As String, ByVal ClientSecret As String)
strClientId = ClientId strClientSecret = ClientSecret
End Sub
'// Simple function to return the authentication status of the currently held credentials
Private Function getAuthenticationStatus() As AuthenticationStatus
'// If the Refresh Token Length is 0 then the initial authentication hasn't occurred
If Len(strRefreshToken) = 0 Then getAuthenticationStatus = NotAuthenticated Exit Function End If
'// If the refresh date is less than now (with a 10 second buffer) then the token has expired
If dtExpiresWhen < DateAdd("s", 10, Now()) Then getAuthenticationStatus = TokenExpired Exit Function End If
'// Otherwise the token is valid
getAuthenticationStatus = Authenticated End FunctionPrivate Sub GetNewToken()
Set oIExplorer = New InternetExplorer With oIExplorer .Navigate CreateAuthRequest() .AddressBar = False .MenuBar = False .Resizable = False .Visible = True End With
'// Wait for userInteraction
Do: DoEvents: Loop Until blnIeComplete
'// Do we have an Authentication Code?
If Len(strAuthCode) = 0 Then Err.Raise vbObjectError + 2, _ Description:="User cancelled Authentication" End If
'// Now Get a new Token If objXMLRequest Is Nothing Then Set objXMLRequest = New MSXML2.ServerXMLHTTP With objXMLRequest .Open "POST", strTokenUrl, False .setRequestHeader "Content-Type", "application/x-www-form-urlencoded" .send CreateTokenRequest()
If .Status <> 200 Then '// Error getting OAuth2 token
Err.Raise vbObjectError + http.Status, _ Description:="Failed to retrieve OAuth2 Token - " & http.Status & ": " & http.responseText End If
'// Get the credentials from the response strToken = GetProp("access_token", .responseText)
strRefreshToken = GetProp("refresh_token") dtExpiresWhen = DateAdd("s", CLng(GetProp("expires_in")), Now())
End With '// Persist the Refresh key and expiry - the above should only ever need running once per application
SaveSetting "GoogleAuth", "Tokens", "RefreshKey", strRefreshToken SaveSetting "GoogleAuth", "Tokens", "Token", strToken SaveSetting "GoogleAuth", "Tokens", "TokenExpiry", CStr(dtExpiresWhen)
End Sub
Private Sub RefreshToken()
If objXMLRequest Is Nothing Then Set objXMLRequest = New MSXML2.ServerXMLHTTP With objXMLRequest .Open "POST", strTokenUrl, False .setRequestHeader "Content-Type", "application/x-www-form-urlencoded" .send CreateRefreshRequest() If .Status <> 200 Then '// Error getting OAuth2 token
Err.Raise vbObjectError + http.Status, _ Description:="Failed to retrieve OAuth2 Token - " & http.Status & ": " & http.responseText End If
'// Get the credentials from the response strToken = GetProp("access_token", .responseText)
dtExpiresWhen = DateAdd("s", CLng(GetProp("expires_in")), Now())
End With '// Persist new token in registry
SaveSetting "GoogleAuth", "Tokens", "Token", strToken SaveSetting "GoogleAuth", "Tokens", "TokenExpiry", CStr(dtExpiresWhen)
End Sub'// Simple function that gets a propery from a single depth JSON formatted string'// Requires the property name'// Requires te JSON string on the first pass
Private Function GetProp(strPropName As String, Optional strJSObject As String = "") As String
Static oScriptControl As Object
If oScriptControl Is Nothing Then Set oScriptControl = CreateObject("ScriptControl") With oScriptControl .Language = "JScript" .AddCode "function getProp(json, prop) { return json[prop]; }" If Len(strJSObject) > 0 Then strResponseText = strJSObject Set oResponse = .eval("(" & strJSObject & ")") End If GetProp = .Run("getProp", oResponse, strPropName) End With
End Function
'// Public property to return the Authorisation value header for a requestPublic Property Get AuthHeader() As String Dim eAuthStatus As AuthenticationStatus
eAuthStatus = getAuthenticationStatus If eAuthStatus = NotAuthenticated Then GetNewToken ElseIf eAuthStatus = TokenExpired Then RefreshToken End If
AuthHeader = "Bearer " & strToken End Property
'//==========================================================================================================='// String building functions for the requests
'// Step 1: The initial url for authentication - Note the scope attribute, this sets what the application can access
Private Function CreateAuthRequest() As String ' Generate initial Authentication Request ' Using installed application flow: https://developers.google.com/accounts/docs/OAuth2InstalledApp CreateAuthRequest = strAuthUrl If InStr(1, CreateAuthRequest, "?") < 1 Then: CreateAuthRequest = CreateAuthRequest & "?"
CreateAuthRequest = CreateAuthRequest & "response_type=code"
CreateAuthRequest = CreateAuthRequest & "&client_id=" & strClientId CreateAuthRequest = CreateAuthRequest & "&redirect_uri=" & strRedirectUri CreateAuthRequest = CreateAuthRequest & "&scope=https%3A%2F%2Fwww.googleapis.com%2Fauth%2Fanalytics.readonly"End Function
'// Step 2: The initial POST body to get the initial Token and refresh token
Private Function CreateTokenRequest() As String
CreateTokenRequest = "code=" & strAuthCode CreateTokenRequest = CreateTokenRequest & "&client_id=" & strClientId CreateTokenRequest = CreateTokenRequest & "&client_secret=" & strClientSecret
CreateTokenRequest = CreateTokenRequest & "&redirect_uri=" & strRedirectUri
CreateTokenRequest = CreateTokenRequest & "&grant_type=authorization_code"
End Function
'// Step 3: The POST body to refresh a token after it has expired
Private Function CreateRefreshRequest() As String
CreateRefreshRequest = "client_id=" & strClientId CreateRefreshRequest = CreateRefreshRequest & "&client_secret=" & strClientSecret CreateRefreshRequest = CreateRefreshRequest & "&refresh_token=" & strRefreshToken CreateRefreshRequest = CreateRefreshRequest & "&grant_type=refresh_token" End Function
'//==========================================================================================================='// Event handling for Internet Explorer Object'// OAuth 2.0 Process flow requires a user to provide access through the browser for initial Authentication
'//Break Loop on user Quit of IE
Private Sub oIExplorer_OnQuit() blnIeComplete = TrueEnd Sub
'//Check the title Window, if Success or Denied Found End the IE interaction
Private Sub oIExplorer_TitleChange(ByVal Text As String)
If InStr(1, Text, "Success") > 0 Then
strAuthCode = oIExplorer.Document.getElementbyid("code").Value
oIExplorer.Quit ElseIf InStr(1, Text, "Denied") > 0 Then oIExplorer.Quit End If
End Sub
Public Function addGoogleScope(s As String) As cOauth2
With pPackage.child("parameters")
Select Case s
Case "analytics"
.add "scope", URLEncode("https://www.googleapis.com/auth/analytics.readonly")
Case "drive"
.add "scope", URLEncode("https://www.googleapis.com/auth/drive")
Case "feeds"
.add "scope", URLEncode("https://spreadsheets.google.com/feeds")
Case "viz"
.add "scope", URLEncode("https://spreadsheets.google.com/feeds") + "+" & _
URLEncode("https://www.googleapis.com/auth/drive")
Case "urlshortener"
.add "scope", URLEncode("https://www.googleapis.com/auth/urlshortener")
Case default
Debug.Assert False
End Select
End With
Set addGoogleScope = Me
End Function
Hi kyle
I usually usestrings for something that might be user extended on their own version. Avoids having multiple versions of a global enum. If its something that is unlikely to need extending then I'd use an enum.
On the encryption, i still haven't figured the 64 bit version.
Bru e
Hi
--
You received this message because you are subscribed to the Google Groups "Excel Liberation" group.
To unsubscribe from this group and stop receiving emails from it, send an email to excel-ramblings+unsubscribe@googlegroups.com.
For more options, visit https://groups.google.com/d/optout.
Hello Bruce, and thanks to Kyle for the contribution.
--
You received this message because you are subscribed to the Google Groups "Excel Liberation" group.
To unsubscribe from this group and stop receiving emails from it, send an email to excel-ramblin...@googlegroups.com.